Miroirs/skint
1
0
Fork 0
mirror of https://github.com/false-schemers/skint.git synced 2024-12-27 21:58:53 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

syntax-lambda fix; improved lib processor

Browse source
This commit is contained in:
ESL 2024-07-06 02:48:34 -04:00
parent 6b0bcc98a4
commit 23f278f767
2 changed files with 65 additions and 78 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

73
src/t.scm
View file

@ -590,7 +590,7 @@
(if (and (list1+? use) (fx=? (length vars) (length (cdr use)))) (if (and (list1+? use) (fx=? (length vars) (length (cdr use))))
(let loop ([vars vars] [exps (cdr use)] [env macenv]) (let loop ([vars vars] [exps (cdr use)] [env macenv])
(if (null? vars) (if (null? vars)
(list 'syntax (xform-body forms env appos?)) (list syntax-id (xform-body forms env appos?))
(loop (cdr vars) (cdr exps) (loop (cdr vars) (cdr exps)
(extend-xenv-local (car vars) (extend-xenv-local (car vars)
(xform #t (car exps) useenv) env)))) (xform #t (car exps) useenv) env))))
@ -957,7 +957,7 @@
(and (memq at '(ref const)) (old-den id))] (and (memq at '(ref const)) (old-den id))]
[(assq id (vector-ref v 0)) => [(assq id (vector-ref v 0)) =>
cdr] ; full access to new locations cdr] ; full access to new locations
[(assq id ial) => ; read-only acess to imports, no shadowing? [(assq id ial) => ; read-only access to imports, no shadowing?
(lambda (b) (and (memq at '(ref const)) (cdr b)))] (lambda (b) (and (memq at '(ref const)) (cdr b)))]
[(symbol-libname? id) ; read-only acess to libs [(symbol-libname? id) ; read-only acess to libs
(and (memq at '(ref const)) (env id at))] (and (memq at '(ref const)) (env id at))]
@ -990,35 +990,34 @@
(let ([first (car body)] [rest (cdr body)]) (let ([first (car body)] [rest (cdr body)])
(if (pair? first) (if (pair? first)
(let* ([head (car first)] [tail (cdr first)] [hval (xform #t head cenv)]) (let* ([head (car first)] [tail (cdr first)] [hval (xform #t head cenv)])
(case hval (cond
[(begin) [(eq? hval 'begin)
(if (list? tail) (unless (list? tail) (x-error "improper begin form" first))
(scan (append tail rest) code*) (scan (append tail rest) code*)]
(x-error "improper begin form" first))] [(and (eq? hval 'define) (list2? tail) (null? (car tail))) ; special idless define
[(define) (scan (append (cadr tail) rest) code*)]
(cond [(and (list2? tail) (null? (car tail))) ; idless [(eq? hval 'define)
(scan rest (cons (xform #f (cadr tail) cenv) code*))] (let* ([core (xform-define tail cenv)]
[(and (list2? tail) (id? (car tail))) [loc (xenv-lookup cenv (cadr core) 'define)])
(unless (xenv-lookup cenv (car tail) 'define) (unless (location? loc) (x-error "unexpected define for id" (cadr core) first))
(x-error "unexpected define for id" (car tail) first)) (scan rest (cons (list 'set! (cadr (location-val loc)) (caddr core)) code*)))]
(scan rest (cons (xform-set! tail cenv) code*))] [(eq? hval 'define-syntax)
[(and (list2+? tail) (pair? (car tail)) (id? (caar tail)) (idslist? (cdar tail))) (let* ([core (xform-define-syntax tail cenv)]
(unless (xenv-lookup cenv (caar tail) 'define) [loc (xenv-lookup cenv (cadr core) 'define-syntax)])
(x-error "unexpected define for id" (caar tail) first)) (unless (location? loc) (x-error "unexpected define-syntax for id" (cadr core) first))
(let* ([id (caar tail)] [init (cons lambda-id (cons (cdar tail) (cdr tail)))]) (location-set-val! loc (caddr core))
(scan rest (cons (xform-set! (list id init) cenv) code*)))] (scan rest code*))]
[else (x-error "improper define form" first)])] [(eq? hval 'define-library)
[(define-syntax) (x-error "NYI: define-library inside library code" first)]
(cond [(and (list2? tail) (id? (car tail))) [(eq? hval 'import)
(let ([loc (xenv-lookup cenv (car tail) 'define-syntax)]) (x-error "NYI: import inside library code" first)]
(location-set-val! loc (xform #t (cadr tail) cenv))
(scan rest code*))]
[else (x-error "improper define-syntax form" first)])]
; TODO: check for built-in (export) and modify eal! ; TODO: check for built-in (export) and modify eal!
[else [(procedure? hval) ; transformer: apply and loop
(if (procedure? hval) (scan (cons (hval first cenv) rest) code*)]
(scan (cons (hval first cenv) rest) code*) [(integrable? hval) ; integrable application
(scan rest (cons (xform #f first cenv) code*)))])) (scan rest (cons (xform-integrable hval tail cenv) code*))]
[else ; other specials and calls
(scan rest (cons (xform #f first cenv) code*))]))
(scan rest (cons (xform #f first cenv) code*)))))) (scan rest (cons (xform #f first cenv) code*))))))
(let* ([code* (scan forms '())] [forms-code (cons 'begin (reverse! code*))] (let* ([code* (scan forms '())] [forms-code (cons 'begin (reverse! code*))]
[combined-code (adjoin-code code (if lid (list 'once lid forms-code) forms-code))]) [combined-code (adjoin-code code (if lid (list 'once lid forms-code) forms-code))])
@ -1041,7 +1040,7 @@
(define (xform-define-library head tail env appos?) ; non-internal (define (xform-define-library head tail env appos?) ; non-internal
(if (and (list2+? tail) (list1+? (car tail))) (if (and (list2+? tail) (list1+? (car tail)))
(let* ([name (xform-sexp->datum (car tail))] [sym (if (symbol? name) name (listname->symbol name))] (let* ([name (xform-sexp->datum (car tail))] [sym (if (symbol? name) name (listname->symbol name))]
[libform (cons head (cons sym (cdr tail)))] ; NB: head is used as seed id for renamings [libform (cons head (cons sym (cdr tail)))] ; head is used as seed id for renamings
[ic&ex (preprocess-library libform env)] [lid (id-rename-as head sym)]) [ic&ex (preprocess-library libform env)] [lid (id-rename-as head sym)])
(list 'define-library lid (list 'quote ic&ex))) (list 'define-library lid (list 'quote ic&ex)))
(x-error "improper define-library form" (cons head tail)))) (x-error "improper define-library form" (cons head tail))))
@ -1698,7 +1697,7 @@
(char=? (string-ref str 5) #\/) (char=? (string-ref str 5) #\/)
(substring str 6 sl)))) (substring str 6 sl))))
(define (symbol->listname sym) ;=> listname | #f #;(define (symbol->listname sym) ;=> listname | #f
(let loop ([s (symbol-libname? sym)] [r '()]) (let loop ([s (symbol-libname? sym)] [r '()])
(cond [(not s) (and (pair? r) (reverse! r))] (cond [(not s) (and (pair? r) (reverse! r))]
[(string-position #\/ s) => [(string-position #\/ s) =>
@ -1706,7 +1705,7 @@
(cons (string->symbol (substring s 0 n)) r)))] (cons (string->symbol (substring s 0 n)) r)))]
[else (loop #f (cons (string->symbol s) r))]))) [else (loop #f (cons (string->symbol s) r))])))
(define (libname->path libname basepath ext) #;(define (libname->path libname basepath ext)
(let ([listname (if (symbol? libname) (symbol->listname libname) libname)]) (let ([listname (if (symbol? libname) (symbol->listname libname) libname)])
(and (list1+? listname) (listname->path listname basepath ext)))) (and (list1+? listname) (listname->path listname basepath ext))))
@ -1719,11 +1718,11 @@
(set! *library-path-list* (append *library-path-list* (list path))) (set! *library-path-list* (append *library-path-list* (list path)))
(c-error "library path should end in directory separator" path))) (c-error "library path should end in directory separator" path)))
(define (find-library-path libname) ;=> name of existing .sld file or #f (define (find-library-path listname) ;=> name of existing .sld file or #f
(define listname (if (symbol? libname) (symbol->listname libname) libname)) ;(define listname (if (symbol? libname) (symbol->listname libname) libname))
(let loop ([l *library-path-list*]) (let loop ([l *library-path-list*])
(and (pair? l) (and (pair? l)
(let ([p (listname->path libname (car l) ".sld")]) (let ([p (listname->path listname (car l) ".sld")])
(if (and p (file-exists? p)) p (loop (cdr l))))))) (if (and p (file-exists? p)) p (loop (cdr l)))))))
#;(define (resolve-input-file/lib-name name) ;=> path (or error is signalled) #;(define (resolve-input-file/lib-name name) ;=> path (or error is signalled)
@ -1777,7 +1776,7 @@
(define (library-available? lib) ;=> #f | filepath (external) | (code . eal) (loaded) (define (library-available? lib) ;=> #f | filepath (external) | (code . eal) (loaded)
(cond [(string? lib) (file-resolve-relative-to-current lib)] (cond [(string? lib) (file-resolve-relative-to-current lib)]
[(library-info lib #f)] ; builtin or preloaded [(library-info lib #f)] ; builtin or preloaded
[else (and (or (symbol? lib) (list1+? lib)) (find-library-path lib))])) [else (and (list1+? lib) (find-library-path lib))])) ;(or (symbol? lib) (list1+? lib))
; name prefixes ; name prefixes

70
t.c
View file

@ -359,11 +359,11 @@ char *t_code[] = {
"P", "xform-syntax-lambda", "P", "xform-syntax-lambda",
"%3${.2,@(y7:list2+?)[01}?{${.2a,@(y3:id?),@(y6:andmap)[02}}{f}?{.0d,.2" "%3${.2,@(y7:list2+?)[01}?{${.2a,@(y3:id?),@(y6:andmap)[02}}{f}?{.0d,.2"
",.2a,.5,.3,.2,.4,&4{%2${.2,@(y7:list1+?)[01}?{.0dg,:1gI=}{f}?{:0,.1d,:" ",.2a,.5,.3,.2,.4,&4{%2${.2,@(y7:list1+?)[01}?{.0dg,:1gI=}{f}?{:0,.1d,:"
"1,,#0.5,.1,:3,:2,&4{%3.0u?{${:1,.5,:0,@(y10:xform-body)[03},'(y6:synta" "1,,#0.5,.1,:3,:2,&4{%3.0u?{${:1,.5,:0,@(y10:xform-body)[03},@(y9:synta"
"x),l2]3}${.4,${:3,.7a,t,@(y5:xform)[03},.4a,@(y17:extend-xenv-local)[0" "x-id),l2]3}${.4,${:3,.7a,t,@(y5:xform)[03},.4a,@(y17:extend-xenv-local"
"3},.2d,.2d,:2^[33}.!0.0^_1[23}.0,'(s33:invalid syntax-lambda applicati" ")[03},.2d,.2d,:2^[33}.!0.0^_1[23}.0,'(s33:invalid syntax-lambda applic"
"on),@(y7:x-error)[22}]6}.0,'(y13:syntax-lambda)c,'(s27:improper syntax" "ation),@(y7:x-error)[22}]6}.0,'(y13:syntax-lambda)c,'(s27:improper syn"
"-lambda body),@(y7:x-error)[32", "tax-lambda body),@(y7:x-error)[32",
"P", "xform-syntax-rules", "P", "xform-syntax-rules",
"%2${.2,@(y7:list2+?)[01}?{${.2a,@(y3:id?)[01}?{${.2da,@(y3:id?),@(y6:a" "%2${.2,@(y7:list2+?)[01}?{${.2a,@(y3:id?)[01}?{${.2da,@(y3:id?),@(y6:a"
@ -562,28 +562,26 @@ char *t_code[] = {
"ym)[01}}{f},.0?{.2dd}{.2d},${.6,.3,.7ac,@(y31:preprocess-library-decla" "ym)[01}}{f},.0?{.2dd}{.2d},${.6,.3,.7ac,@(y31:preprocess-library-decla"
"rations)[02},.0a,.1da,.2dda,.3ddda,${.(i11),.(i10)^,.6,@(y27:ial->cont" "rations)[02},.0a,.1da,.2dda,.3ddda,${.(i11),.(i10)^,.6,@(y27:ial->cont"
"rolled-environment)[03},n,,#0.0,.3,&2{%2.0u?{.1]2}.0d,.1a,.0p?{.0a,.1d" "rolled-environment)[03},n,,#0.0,.3,&2{%2.0u?{.1]2}.0d,.1a,.0p?{.0a,.1d"
",${:0,.4,t,@(y5:xform)[03},.0,'(y5:begin),.1v?{.2L0?{.7,.6,.4L6,:1^[82" ",${:0,.4,t,@(y5:xform)[03},'(y5:begin),.1q?{.1L0~?{${.5,'(s19:improper"
"}.4,'(s19:improper begin form),@(y7:x-error)[82}'(y6:define),.1v?{${.4" " begin form),@(y7:x-error)[02}}.6,.5,.3L6,:1^[72}'(y6:define),.1q?{${."
",@(y6:list2?)[01}?{.2au}{f}?{.7,${:0,.6da,f,@(y5:xform)[03}c,.6,:1^[82" "3,@(y6:list2?)[01}?{.1au}{f}}{f}?{.6,.5,.3daL6,:1^[72}'(y6:define),.1q"
"}${.4,@(y6:list2?)[01}?{${.4a,@(y3:id?)[01}}{f}?{${'(y6:define),.5a,:0" "?{${:0,.4,@(y12:xform-define)[02},${'(y6:define),.3da,:0,@(y11:xenv-lo"
",@(y11:xenv-lookup)[03}~?{${.6,.5a,'(s24:unexpected define for id),@(y" "okup)[03},.0Y2~?{${.7,.4da,'(s24:unexpected define for id),@(y7:x-erro"
"7:x-error)[03}}.7,${:0,.6,@(y10:xform-set!)[02}c,.6,:1^[82}${.4,@(y7:l" "r)[03}}.8,.2dda,.2zda,'(y4:set!),l3c,.7,:1^[92}'(y13:define-syntax),.1"
"ist2+?)[01}?{.2ap?{${.4aa,@(y3:id?)[01}?{${.4ad,@(y8:idslist?)[01}}{f}" "q?{${:0,.4,@(y19:xform-define-syntax)[02},${'(y13:define-syntax),.3da,"
"}{f}}{f}?{${'(y6:define),.5aa,:0,@(y11:xenv-lookup)[03}~?{${.6,.5aa,'(" ":0,@(y11:xenv-lookup)[03},.0Y2~?{${.7,.4da,'(s31:unexpected define-syn"
"s24:unexpected define for id),@(y7:x-error)[03}}.2aa,.3d,.4adc,@(y9:la" "tax for id),@(y7:x-error)[03}}.1dda,.1sz.8,.7,:1^[92}'(y14:define-libr"
"mbda-id)c,.9,${:0,.4,.6,l2,@(y10:xform-set!)[02}c,.8,:1^[(i10)2}.4,'(s" "ary),.1q?{.3,'(s39:NYI: define-library inside library code),@(y7:x-err"
"20:improper define form),@(y7:x-error)[82}'(y13:define-syntax),.1v?{${" "or)[72}'(y6:import),.1q?{.3,'(s31:NYI: import inside library code),@(y"
".4,@(y6:list2?)[01}?{${.4a,@(y3:id?)[01}}{f}?{${'(y13:define-syntax),." "7:x-error)[72}.0K0?{.6,.5,${:0,.8,.6[02}c,:1^[72}.0U0?{.6,${:0,.5,.5,@"
"5a,:0,@(y11:xenv-lookup)[03},${:0,.6da,t,@(y5:xform)[03},.1sz.8,.7,:1^" "(y16:xform-integrable)[03}c,.5,:1^[72}.6,${:0,.7,f,@(y5:xform)[03}c,.5"
"[92}.4,'(s27:improper define-syntax form),@(y7:x-error)[82}.1K0?{.7,.6" ",:1^[72}.3,${:0,.4,f,@(y5:xform)[03}c,.2,:1^[42}.!0${n,.6,.4^[02},.0A9"
",${:0,.9,.7[02}c,:1^[82}.7,${:0,.8,f,@(y5:xform)[03}c,.6,:1^[82}.3,${:" ",'(y5:begin)c,${.(i13)?{.2,.(i14),'(y4:once),l3}{.2},.(i11),@(y11:adjo"
"0,.4,f,@(y5:xform)[03}c,.2,:1^[42}.!0${n,.6,.4^[02},.0A9,'(y5:begin)c," "in-code)[02},.4,.8,,#0.8,.1,.5,&3{%2.0u?{.1A9,:0c]2}.0aa,.1ad,${'(y5:c"
"${.(i13)?{.2,.(i14),'(y4:once),l3}{.2},.(i11),@(y11:adjoin-code)[02},." "onst),.4,:2[02},.0~?{.2,'(s16:cannot export id),@(y7:x-error)[52}${.2,"
"4,.8,,#0.8,.1,.5,&3{%2.0u?{.1A9,:0c]2}.0aa,.1ad,${'(y5:const),.4,:2[02" "@(y17:location-special?)[01}?{.4,.1,.3cc,.4d,:1^[52}.0z,'(l2:y3:ref;y5"
"},.0~?{.2,'(s16:cannot export id),@(y7:x-error)[52}${.2,@(y17:location" ":const;),.1aA0?{.5,.1da,'(y5:const),l2b,.4cc,.5d,:1^[62}.0,.4,'(s27:ca"
"-special?)[01}?{.4,.1,.3cc,.4d,:1^[52}.0z,'(l2:y3:ref;y5:const;),.1aA0" "nnot export code alias id),@(y7:x-error)[63}.!0.0^_1[(i16)2",
"?{.5,.1da,'(y5:const),l2b,.4cc,.5d,:1^[62}.0,.4,'(s27:cannot export co"
"de alias id),@(y7:x-error)[63}.!0.0^_1[(i16)2",
"P", "xform-define-library", "P", "xform-define-library",
"%4${.3,@(y7:list2+?)[01}?{${.3a,@(y7:list1+?)[01}}{f}?{${.3a,@(y17:xfo" "%4${.3,@(y7:list2+?)[01}?{${.3a,@(y7:list1+?)[01}}{f}?{${.3a,@(y17:xfo"
@ -919,15 +917,6 @@ char *t_code[] = {
"{'(c:),'3,.3S4C=?{'(c/),'4,.3S4C=?{'(c/),'5,.3S4C=?{.0,'6,.3S7]3}f]3}f" "{'(c:),'3,.3S4C=?{'(c/),'4,.3S4C=?{'(c/),'5,.3S4C=?{.0,'6,.3S7]3}f]3}f"
"]3}f]3}f]3}f]3}f]3}f]3", "]3}f]3}f]3}f]3}f]3}f]3",
"P", "symbol->listname",
"%1n,${.3,@(y15:symbol-libname?)[01},,#0.0,&1{%2.0~?{.1p?{.1A9]2}f]2}.0"
",'(c/)S8,.0?{.0,.3,.1,'0,.5S7X5c,.3S3,'1,.3+,.5S7,:0^[42}.2,.2X5c,f,:0"
"^[32}.!0.0^_1[12",
"P", "libname->path",
"%3.0Y0?{${.2,@(y16:symbol->listname)[01}}{.0},${.2,@(y7:list1+?)[01}?{"
".3,.3,.2,@(y14:listname->path)[43}f]4",
"C", 0, "C", 0,
"'(l1:s2:./;)@!(y19:*library-path-list*)", "'(l1:s2:./;)@!(y19:*library-path-list*)",
@ -937,9 +926,8 @@ char *t_code[] = {
"irectory separator),@(y7:c-error)[12", "irectory separator),@(y7:c-error)[12",
"P", "find-library-path", "P", "find-library-path",
"%1,#0.1Y0?{${.3,@(y16:symbol->listname)[01}}{.1}.!0@(y19:*library-path" "%1@(y19:*library-path-list*),,#0.0,.3,&2{%1.0p?{${'(s4:.sld),.3a,:0,@("
"-list*),,#0.0,.4,&2{%1.0p?{${'(s4:.sld),.3a,:0,@(y14:listname->path)[0" "y14:listname->path)[03},.0?{.0F0}{f}?{.0]2}.1d,:1^[21}f]1}.!0.0^_1[11",
"3},.0?{.0F0}{f}?{.0]2}.1d,:1^[21}f]1}.!0.0^_1[21",
"P", "read-file-sexps", "P", "read-file-sexps",
"%2.1,&1{%1:0?{t,.1P79}n,,#0.2,.1,&2{%1${:1,@(y14:read-code-sexp)[01},." "%2.1,&1{%1:0?{t,.1P79}n,,#0.2,.1,&2{%1${:1,@(y14:read-code-sexp)[01},."
@ -948,8 +936,8 @@ char *t_code[] = {
"P", "library-available?", "P", "library-available?",
"%1.0S0?{.0,@(y32:file-resolve-relative-to-current)[11}${f,.3,@(y12:lib" "%1.0S0?{.0,@(y32:file-resolve-relative-to-current)[11}${f,.3,@(y12:lib"
"rary-info)[02},.0?{.0]2}.1Y0,.0?{.0}{${.4,@(y7:list1+?)[01}}_1?{.1,@(y" "rary-info)[02},.0?{.0]2}${.3,@(y7:list1+?)[01}?{.1,@(y17:find-library-"
"17:find-library-path)[21}f]2", "path)[21}f]2",
"P", "fully-qualified-library-prefixed-name", "P", "fully-qualified-library-prefixed-name",
"%2.1,'(y1:?),.2Y0?{.2}{${.4,@(y16:listname->symbol)[01}},@(y13:symbol-" "%2.1,'(y1:?),.2Y0?{.2}{${.4,@(y16:listname->symbol)[01}},@(y13:symbol-"