diff options
Diffstat (limited to 'stdlib')
| -rw-r--r-- | stdlib/awk.tl | 77 | ||||
| -rw-r--r-- | stdlib/conv.tl | 46 |
2 files changed, 80 insertions, 43 deletions
diff --git a/stdlib/awk.tl b/stdlib/awk.tl index 497b9e17..5eb409d3 100644 --- a/stdlib/awk.tl +++ b/stdlib/awk.tl @@ -59,7 +59,7 @@ begin-file-actions end-file-actions begin-actions end-actions cond-actions - field-names + field-name-conv (nranges 0) (rng-rec-temp (gensym)) (rng-vec-temp (gensym)) @@ -324,14 +324,24 @@ (:set-file (push ^((set ,*actions)) awc.begin-actions)) (:end-file (push actions awc.end-file-actions)) (:fields - (when awc.field-names + (when awc.field-name-conv (awk-error "duplicate :fields clauses")) - (whenlet ((fn (member-if [notf bindable] actions))) - (awk-error "~s isn't a valid field name" (car fn))) - (let ((syms (remq '- actions))) - (unless (equal syms (uniq syms)) - (awk-error "duplicate field names"))) - (set awc.field-names actions)) + (let ((fnames + (collect-each ((fn actions)) + (match-case fn + (@(bindable @sym) (list sym)) + ((@(bindable @sym) @(bindable @fun)) + (if (eq sym '-) + (awk-error "type given for unnamed field")) + fn) + ((@(bindable) @type) + (awk-error "bad fconv function: ~s" type)) + (@else (awk-error "bad :fields item: ~s" + else)))))) + (let ((nodash [remq '- fnames car])) + (unless (equal nodash [unique nodash car]) + (awk-error "duplicate field names"))) + (set awc.field-name-conv fnames))) (t (push (if actions cl ^(,pattern (prn))) @@ -475,12 +485,34 @@ ,*body)) (defmacro sys:awk-symac-let (awc . body) - ^(symacrolet ,(append-each ((fn awc.field-names) + ^(symacrolet ,(append-each ((fn awc.field-name-conv) (ix 0)) - (if (neq fn '-) - (list ^(,fn [f ,ix])))) + (if (neq (car fn) '-) + (list ^(,(car fn) [f ,ix])))) ,*body)) +(defun sys:awk-field-name-code (awc aws-sym) + (with-gensyms (fiter) + (let* ((nf 0) + (code (append-each ((fnc awc.field-name-conv) + (i 0)) + (set nf (succ i)) + (if (cadr fnc) + ^((rplaca ,fiter + (sys:conv-expand-sym ,(cadr fnc) + (car ,fiter))) + (set ,fiter (cdr ,fiter))) + ^((set ,fiter (cdr ,fiter))))))) + (while-match @(end ((set . @nil))) code + (upd code butlast)) + ^(let ((,fiter (qref ,aws-sym fields))) + (if (< (len ,fiter) ,nf) + (set ,fiter (take ,nf (append ,fiter (repeat '("")))) + (qref ,aws-sym fields) ,fiter + (qref ,aws-sym nf) ,nf)) + ,*code + (qref ,aws-sym (f-to-rec)))))) + (defun sys:awk-fun-shadowing-env (up-env) (make-env nil '((prn . sys:special)) up-env)) @@ -494,6 +526,20 @@ ^(sys:awk-mac-let ,awc ,aws-sym ,*p-actions-xform-unex) (sys:awk-fun-shadowing-env outer-env)))) + (if awc.rng-exprs + (set p-actions-xform + ^(let* ((,awc.rng-rec-temp rec) + (,awc.rng-vec-temp (qref ,aws-sym rng-vec)) + ,*(nreverse + (zip awc.rng-expr-temps + awc.rng-exprs))) + ,p-actions-xform))) + (if (and awc.field-name-conv + [some awc.field-name-conv cdr]) + (set p-actions-xform + ^(progn + ,(sys:awk-field-name-code awc aws-sym) + ,p-actions-xform))) ^(block ,(or awc.name 'awk) (let* (,*awc.lets ,awk-retval (,aws-sym (new sys:awk-state @@ -514,14 +560,7 @@ ,*(if (or awc.cond-actions awc.begin-file-actions awc.end-file-actions awc.end-actions) ^((,awk-fun (lambda (,aws-sym) - ,(if awc.rng-exprs - ^(let* ((,awc.rng-rec-temp rec) - (,awc.rng-vec-temp (qref ,aws-sym rng-vec)) - ,*(nreverse - (zip awc.rng-expr-temps - awc.rng-exprs))) - ,p-actions-xform) - p-actions-xform)))))) + ,p-actions-xform))))) ,*awc.begin-actions (unwind-protect ,(if (or awc.cond-actions awc.begin-file-actions diff --git a/stdlib/conv.tl b/stdlib/conv.tl index f2f5bd4d..ef1088cc 100644 --- a/stdlib/conv.tl +++ b/stdlib/conv.tl @@ -24,31 +24,29 @@ ;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ;; POSSIBILITY OF SUCH DAMAGE. + + +(defmacro sys:conv-expand-sym (sym arg-expr) + (caseq sym + (usr:i ^(toint ,arg-expr)) + (usr:o ^(toint ,arg-expr 8)) + (usr:x ^(toint ,arg-expr 16)) + (usr:b ^(toint ,arg-expr 2)) + (usr:c ^(toint ,arg-expr #\c)) + (usr:r ^(tofloat ,arg-expr)) + (usr:iz ^(tointz ,arg-expr)) + (usr:oz ^(tointz ,arg-expr 8)) + (usr:xz ^(tointz ,arg-expr 16)) + (usr:bz ^(tointz ,arg-expr 2)) + (usr:cz ^(tointz ,arg-expr #\c)) + (usr:rz ^(tofloatz ,arg-expr)) + (t ^(,sym ,arg-expr)))) + (defun sys:conv-let (. body) - ^(flet ((usr:i (arg : radix) - (toint arg radix)) - (usr:o (arg) - (toint arg 8)) - (usr:x (arg) - (toint arg 16)) - (usr:b (arg) - (toint arg 2)) - (usr:c (arg) - (toint arg #\c)) - (usr:r (arg) - (tofloat arg)) - (usr:iz (arg : radix) - (tointz arg radix)) - (usr:oz (arg) - (tointz arg 8)) - (usr:xz (arg) - (tointz arg 16)) - (usr:bz (arg) - (tointz arg 2)) - (usr:cz (arg) - (tointz arg #\c)) - (usr:rz (arg) - (tofloatz arg))) + ^(flet ,(collect-each ((sym '(usr:i usr:o usr:x usr:b usr:c + usr:r usr:iz usr:oz usr:xz + usr:bz usr:cz usr:rz))) + ^(,sym (arg) (sys:conv-expand-sym ,sym arg))) ,*body)) (defun sys:do-conv (lfl mfl tfl nm list) |