Miroirs/skint
1
0
Fork 0
mirror of https://github.com/false-schemers/skint.git synced 2025-01-13 20:03:30 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

fixed id-rename-as; enhanced sexp-case

Browse source
This commit is contained in:
ESL 2024-06-20 18:42:11 -04:00
parent 4606c30af1
commit c85dad9f0a
2 changed files with 89 additions and 112 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

121
src/t.scm
View file

@ -67,27 +67,31 @@
(and (eq? pat '<id>) (or (symbol? x) (procedure? x)))
(and (eq? pat '<symbol>) (symbol? x))
(and (eq? pat '<string>) (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 <special> or a <core> value. In normal case, <core> value is (ref <gid>),
@ -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))))
;---------------------------------------------------------------------------------------------

80
t.c
View file

@ -36,11 +36,13 @@ char *t_code[] = {
"P", "sexp-match?",
"%2'(y1:*),.1q,.0?{.0]3}'(y4:<id>),.2q?{.2Y0,.0?{.0}{.3K0}_1}{f},.0?{.0"
"]4}'(y8:<symbol>),.3q?{.3Y0}{f},.0?{.0]5}'(y8:<string>),.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."