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

better nested includes; (begin x) == x

Browse source
This commit is contained in:
ESL 2024-06-27 13:31:32 -04:00
parent 7c175c823b
commit 2a2498d5a2
2 changed files with 108 additions and 46 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

60
src/t.scm
View file

@ -356,7 +356,7 @@
[(letcc) (xform-letcc tail env)]
[(withcc) (xform-withcc tail env)]
[(body) (xform-body tail env appos?)]
[(begin) (xform-begin tail env)]
[(begin) (xform-begin tail env appos?)]
[(define) (xform-define tail env)]
[(define-syntax) (xform-define-syntax tail env)]
[(syntax-lambda) (xform-syntax-lambda tail env appos?)]
@ -547,12 +547,11 @@
(location-set-val! (xenv-lookup env (car ids) 'set!) (xform #t (car inits) env))
(loop (cdr ids) (cdr inits) (cdr nids) sets lids)])))
(define (xform-begin tail env) ; non-internal
(define (xform-begin tail env appos?) ; non-internal
(if (list? tail)
(let ([xexps (map (lambda (sexp) (xform #f sexp env)) tail)])
(if (and (pair? xexps) (null? (cdr xexps)))
(car xexps) ; (begin x) => x
(cons 'begin xexps)))
(if (list1? tail)
(xform appos? (car tail) env) ; (begin x) == x
(cons 'begin (map (lambda (sexp) (xform #f sexp env)) tail)))
(x-error "improper begin form" (cons 'begin tail))))
(define (xform-define tail env) ; non-internal
@ -735,15 +734,24 @@
(define (make-include-transformer ci?)
(define begin-id (new-id 'begin (make-location 'begin) #f))
(define (push-current-file-transformer sexp env)
(unless (and (list2? sexp) (string? (cadr sexp))) (x-error "invalid syntax" sexp))
(push-current-file! (cadr sexp)) (list begin-id))
(define (pop-current-file-transformer sexp env)
(unless (list1? sexp) (x-error "invalid syntax" sexp))
(pop-current-file!) (list begin-id))
(define push-cf-id (new-id 'push-cf (make-location push-current-file-transformer) #f))
(define pop-cf-id (new-id 'pop-cf (make-location pop-current-file-transformer) #f))
(lambda (sexp env)
(if (list1+? sexp)
(unless (list1+? sexp) (x-error "invalid syntax" sexp))
(let loop ([files (cdr sexp)] [exp-lists '()])
(if (null? files)
(cons begin-id (apply append (reverse! exp-lists)))
(call-with-file/lib-sexps (car files) ci? ;=>
(lambda (exp-list)
(loop (cdr files) (cons exp-list exp-lists))))))
(x-error "invalid syntax" sexp))))
(let* ([filepath (file-resolve-relative-to-current (car files))]
[sexps (read-file-sexps filepath ci?)]
[wrapped-sexps `((,push-cf-id ,filepath) ,@sexps (,pop-cf-id))])
(loop (cdr files) (cons wrapped-sexps exp-lists)))))))
(define (if-feature-available-transformer sexp env)
(if (and (list? sexp) (= (length sexp) 4))
@ -1293,14 +1301,26 @@
(define *current-file-stack* '())
(define (current-file-stack) *current-file-stack*)
(define (set-current-file-stack! s) (set! *current-file-stack* s))
(define (current-file) ;=> filename of #f
(and (pair? *current-file-stack*) (car *current-file-stack*)))
(define (push-current-file! filename)
(when (member filename *current-file-stack* string=?)
(x-error "circularity in include file chain" filename))
(set! *current-file-stack* (cons filename *current-file-stack*)))
(define (pop-current-file!)
(unless (null? *current-file-stack*)
(set! *current-file-stack* (cdr *current-file-stack*))))
(define (with-current-file filename thunk)
(dynamic-wind
(lambda () (set! *current-file-stack* (cons filename *current-file-stack*)))
(lambda () (push-current-file! filename))
thunk
(lambda () (set! *current-file-stack* (cdr *current-file-stack*)))))
(lambda () (pop-current-file!))))
(define (file-resolve-relative-to-current filename) ; => resolved or original filename
(if (path-relative? filename)
@ -1390,6 +1410,16 @@
(c-error "cannot resolve file or library name to an existing file:" name '=> filepath))
filepath)
(define (read-file-sexps filepath ci?)
(call-with-input-file filepath
(lambda (port)
(when ci? (set-port-fold-case! port #t))
(let loop ([sexps '()])
(let ([s (read-code-sexp port)])
(if (eof-object? s)
(reverse! sexps)
(loop (cons s sexps))))))))
(define (call-with-input-file/lib name ci? proc) ;=> (proc filepath port), called while name is current-file
(let ([filepath (resolve-input-file/lib-name name)])
(with-current-file filepath
@ -1957,17 +1987,20 @@
(read-code-sexp iport))
(define (repl-from-port iport env prompt)
(define cfs (current-file-stack))
(guard (err
[(error-object? err)
(let ([p (current-error-port)])
(display (error-object-message err) p) (newline p)
(for-each (lambda (arg) (write arg p) (newline p))
(error-object-irritants err)))
(set-current-file-stack! cfs)
(when prompt (repl-from-port iport env prompt))]
[else
(let ([p (current-error-port)])
(display "Unknown error:" p) (newline p)
(write err p) (newline p))
(set-current-file-stack! cfs)
(when prompt (repl-from-port iport env prompt))])
(let loop ([x (repl-read iport prompt)])
(unless (eof-object? x)
@ -1988,6 +2021,7 @@
(close-input-port iport))
(define (run-repl)
(set-current-file-stack! '())
(repl-from-port
(current-input-port)
repl-environment

88
t.c
View file

@ -198,14 +198,14 @@ char *t_code[] = {
"mbda),.1v?{.6,.3,@(y12:xform-lambda)[72}'(y7:lambda*),.1v?{.6,.3,@(y13"
":xform-lambda*)[72}'(y5:letcc),.1v?{.6,.3,@(y11:xform-letcc)[72}'(y6:w"
"ithcc),.1v?{.6,.3,@(y12:xform-withcc)[72}'(y4:body),.1v?{.4,.7,.4,@(y1"
"0:xform-body)[73}'(y5:begin),.1v?{.6,.3,@(y11:xform-begin)[72}'(y6:def"
"ine),.1v?{.6,.3,@(y12:xform-define)[72}'(y13:define-syntax),.1v?{.6,.3"
",@(y19:xform-define-syntax)[72}'(y13:syntax-lambda),.1v?{.4,.7,.4,@(y1"
"9:xform-syntax-lambda)[73}'(y12:syntax-rules),.1v?{.6,.3,@(y18:xform-s"
"yntax-rules)[72}'(y13:syntax-length),.1v?{.6,.3,@(y19:xform-syntax-len"
"gth)[72}'(y12:syntax-error),.1v?{.6,.3,@(y18:xform-syntax-error)[72}.1"
"U0?{.6,.3,.3,@(y16:xform-integrable)[73}.1K0?{.6,${.9,.9,.6[02},.6,@(y"
"5:xform)[73}.6,.3,.3,@(y10:xform-call)[73",
"0:xform-body)[73}'(y5:begin),.1v?{.4,.7,.4,@(y11:xform-begin)[73}'(y6:"
"define),.1v?{.6,.3,@(y12:xform-define)[72}'(y13:define-syntax),.1v?{.6"
",.3,@(y19:xform-define-syntax)[72}'(y13:syntax-lambda),.1v?{.4,.7,.4,@"
"(y19:xform-syntax-lambda)[73}'(y12:syntax-rules),.1v?{.6,.3,@(y18:xfor"
"m-syntax-rules)[72}'(y13:syntax-length),.1v?{.6,.3,@(y19:xform-syntax-"
"length)[72}'(y12:syntax-error),.1v?{.6,.3,@(y18:xform-syntax-error)[72"
"}.1U0?{.6,.3,.3,@(y16:xform-integrable)[73}.1K0?{.6,${.9,.9,.6[02},.6,"
"@(y5:xform)[73}.6,.3,.3,@(y10:xform-call)[73",
"P", "xform-syntax",
"%2${.2,@(y6:list1?)[01}?{.0a]2}.0,'(y6:syntax)c,'(s20:improper syntax "
@ -319,9 +319,9 @@ char *t_code[] = {
"lookup)[03}sz.4,.4,.4d,.4d,.4d,:4^[55}.!0.0^_1[75",
"P", "xform-begin",
"%2.0L0?{${.2,.4,&1{%1:0,.1,f,@(y5:xform)[13},@(y5:%25map1)[02},.0p?{.0"
"du}{f}?{.0a]3}.0,'(y5:begin)c]3}.0,'(y5:begin)c,'(s19:improper begin f"
"orm),@(y7:x-error)[22",
"%3.0L0?{${.2,@(y6:list1?)[01}?{.1,.1a,.4,@(y5:xform)[33}${.2,.4,&1{%1:"
"0,.1,f,@(y5:xform)[13},@(y5:%25map1)[02},'(y5:begin)c]3}.0,'(y5:begin)"
"c,'(s19:improper begin form),@(y7:x-error)[32",
"P", "xform-define",
"%2${.2,@(y6:list2?)[01}?{.0au}{f}?{.1,.1da,f,@(y5:xform)[23}${.2,@(y6:"
@ -394,11 +394,17 @@ char *t_code[] = {
".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,@"
"(y7:list1+?)[01}?{n,.1d,,#0.0,:1,:0,&3{%2.0u?{${.3A9,@(y7:%25append),@"
"(y13:apply-to-list)[02},:0^c]2}.1,.1,:2,&3{%1:2,.1c,:1d,:0^[12},:1,.2a"
",@(y24:call-with-file/lib-sexps)[23}.!0.0^_1[22}.0,'(s14:invalid synta"
"x),@(y7:x-error)[22}]2",
"%1,,,,,#0#1#2#3#4${f,'(y5:begin)b,'(y5:begin),@(y6:new-id)[03}.!0.0,&1"
"{%2${.2,@(y6:list2?)[01}?{.0daS0}{f}~?{${.2,'(s14:invalid syntax),@(y7"
":x-error)[02}}${.2da,@(y18:push-current-file!)[01}:0^,l1]2}.!1.0,&1{%2"
"${.2,@(y6:list1?)[01}~?{${.2,'(s14:invalid syntax),@(y7:x-error)[02}}$"
"{@(y17:pop-current-file!)[00}:0^,l1]2}.!2${f,.4^b,'(y7:push-cf),@(y6:n"
"ew-id)[03}.!3${f,.5^b,'(y6:pop-cf),@(y6:new-id)[03}.!4.3,.5,.7,.3,&4{%"
"2${.2,@(y7:list1+?)[01}~?{${.2,'(s14:invalid syntax),@(y7:x-error)[02}"
"}n,.1d,,#0:3,:2,.2,:1,:0,&5{%2.0u?{${.3A9,@(y7:%25append),@(y13:apply-"
"to-list)[02},:0^c]2}${.2a,@(y32:file-resolve-relative-to-current)[01},"
"${:1,.3,@(y15:read-file-sexps)[02},n,n,:3^cc,.1L6,n,.3c,:4^cc,.4,.1c,."
"4d,:2^[52}.!0.0^_1[22}]6",
"P", "if-feature-available-transformer",
"%2.0L0?{'4,.1g=}{f}?{.0ddda,.1dda,.2da,${${.4,@(y17:xform-sexp->datum)"
@ -671,13 +677,27 @@ char *t_code[] = {
"C", 0,
"n@!(y20:*current-file-stack*)",
"P", "current-file-stack",
"%0@(y20:*current-file-stack*)]0",
"P", "set-current-file-stack!",
"%1.0@!(y20:*current-file-stack*)]1",
"P", "current-file",
"%0@(y20:*current-file-stack*)p?{@(y20:*current-file-stack*)a]0}f]0",
"P", "push-current-file!",
"%1${@(y8:string=?),@(y20:*current-file-stack*),.4,@(y7:%25member)[03}?"
"{${.2,'(s33:circularity in include file chain),@(y7:x-error)[02}}@(y20"
":*current-file-stack*),.1c@!(y20:*current-file-stack*)]1",
"P", "pop-current-file!",
"%0@(y20:*current-file-stack*)u~?{@(y20:*current-file-stack*)d@!(y20:*c"
"urrent-file-stack*)]0}]0",
"P", "with-current-file",
"%2&0{%0@(y20:*current-file-stack*)d@!(y20:*current-file-stack*)]0},.2,"
".2,&1{%0@(y20:*current-file-stack*),:0c@!(y20:*current-file-stack*)]0}"
",@(y12:dynamic-wind)[23",
"%2&0{%0@(y17:pop-current-file!)[00},.2,.2,&1{%0:0,@(y18:push-current-f"
"ile!)[01},@(y12:dynamic-wind)[23",
"P", "file-resolve-relative-to-current",
"%1${.2,@(y14:path-relative?)[01}?{${@(y12:current-file)[00},.0?{${.2,@"
@ -730,6 +750,11 @@ char *t_code[] = {
"}}}.0^F0~?{${.2^,'(y2:=>),.5,'(s56:cannot resolve file or library name"
" to an existing file:),@(y7:c-error)[04}}.0^]2",
"P", "read-file-sexps",
"%2.1,&1{%1:0?{t,.1P79}n,,#0.2,.1,&2{%1${:1,@(y14:read-code-sexp)[01},."
"0R8?{.1A9]2}.1,.1c,:0^[21}.!0.0^_1[11},.1,@(y20:call-with-input-file)["
"22",
"P", "call-with-input-file/lib",
"%3${.2,@(y27:resolve-input-file/lib-name)[01},.2,.1,.5,&3{%0:0,:1,:2,&"
"3{%1:0?{t,.1P79}.0,:1,:2[12},:1,@(y20:call-with-input-file)[02},.1,@(y"
@ -1093,16 +1118,18 @@ char *t_code[] = {
"%2.1?{PoW6Po,.2W4Po,'(s1: )W4}.0,@(y14:read-code-sexp)[21",
"P", "repl-from-port",
"%3${k0,.0,${.2,.8,.(i10),.9,&4{%0:3,&1{%!0.0,&1{%0:0,@(y6:values),@(y1"
"3:apply-to-list)[02},:0[11},:0,:1,:2,&3{%0${:1,:2,@(y9:repl-read)[02},"
",#0:0,:2,:1,.3,&4{%1.0R8~?{${:3,.3,@(y18:repl-eval-top-form)[02}${:1,:"
"2,@(y9:repl-read)[02},:0^[11}]1}.!0.0^_1[01},@(y16:call-with-values)[0"
"2},.9,.9,.9,.6,&4{%1${k0,.0,${.6,:1,:2,:3,&4{%0:3,${.2,@(y13:error-obj"
"ect?)[01}?{Pe,.0,${.4,@(y20:error-object-message)[01}W4.0W6${${.5,@(y2"
"2:error-object-irritants)[01},.3,&1{%1:0,.1W5:0W6]1},@(y10:%25for-each"
"1)[02}_1:0?{:0,:1,:2,@(y14:repl-from-port)[13}]1}Pe,.0,'(s14:Unknown e"
"rror:)W4.0W6.0,.2W5.0W6_1:0?{:0,:1,:2,@(y14:repl-from-port)[13}]1},:0["
"01}_1_3}[10},@(y22:with-exception-handler)[02}_1_3}[30",
"%3,#0${@(y18:current-file-stack)[00}.!0${k0,.0,${.2,.9,.(i11),.(i10),&"
"4{%0:3,&1{%!0.0,&1{%0:0,@(y6:values),@(y13:apply-to-list)[02},:0[11},:"
"0,:1,:2,&3{%0${:1,:2,@(y9:repl-read)[02},,#0:0,:2,:1,.3,&4{%1.0R8~?{${"
":3,.3,@(y18:repl-eval-top-form)[02}${:1,:2,@(y9:repl-read)[02},:0^[11}"
"]1}.!0.0^_1[01},@(y16:call-with-values)[02},.(i10),.(i10),.(i10),.(i10"
"),.7,&5{%1${k0,.0,${.6,:1,:2,:3,:4,&5{%0:4,${.2,@(y13:error-object?)[0"
"1}?{Pe,.0,${.4,@(y20:error-object-message)[01}W4.0W6${${.5,@(y22:error"
"-object-irritants)[01},.3,&1{%1:0,.1W5:0W6]1},@(y10:%25for-each1)[02}_"
"1${:3^,@(y23:set-current-file-stack!)[01}:0?{:0,:1,:2,@(y14:repl-from-"
"port)[13}]1}Pe,.0,'(s14:Unknown error:)W4.0W6.0,.2W5.0W6_1${:3^,@(y23:"
"set-current-file-stack!)[01}:0?{:0,:1,:2,@(y14:repl-from-port)[13}]1},"
":0[01}_1_3}[10},@(y22:with-exception-handler)[02}_1_3}[40",
"P", "repl-file",
"%2,#0${.3,@(y15:open-input-file)[01}.!0${f,.5,.4^,@(y14:repl-from-port"
@ -1116,7 +1143,8 @@ char *t_code[] = {
";f;),@(y18:repl-eval-top-form)[02}.0^P60]2",
"P", "run-repl",
"%0'(s6:skint]),@(y16:repl-environment),Pi,@(y14:repl-from-port)[03",
"%0${n,@(y23:set-current-file-stack!)[01}'(s6:skint]),@(y16:repl-enviro"
"nment),Pi,@(y14:repl-from-port)[03",
0, 0, 0
};