diff --git a/src/t.scm b/src/t.scm index ca2dc42..d7892dc 100644 --- a/src/t.scm +++ b/src/t.scm @@ -67,27 +67,31 @@ (and (eq? pat ') (or (symbol? x) (procedure? x))) (and (eq? pat ') (symbol? x)) (and (eq? pat ') (string? x)) - (eq? x pat) + (eqv? x pat) (and (pair? pat) - (cond [(and (eq? (car pat) '...) - (pair? (cdr pat)) - (null? (cddr pat))) - (eq? x (cadr pat))] - [(and (pair? (cdr pat)) - (eq? (cadr pat) '...) - (null? (cddr pat))) + (cond [(and (eq? (car pat) '...) + (pair? (cdr pat)) + (null? (cddr pat))) + (eqv? x (cadr pat))] + [(and (pair? (cdr pat)) + (eq? (cadr pat) '...) + (null? (cddr pat))) (let ([pat (car pat)]) (if (eq? pat '*) (list? x) (let loop ([lst x]) (or (null? lst) (and (pair? lst) - (sexp-match? pat (car lst)) - (loop (cdr lst)))))))] - [else + (sexp-match? pat (car lst)) + (loop (cdr lst)))))))] + [else (and (pair? x) - (sexp-match? (car pat) (car x)) - (sexp-match? (cdr pat) (cdr x)))])))) + (sexp-match? (car pat) (car x)) + (sexp-match? (cdr pat) (cdr x)))])) + (and (vector? pat) (vector? x) + (sexp-match? (vector->list pat) (vector->list x))) + (and (box? pat) (box? x) + (sexp-match? (unbox pat) (unbox x))))) (define-syntax sexp-case (syntax-rules (else) @@ -125,6 +129,12 @@ [(eq? x (car l)) n] [else (loop (cdr l) (fx+ n 1))])))) +(define rassq + (lambda (x al) + (and (pair? al) + (let ([a (car al)]) + (if (eq? x (cdr a)) a (rassq x (cdr al))))))) + (define list-diff (lambda (l t) (if (or (null? l) (eq? l t)) @@ -147,6 +157,9 @@ (define (andmap p l) (if (pair? l) (and (p (car l)) (andmap p (cdr l))) #t)) +(define (ormap p l) + (if (pair? l) (or (p (car l)) (ormap p (cdr l))) #f)) + (define (list1? x) (and (pair? x) (null? (cdr x)))) (define (list1+? x) (and (pair? x) (list? (cdr x)))) (define (list2? x) (and (pair? x) (list1? (cdr x)))) @@ -258,13 +271,22 @@ (define-syntax location-set-val! set-box!) (define (location-special? l) (not (pair? (unbox l)))) -(define (new-id sym den rename) (define p (list sym den rename)) (lambda () p)) +(define (new-id sym den getlits) (define p (list sym den getlits)) (lambda () p)) (define (old-sym id) (car (id))) (define (old-den id) (cadr (id))) -(define (old-rename id) (or (caddr (id)) (lambda (nid) nid))) +(define (old-literals id) ((or (caddr (id)) (lambda () '())))) (define (id? x) (or (symbol? x) (procedure? x))) (define (id->sym id) (if (symbol? id) id (old-sym id))) -(define (id-rename-as id nid) (if (symbol? id) nid ((old-rename id) nid))) + +; take a possibly renamed target id, and find image for nid +(define (id-rename-as id nid) + (let loop ([id id]) + (if (symbol? id) nid + (let* ([lits (old-literals id)] [oid->id (rassq id lits)]) + (unless oid->id (x-error "id-rename-as failed: not found in its own lits" id)) + (let ([renamed-nid (loop (car oid->id))]) + (cond [(assq renamed-nid lits) => cdr] + [else renamed-nid])))))) ; Expand-time environments map identifiers (symbolic or thunked) to denotations, i.e. locations ; containing either a or a value. In normal case, value is (ref ), @@ -657,13 +679,8 @@ (define new-literals (body (define nl - (map (lambda (id) - (cons id - (new-id (id->sym id) - (xenv-ref mac-env id) - (lambda (nid) (cond [(assq nid nl) => cdr] [else nid]))))) - (list-ids tmpl #t - (lambda (id) (not (assq id top-bindings)))))) + (map (lambda (id) (cons id (new-id (id->sym id) (xenv-ref mac-env id) (lambda () nl)))) + (list-ids tmpl #t (lambda (id) (not (assq id top-bindings)))))) nl)) (define ellipsis-vars @@ -1282,20 +1299,20 @@ ; Library names and library file lookup ;--------------------------------------------------------------------------------------------- - (define (mangle-symbol->string sym) - (define safe '(#\! #\$ #\- #\_ #\=)) - (let loop ([lst (string->list (symbol->string sym))] [text '()]) - (cond [(null? lst) - (list->string (reverse text))] - [(or (char-lower-case? (car lst)) (char-numeric? (car lst))) - (loop (cdr lst) (cons (car lst) text))] - [(memv (car lst) safe) - (loop (cdr lst) (cons (car lst) text))] - [else ; use % encoding for everything else - (let* ([s (number->string (char->integer (car lst)) 16)] - [s (if (< (string-length s) 2) (string-append "0" s) s)] - [l (cons #\% (string->list (string-downcase s)))]) - (loop (cdr lst) (append (reverse l) text)))]))) +(define (mangle-symbol->string sym) + (define safe '(#\! #\$ #\- #\_ #\=)) + (let loop ([lst (string->list (symbol->string sym))] [text '()]) + (cond [(null? lst) + (list->string (reverse text))] + [(or (char-lower-case? (car lst)) (char-numeric? (car lst))) + (loop (cdr lst) (cons (car lst) text))] + [(memv (car lst) safe) + (loop (cdr lst) (cons (car lst) text))] + [else ; use % encoding for everything else + (let* ([s (number->string (char->integer (car lst)) 16)] + [s (if (< (string-length s) 2) (string-append "0" s) s)] + [l (cons #\% (string->list (string-downcase s)))]) + (loop (cdr lst) (append (reverse l) text)))]))) (define (listname->symbol lib) (define postfix "") @@ -1317,18 +1334,6 @@ [(exact-integer? s) (number->string s)] [else (c-error "invalid library name name element" s)])) -(define modname-separator "_") - -(define (listname->modname listname) - (define sep modname-separator) - (let loop ([l listname] [r '()]) - (if (pair? l) - (loop (cdr l) - (if (null? r) - (cons (listname-segment->string (car l)) r) - (cons (listname-segment->string (car l)) (cons sep r)))) - (string-append* (reverse r))))) - (define (listname->path listname basepath ext) (define sep (let ([sc (base-path-separator basepath)]) @@ -1396,26 +1401,10 @@ (let ([s (read-code-sexp port)]) (unless (eof-object? s) (proc s) (loop))))))) -(define (file/lib->modname name) - (cond [(and (pair? name) (list? name)) (listname->modname name)] - [(string? name) (path-strip-extension (path-strip-directory name))] - [else (c-error "illegal file or library name:" name)])) - -(define (file/lib/stdin->modname name) - (if (and (string? name) (string=? name "-")) - "stdin" - (file/lib->modname name))) - ; name prefixes -(define (fully-qualified-prefix modname) - (string-append modname ".")) - -(define (fully-qualified-library-prefix lib) - (fully-qualified-prefix (file/lib->modname lib))) - (define (fully-qualified-library-prefixed-name lib id) - (string-append (file/lib->modname lib) "." (symbol->string id))) + (string->symbol (string-append (symbol->string (listname->symbol lib)) "?" (symbol->string id)))) ;--------------------------------------------------------------------------------------------- diff --git a/t.c b/t.c index 17593ee..eb0265c 100644 --- a/t.c +++ b/t.c @@ -36,11 +36,13 @@ char *t_code[] = { "P", "sexp-match?", "%2'(y1:*),.1q,.0?{.0]3}'(y4:),.2q?{.2Y0,.0?{.0}{.3K0}_1}{f},.0?{.0" "]4}'(y8:),.3q?{.3Y0}{f},.0?{.0]5}'(y8:),.4q?{.4S0}{f}," - ".0?{.0]6}.4,.6q,.0?{.0]7}.5p?{'(y3:...),.6aq?{.5dp?{.5ddu}{f}}{f}?{.5d" - "a,.7q]7}.5dp?{'(y3:...),.6daq?{.5ddu}{f}}{f}?{.5a,'(y1:*),.1q?{.7L0]8}" - ".7,,#0.0,.3,&2{%1.0u,.0?{.0]2}.1p?{${.3a,:0,@(y11:sexp-match?)[02}?{.1" - "d,:1^[21}f]2}f]2}.!0.0^_1[81}.6p?{${.8a,.8a,@(y11:sexp-match?)[02}?{.6" - "d,.6d,@(y11:sexp-match?)[72}f]7}f]7}f]7", + ".0?{.0]6}.4,.6v,.0?{.0]7}.5p?{'(y3:...),.6aq?{.5dp?{.5ddu}{f}}{f}?{.5d" + "a,.7v}{.5dp?{'(y3:...),.6daq?{.5ddu}{f}}{f}?{.5a,'(y1:*),.1q?{.7L0}{${" + ".9,,#0.0,.5,&2{%1.0u,.0?{.0]2}.1p?{${.3a,:0,@(y11:sexp-match?)[02}?{.1" + "d,:1^[21}f]2}f]2}.!0.0^_1[01}}_1}{.6p?{${.8a,.8a,@(y11:sexp-match?)[02" + "}?{${.8d,.8d,@(y11:sexp-match?)[02}}{f}}{f}}}}{f},.0?{.0]8}.6V0?{.7V0?" + "{${.9X0,.9X0,@(y11:sexp-match?)[02}}{f}}{f},.0?{.0]9}.7Y2?{.8Y2?{.8z,." + "8z,@(y11:sexp-match?)[92}f]9}f]9", "S", "sexp-case", "l6:y12:syntax-rules;l1:y4:else;;l2:l4:y1:_;l2:y3:key;y3:...;;y7:clause" @@ -62,6 +64,9 @@ char *t_code[] = { "%2'0,.2,,#0.0,.4,&2{%2.0u?{f]2}.0a,:0q?{.1]2}'1,.2I+,.1d,:1^[22}.!0.0^" "_1[22", + "P", "rassq", + "%2.1p?{.1a,.0d,.2q?{.0]3}.2d,.2,@(y5:rassq)[32}f]2", + "P", "list-diff", "%2.0u,.0?{.0}{.2,.2q}_1?{n]2}${.3,.3d,@(y9:list-diff)[02},.1ac]2", @@ -77,6 +82,9 @@ char *t_code[] = { "P", "andmap", "%2.1p?{${.3a,.3[01}?{.1d,.1,@(y6:andmap)[22}f]2}t]2", + "P", "ormap", + "%2.1p?{${.3a,.3[01},.0?{.0]3}.2d,.2,@(y5:ormap)[32}f]2", + "P", "list1?", "%1.0p?{.0du]1}f]1", @@ -136,8 +144,8 @@ char *t_code[] = { "P", "old-den", "%1${.2[00}da]1", - "P", "old-rename", - "%1${.2[00}dda,.0?{.0]2}&0{%1.0]1}]2", + "P", "old-literals", + "%1${.2[00}dda,.0?{.0}{&0{%0n]0}}_1[10", "P", "id?", "%1.0Y0,.0?{.0]2}.1K0]2", @@ -146,7 +154,10 @@ char *t_code[] = { "%1.0Y0?{.0]1}.0,@(y7:old-sym)[11", "P", "id-rename-as", - "%2.0Y0?{.1]2}.1,${.3,@(y10:old-rename)[01}[21", + "%2.0,,#0.0,.4,&2{%1.0Y0?{:0]1}${.2,@(y12:old-literals)[01},${.2,.4,@(y" + "5:rassq)[02},.0~?{${.4,'(s46:id-rename-as failed: not found in its own" + " lits),@(y7:x-error)[02}}${.2a,:1^[01},.2,.1A3,.0?{.0d]5}.1]5}.!0.0^_1" + "[21", "P", "extend-xenv-local", "%3.1b,.3,.1,.3,&3{%2.0,:0q?{.1,'(l2:y3:ref;y4:set!;),.1A1?{:1]3}f]3}.1" @@ -362,19 +373,19 @@ char *t_code[] = { "},${${.7,.6^,@(y5:%25map1)[02},.5c,@(y4:list)c,@(y4:%25map),@(y13:appl" "y-to-list)[02}L6](i11)}.2p?{${.5,.5d,.5d,:6^[03},.3a,.3a,:6^[43}:7^[40" "}.!0.0^_1[63}.!6.8,.2,.7,.5,&4{%3,,,#0#1#2,#0${${.(i10),&1{%1:0,.1A3~]" - "1},t,.(i11),:1^[03},:3,.4,&2{%1${:0,&1{%1:0^,.1A3,.0?{.0d]2}.1]2},${.5" - ",:1,@(y8:xenv-ref)[02},${.6,@(y7:id->sym)[01},@(y6:new-id)[03},.1c]1}," - "@(y5:%25map1)[02}.!0.0^_1.!0${:2^,f,.7,:1^[03}.!1.1,:1,&2{%1:1,&1{%1:0" - "^,.1A0]1},t,.2,:0^[13}.!2.5,.5,,#0.8,.4,:0,.8,.4,&5{%2.0,,#0.0,.4,:0,:" - "1,:2,:3,:4,&7{%1${.2,@(y3:id?)[01}?{:5,.1A3,.0?{.0}{:0,.2A3,.0?{.0}{:1" - "^,.3A3}_1}_1d]1}.0V0?{${.2X0,:6^[01}X1]1}.0p?{${.2d,:2^[01}}{f}?{${.2a" - ",:3^[01},,,#0#1:5,&1{%1:0,.1A3d]1}.!0.2,.4,:4,&3{%!0${.2,:2,@(y4:cons)" - ",@(y5:%25map2)[03},:1a,:0^[12}.!1.2u?{${.5dd,:6^[01},${.6a,:6^[01}c]4}" - "${.4,.3^,@(y5:%25map1)[02},${.6dd,:6^[01},${.3,.6^c,@(y4:%25map),@(y13" - ":apply-to-list)[02}L6]5}.0p?{${.2d,:6^[01},${.3a,:6^[01}c]1}.0]1}.!0.0" - "^_1[21}.!0.0^_1[62}.!7.(i11),.8,.8,&3{%2:2,,#0:0,.3,.5,:1,.4,&5{%1.0u?" - "{${:3,'(s14:invalid syntax),@(y7:x-error)[02}}.0a,.0a,.1da,${:2,:3,.5," - ":4^[03},.0?{.0,.0,.3,.5,:1^[63}.4d,:0^[51}.!0.0^_1[21}](i12)", + "1},t,.(i11),:1^[03},:3,.4,&2{%1${:0,&1{%0:0^]0},${.5,:1,@(y8:xenv-ref)" + "[02},${.6,@(y7:id->sym)[01},@(y6:new-id)[03},.1c]1},@(y5:%25map1)[02}." + "!0.0^_1.!0${:2^,f,.7,:1^[03}.!1.1,:1,&2{%1:1,&1{%1:0^,.1A0]1},t,.2,:0^" + "[13}.!2.5,.5,,#0.8,.4,:0,.8,.4,&5{%2.0,,#0.0,.4,:0,:1,:2,:3,:4,&7{%1${" + ".2,@(y3:id?)[01}?{:5,.1A3,.0?{.0}{:0,.2A3,.0?{.0}{:1^,.3A3}_1}_1d]1}.0" + "V0?{${.2X0,:6^[01}X1]1}.0p?{${.2d,:2^[01}}{f}?{${.2a,:3^[01},,,#0#1:5," + "&1{%1:0,.1A3d]1}.!0.2,.4,:4,&3{%!0${.2,:2,@(y4:cons),@(y5:%25map2)[03}" + ",:1a,:0^[12}.!1.2u?{${.5dd,:6^[01},${.6a,:6^[01}c]4}${.4,.3^,@(y5:%25m" + "ap1)[02},${.6dd,:6^[01},${.3,.6^c,@(y4:%25map),@(y13:apply-to-list)[02" + "}L6]5}.0p?{${.2d,:6^[01},${.3a,:6^[01}c]1}.0]1}.!0.0^_1[21}.!0.0^_1[62" + "}.!7.(i11),.8,.8,&3{%2:2,,#0:0,.3,.5,:1,.4,&5{%1.0u?{${:3,'(s14:invali" + "d syntax),@(y7:x-error)[02}}.0a,.0a,.1da,${:2,:3,.5,:4^[03},.0?{.0,.0," + ".3,.5,:1^[63}.4d,:0^[51}.!0.0^_1[21}](i12)", "P", "make-include-transformer", "%1,#0${f,'(y5:begin)b,'(y5:begin),@(y6:new-id)[03}.!0.1,.1,&2{%2${.2,@" @@ -679,15 +690,6 @@ char *t_code[] = { "%1.0Y0?{.0,@(y21:mangle-symbol->string)[11}.0I0?{'(i10),.1E8]1}.0,'(s3" "3:invalid library name name element),@(y7:c-error)[12", - "C", 0, - "'(s1:_)@!(y17:modname-separator)", - - "P", "listname->modname", - "%1,#0@(y17:modname-separator).!0n,.2,,#0.0,.4,&2{%2.0p?{.1u?{.1,${.3a," - "@(y24:listname-segment->string)[01}c}{.1,:0^c,${.3a,@(y24:listname-seg" - "ment->string)[01}c},.1d,:1^[22}.1A8,@(y14:string-append*)[21}.!0.0^_1[" - "22", - "P", "listname->path", "%3,#0${.4,@(y19:base-path-separator)[01},.0?{.0,S11}{${.5,'(s38:librar" "y path does not end in separator),@(y7:c-error)[02}}_1.!0n,.2,,#0.5,.7" @@ -730,23 +732,9 @@ char *t_code[] = { "%3.0,&1{%2,#0.2,.1,:0,&3{%0${:2,@(y14:read-code-sexp)[01},.0R8~?{${.2," ":0[01}:1^[10}]1}.!0.0^_1[20},.3,.3,@(y24:call-with-input-file/lib)[33", - "P", "file/lib->modname", - "%1.0p?{.0L0}{f}?{.0,@(y17:listname->modname)[11}.0S0?{${.2,@(y20:path-" - "strip-directory)[01},@(y20:path-strip-extension)[11}.0,'(s29:illegal f" - "ile or library name:),@(y7:c-error)[12", - - "P", "file/lib/stdin->modname", - "%1.0S0?{'(s1:-),.1S=}{f}?{'(s5:stdin)]1}.0,@(y17:file/lib->modname)[11", - - "P", "fully-qualified-prefix", - "%1'(s1:.),.1S6]1", - - "P", "fully-qualified-library-prefix", - "%1${.2,@(y17:file/lib->modname)[01},@(y22:fully-qualified-prefix)[11", - "P", "fully-qualified-library-prefixed-name", - "%2.1X4,'(s1:.),${.4,@(y17:file/lib->modname)[01},@(y14:%25string-appen" - "d)[23", + "%2${.3X4,'(s1:?),${.6,@(y16:listname->symbol)[01}X4,@(y14:%25string-ap" + "pend)[03}X5]2", "P", "env-lookup", "%3.0K0?{.2,'(l2:y3:ref;y4:set!;),.1A1?{.1,@(y7:old-den)[41}f]4}.1,,#0."