mirror of
https://github.com/false-schemers/skint.git
synced 2024-12-26 21:58:51 +01:00
script-related fixes; fully operational ccomp
This commit is contained in:
ESL
parent
a511e77df9
commit
c48e935bba
4 changed files with 112 additions and 117 deletions
|
|
@ -7,7 +7,8 @@
|
|||
xform write-serialized-sexp compile-to-string
|
||||
make-location syntax-rules* new-id? new-id-lookup
|
||||
lookup-integrable write-serialized-sexp compile-to-string
|
||||
path-strip-extension path-strip-directory))
|
||||
path-strip-extension path-strip-directory
|
||||
call-with-current-input-file))
|
||||
|
||||
(define *transformers*
|
||||
(list
|
||||
|
|
@ -108,16 +109,18 @@
|
|||
(display-code (substring cstr 3 (fx- len 1)) oport) (newline oport)]
|
||||
[else (process-command (list 'set! id xlam) oport)])))
|
||||
|
||||
(define (for-each-top-sexp filename sexpproc)
|
||||
(call-with-current-input-file filename ;=>
|
||||
(lambda (iport)
|
||||
(let loop ([x (read iport)])
|
||||
(unless (eof-object? x)
|
||||
(sexpproc x)
|
||||
(loop (read iport)))))))
|
||||
|
||||
(define (scan-top-form x)
|
||||
(cond
|
||||
[(and (list2? x) (eq? (car x) 'load) (string? (cadr x)))
|
||||
; FIXME: resolve relatively to the file being compiled!
|
||||
(let ([iport (open-input-file (cadr x))])
|
||||
(let loop ([x (read iport)])
|
||||
(unless (eof-object? x)
|
||||
(scan-top-form x)
|
||||
(loop (read iport))))
|
||||
(close-input-port iport))]
|
||||
(for-each-top-sexp (cadr x) scan-top-form)]
|
||||
[(pair? x)
|
||||
(let ([hval (transform #t (car x))])
|
||||
(cond
|
||||
|
|
@ -132,12 +135,7 @@
|
|||
(define (process-top-form x oport)
|
||||
(cond
|
||||
[(and (list2? x) (eq? (car x) 'load) (string? (cadr x)))
|
||||
(let ([iport (open-input-file (cadr x))])
|
||||
(let loop ([x (read iport)])
|
||||
(unless (eof-object? x)
|
||||
(scan-top-form x)
|
||||
(loop (read iport))))
|
||||
(close-input-port iport))]
|
||||
(for-each-top-sexp (cadr x) scan-top-form)]
|
||||
[(pair? x)
|
||||
(let ([hval (transform #t (car x))])
|
||||
(cond
|
||||
|
|
@ -177,13 +175,13 @@
|
|||
(define (module-name filename)
|
||||
(path-strip-extension (path-strip-directory filename)))
|
||||
|
||||
(define (process-file fname . ?ofname)
|
||||
(define iport (open-input-file fname))
|
||||
(define (process-file ifname . ?ofname)
|
||||
(define iport (open-input-file ifname)) ; relative to wd, not this script!
|
||||
(define oport (if (pair? ?ofname) (open-output-file (car ?ofname)) (current-output-port)))
|
||||
(define mname (module-name fname))
|
||||
(define mname (module-name ifname))
|
||||
(display "/* " oport) (display mname oport)
|
||||
(display ".c -- generated via skint -c " oport)
|
||||
(display (path-strip-directory fname) oport)
|
||||
(display (path-strip-directory ifname) oport)
|
||||
(display " */" oport) (newline oport) (newline oport)
|
||||
(display "char *" oport) (display mname oport)
|
||||
(display "_code[] = {" oport) (newline oport)
|
||||
|
|
@ -200,4 +198,5 @@
|
|||
[(list3? args) (process-file (cadr args) (caddr args))]
|
||||
[else (error "usage: ccomp INFILE [OUTFILE]" args)]))
|
||||
|
||||
;(main (command-line))
|
||||
; this is not a real #! script, so call main manually
|
||||
(main (command-line))
|
||||
|
|
|
|||
|
|
@ -274,7 +274,8 @@
|
|||
; check that now relies on block tag being a non-immediate object, so we'll better put
|
||||
; some pseudo-unique immediate object here -- and we don't have to be fast doing that
|
||||
(let loop ([fl (cons name fields)] [sl '("rtd://")])
|
||||
(cond [(null? fl) (string->symbol (apply-to-list string-append (reverse sl)))]
|
||||
; NB: can't do (apply string-append ..) -- they are defined w/cover syntax below!
|
||||
(cond [(null? fl) (string->symbol (apply-to-list %string-append (reverse sl)))]
|
||||
[(null? (cdr fl)) (loop (cdr fl) (cons (symbol->string (car fl)) sl))]
|
||||
[else (loop (cdr fl) (cons ":" (cons (symbol->string (car fl)) sl)))])))
|
||||
|
||||
|
|
|
|||
59
src/t.scm
59
src/t.scm
|
|
@ -1644,6 +1644,13 @@
|
|||
(if cf (file-resolve-relative-to-base-path filename (path-directory cf)) filename))
|
||||
filename))
|
||||
|
||||
(define (call-with-current-input-file filename portproc)
|
||||
(let* ([filepath (and (string? filename) (file-resolve-relative-to-current filename))]
|
||||
[fileok? (and (string? filepath) (file-exists? filepath))])
|
||||
(unless fileok? (error "cannot open file" filename filepath))
|
||||
(with-current-file filepath
|
||||
(lambda () (call-with-input-file filepath portproc)))))
|
||||
|
||||
|
||||
;--------------------------------------------------------------------------------------------------
|
||||
; Library names and library file lookup
|
||||
|
|
@ -2309,18 +2316,13 @@
|
|||
(define (load filename . ?env)
|
||||
(define env (if (pair? ?env) (car ?env) (interaction-environment)))
|
||||
(define ci? #f) ; do not bother setting this unless told by the specification
|
||||
(let* ([filepath (and (string? filename) (file-resolve-relative-to-current filename))]
|
||||
[fileok? (and (string? filepath) (file-exists? filepath))])
|
||||
(unless fileok? (error "cannot load file" filename filepath))
|
||||
(with-current-file filepath
|
||||
(lambda ()
|
||||
(call-with-input-file filepath
|
||||
(call-with-current-input-file filename ;=>
|
||||
(lambda (port)
|
||||
(when ci? (set-port-fold-case! port #t))
|
||||
(let loop ([x (read-code-sexp port)])
|
||||
(unless (eof-object? x)
|
||||
(eval x env)
|
||||
(loop (read-code-sexp port)))))))))
|
||||
(loop (read-code-sexp port))))))
|
||||
; we aren't asked by the spec to call last expr tail-recursively, so this
|
||||
(void))
|
||||
|
||||
|
|
@ -2330,18 +2332,13 @@
|
|||
(define ci? #f) ; normal load-like behavior is the default
|
||||
(define callmain #f) ; got changed via first #! line
|
||||
(define main-args (cons filename args))
|
||||
(let* ([filepath (and (string? filename) (file-resolve-relative-to-current filename))]
|
||||
[fileok? (and (string? filepath) (file-exists? filepath))])
|
||||
(unless fileok? (error "cannot run script" filename filepath))
|
||||
(with-current-file filepath
|
||||
(lambda ()
|
||||
(call-with-input-file filepath
|
||||
(call-with-current-input-file filename ;=>
|
||||
(lambda (port)
|
||||
(let ([x0 (read-code-sexp port)])
|
||||
(when (shebang? x0)
|
||||
(let ([shs (symbol->string (shebang->symbol x0))])
|
||||
(cond [(string-position "r7rs" shs)
|
||||
(command-line main-args)]
|
||||
(cond [(string-position "r7rs" shs)] ; skint env will do
|
||||
[(string-position "skint" shs)] ; ditto
|
||||
[(string-position "r5rs" shs)
|
||||
(set! env (scheme-report-environment 5))
|
||||
(set! ci? #t)]
|
||||
|
|
@ -2349,14 +2346,16 @@
|
|||
(when ci? (set-port-fold-case! port #t))
|
||||
(set! callmain #t)
|
||||
(set! x0 (read-code-sexp port))))
|
||||
(parameterize ([command-line main-args])
|
||||
(let loop ([x x0])
|
||||
(unless (eof-object? x)
|
||||
(eval x env)
|
||||
(loop (read-code-sexp port))))
|
||||
(when callmain
|
||||
; if it is a real script, exit with main's return value
|
||||
(exit (eval `(main (quote ,main-args)) env))))))))
|
||||
(void)))
|
||||
(loop (read-code-sexp port)))))
|
||||
(if callmain
|
||||
; if it is a real script, call main and return its value
|
||||
(eval `(main (quote ,main-args)) env)
|
||||
; otherwise return #t -- it will be used as exit value
|
||||
#t)))))
|
||||
|
||||
; r7rs scheme program processor (args is list of strings)
|
||||
(define (run-program filename args)
|
||||
|
|
@ -2366,19 +2365,15 @@
|
|||
(define env (make-controlled-environment ial global root-environment))
|
||||
(define ci? #f) ; normal load-like behavior is the default
|
||||
(define main-args (cons filename args))
|
||||
(let* ([filepath (and (string? filename) (file-resolve-relative-to-current filename))]
|
||||
[fileok? (and (string? filepath) (file-exists? filepath))])
|
||||
(unless fileok? (error "cannot run program" filename filepath))
|
||||
(with-current-file filepath
|
||||
(lambda ()
|
||||
(call-with-input-file filepath
|
||||
(call-with-current-input-file filename ;=>
|
||||
(lambda (port)
|
||||
(command-line main-args)
|
||||
(let loop ([x (read-code-sexp port)])
|
||||
(unless (eof-object? x)
|
||||
(eval x env)
|
||||
(loop (read-code-sexp port))))))))
|
||||
(exit #t)))
|
||||
(loop (read-code-sexp port))))))
|
||||
; return #t -- it will be used as exit value
|
||||
#t)
|
||||
|
||||
|
||||
;--------------------------------------------------------------------------------------------------
|
||||
|
|
@ -2556,12 +2551,12 @@
|
|||
[(append-libdir *) (append-library-path! optarg) (loop restargs #t)]
|
||||
[(prepend-libdir *) (prepend-library-path! optarg) (loop restargs #t)]
|
||||
[(eval *) (eval! optarg #t) (loop restargs #f)]
|
||||
[(script *) (run-script optarg restargs)] ; will exit if a script
|
||||
[(program *) (run-program optarg restargs)] ; will exit if a script
|
||||
[(benchmark *) (run-script optarg restargs)] ; will exit if a script
|
||||
[(script *) (exit (run-script optarg restargs))]
|
||||
[(program *) (exit (run-program optarg restargs))]
|
||||
[(benchmark *) (exit (run-script optarg restargs))] ; FIXME
|
||||
[(version) (print-version!) (loop '() #f)]
|
||||
[(help) (print-help!) (loop '() #f)]
|
||||
[(#f) (cond [(pair? restargs) (run-script (car restargs) (cdr restargs))]
|
||||
[(#f) (cond [(pair? restargs) (exit (run-script (car restargs) (cdr restargs)))]
|
||||
[(not repl?) (exit #t)])])))) ; all done -- no need to continue
|
||||
; falling through to interactive mode
|
||||
(when (and (tty-port? (current-input-port)) (tty-port? (current-output-port)))
|
||||
|
|
|
|||
70
t.c
70
t.c
|
|
@ -943,6 +943,11 @@ char *t_code[] = {
|
|||
"(y14:path-directory)[01},.2,@(y34:file-resolve-relative-to-base-path)["
|
||||
"22}.1]2}.0]1",
|
||||
|
||||
"P", "call-with-current-input-file",
|
||||
"%2.0S0?{${.2,@(y32:file-resolve-relative-to-current)[01}}{f},.0S0?{.0F"
|
||||
"0}{f},.0~?{${.3,.5,'(s16:cannot open file),@(y5:error)[03}}.3,.2,&2{%0"
|
||||
":1,:0,@(y20:call-with-input-file)[02},.2,@(y17:with-current-file)[42",
|
||||
|
||||
"P", "lnpart?",
|
||||
"%1${.2,@(y3:id?)[01},.0?{.0]2}.1I0]2",
|
||||
|
||||
|
|
@ -1455,39 +1460,33 @@ char *t_code[] = {
|
|||
"valuate-top-form)[32",
|
||||
|
||||
"P", "load",
|
||||
"%!1,,#0#1.2p?{.2a}{${@(y23:interaction-environment)[00}}.!0f.!1.3S0?{$"
|
||||
"{.5,@(y32:file-resolve-relative-to-current)[01}}{f},.0S0?{.0F0}{f},.0~"
|
||||
"?{${.3,.8,'(s16:cannot load file),@(y5:error)[03}}${.5,.5,.5,&3{%0:1,:"
|
||||
"2,&2{%1:0^?{t,.1P79}${.2,@(y14:read-code-sexp)[01},,#0:1,.3,.2,&3{%1.0"
|
||||
"R8~?{${:2^,.3,@(y4:eval)[02}${:1,@(y14:read-code-sexp)[01},:0^[11}]1}."
|
||||
"!0.0^_1[11},:0,@(y20:call-with-input-file)[02},.4,@(y17:with-current-f"
|
||||
"ile)[02}_1_1Y9]4",
|
||||
"%!1,,#0#1.2p?{.2a}{${@(y23:interaction-environment)[00}}.!0f.!1${.2,.4"
|
||||
",&2{%1:0^?{t,.1P79}${.2,@(y14:read-code-sexp)[01},,#0:1,.3,.2,&3{%1.0R"
|
||||
"8~?{${:2^,.3,@(y4:eval)[02}${:1,@(y14:read-code-sexp)[01},:0^[11}]1}.!"
|
||||
"0.0^_1[11},.6,@(y28:call-with-current-input-file)[02}Y9]4",
|
||||
|
||||
"P", "run-script",
|
||||
"%2,,,,#0#1#2#3${@(y23:interaction-environment)[00}.!0f.!1f.!2.5,.5c.!3"
|
||||
".4S0?{${.6,@(y32:file-resolve-relative-to-current)[01}}{f},.0S0?{.0F0}"
|
||||
"{f},.0~?{${.3,.9,'(s17:cannot run script),@(y5:error)[03}}${.6,.8,.6,."
|
||||
"8,.7,&5{%0:1,:2,:3,:4,&4{%1${.2,@(y14:read-code-sexp)[01},#0.0^Y5?{.0^"
|
||||
"Y7X4,.0,'(s4:r7rs)S8?{${:1^,@(y12:command-line)[01}}{.0,'(s4:r5rs)S8?{"
|
||||
"${'5,@(y25:scheme-report-environment)[01}:!2t:!3}{${.2,'(s41:only sche"
|
||||
"me-r[57]rs scripts are supported),@(y5:error)[02}}}:3^?{t,.3P79}t:!0${"
|
||||
".4,@(y14:read-code-sexp)[01}.!1_1}${.2^,,#0:2,.6,.2,&3{%1.0R8~?{${:2^,"
|
||||
".3,@(y4:eval)[02}${:1,@(y14:read-code-sexp)[01},:0^[11}]1}.!0.0^_1[01}"
|
||||
":0^?{${:2^,n,n,:1^c,'(y5:quote)cc,'(y4:main)c,@(y4:eval)[02},@(y4:exit"
|
||||
")[21}]2},:0,@(y20:call-with-input-file)[02},.4,@(y17:with-current-file"
|
||||
")[02}Y9]8",
|
||||
".1,.4,.2,.5,&4{%1${.2,@(y14:read-code-sexp)[01},#0.0^Y5?{.0^Y7X4,.0,'("
|
||||
"s4:r7rs)S8,.0?{.0}{.1,'(s5:skint)S8,.0?{.0}{.2,'(s4:r5rs)S8?{${'5,@(y2"
|
||||
"5:scheme-report-environment)[01}:!1t:!3}{${.4,'(s41:only scheme-r[57]r"
|
||||
"s scripts are supported),@(y5:error)[02}}}_1}_1:3^?{t,.3P79}t:!0${.4,@"
|
||||
"(y14:read-code-sexp)[01}.!1_1}@(y12:command-line),${f,:2^,.4[02},${.3["
|
||||
"00},${.2,.5,&2{%0t,:1,:0[02},.6,.8,:1,&3{%0:2^,,#0:0,:1,.2,&3{%1.0R8~?"
|
||||
"{${:2^,.3,@(y4:eval)[02}${:1,@(y14:read-code-sexp)[01},:0^[11}]1}.!0.0"
|
||||
"^_1[01},.5,.7,&2{%0t,:1,:0[02},@(y12:dynamic-wind)[03}_2_1:0^?{:1^,n,n"
|
||||
",:2^c,'(y5:quote)cc,'(y4:main)c,@(y4:eval)[22}t]2},.5,@(y28:call-with-"
|
||||
"current-input-file)[62",
|
||||
|
||||
"P", "run-program",
|
||||
"%2,,,,,,#0#1#2#3#4#5${${.(i10),@(y20:path-strip-directory)[01},@(y20:p"
|
||||
"ath-strip-extension)[01}X5.!0.0,&1{%1.0,'(y1:?),:0^,'(y7:prog://),@(y1"
|
||||
"3:symbol-append)[14}.!1'(y6:import)b,'(y6:import)c,l1.!2${@(y16:root-e"
|
||||
"nvironment),.4^,.6^,@(y27:make-controlled-environment)[03}.!3f.!4.7,.7"
|
||||
"c.!5.6S0?{${.8,@(y32:file-resolve-relative-to-current)[01}}{f},.0S0?{."
|
||||
"0F0}{f},.0~?{${.3,.(i11),'(s18:cannot run program),@(y5:error)[03}}${."
|
||||
"9,.8,.5,&3{%0:1,:2,&2{%1${:0^,@(y12:command-line)[01}${.2,@(y14:read-c"
|
||||
"ode-sexp)[01},,#0:1,.3,.2,&3{%1.0R8~?{${:2^,.3,@(y4:eval)[02}${:1,@(y1"
|
||||
"4:read-code-sexp)[01},:0^[11}]1}.!0.0^_1[11},:0,@(y20:call-with-input-"
|
||||
"file)[02},.4,@(y17:with-current-file)[02}t,@(y4:exit)[(i10)1",
|
||||
"c.!5${.5,.8,&2{%1${:0^,@(y12:command-line)[01}${.2,@(y14:read-code-sex"
|
||||
"p)[01},,#0:1,.3,.2,&3{%1.0R8~?{${:2^,.3,@(y4:eval)[02}${:1,@(y14:read-"
|
||||
"code-sexp)[01},:0^[11}]1}.!0.0^_1[11},.9,@(y28:call-with-current-input"
|
||||
"-file)[02}t]8",
|
||||
|
||||
"P", "repl-evaluate-top-form",
|
||||
"%3,,#0#1.!0${.2,&1{%!0.0:!0]1},.6,.6,&2{%0:1,:0,@(y17:evaluate-top-for"
|
||||
|
|
@ -1628,17 +1627,18 @@ char *t_code[] = {
|
|||
"}t,.4,:2^[42}${.2,'(l2:y14:prepend-libdir;y1:*;),@(y11:sexp-match?)[02"
|
||||
"}?{${.4,@(y21:prepend-library-path!)[01}t,.4,:2^[42}${.2,'(l2:y4:eval;"
|
||||
"y1:*;),@(y11:sexp-match?)[02}?{${t,.5,:4^[02}f,.4,:2^[42}${.2,'(l2:y6:"
|
||||
"script;y1:*;),@(y11:sexp-match?)[02}?{.3,.3,@(y10:run-script)[42}${.2,"
|
||||
"'(l2:y7:program;y1:*;),@(y11:sexp-match?)[02}?{.3,.3,@(y11:run-program"
|
||||
")[42}${.2,'(l2:y9:benchmark;y1:*;),@(y11:sexp-match?)[02}?{.3,.3,@(y10"
|
||||
":run-script)[42}${.2,'(l1:y7:version;),@(y11:sexp-match?)[02}?{${:3^[0"
|
||||
"0}f,n,:2^[42}${.2,'(l1:y4:help;),@(y11:sexp-match?)[02}?{${:1^[00}f,n,"
|
||||
":2^[42}${.2,'(l1:f;),@(y11:sexp-match?)[02}?{.3p?{.3d,.4a,@(y10:run-sc"
|
||||
"ript)[42}:0~?{t,@(y4:exit)[41}f]4}]4},@(y15:*skint-options*),.2,@(y28:"
|
||||
"get-next-command-line-option)[23}.!0.0^_1[02}PiP09?{PoP09}{f}?{${@(y15"
|
||||
":*skint-version*),'(s30:SKINT Scheme Interpreter v~a~%25),t,@(y6:forma"
|
||||
"t)[03}${'(s35:Copyright (c) 2024 False Schemers~%25),t,@(y6:format)[02"
|
||||
"}}t]4",
|
||||
"script;y1:*;),@(y11:sexp-match?)[02}?{${.5,.5,@(y10:run-script)[02},@("
|
||||
"y4:exit)[41}${.2,'(l2:y7:program;y1:*;),@(y11:sexp-match?)[02}?{${.5,."
|
||||
"5,@(y11:run-program)[02},@(y4:exit)[41}${.2,'(l2:y9:benchmark;y1:*;),@"
|
||||
"(y11:sexp-match?)[02}?{${.5,.5,@(y10:run-script)[02},@(y4:exit)[41}${."
|
||||
"2,'(l1:y7:version;),@(y11:sexp-match?)[02}?{${:3^[00}f,n,:2^[42}${.2,'"
|
||||
"(l1:y4:help;),@(y11:sexp-match?)[02}?{${:1^[00}f,n,:2^[42}${.2,'(l1:f;"
|
||||
"),@(y11:sexp-match?)[02}?{.3p?{${.5d,.6a,@(y10:run-script)[02},@(y4:ex"
|
||||
"it)[41}:0~?{t,@(y4:exit)[41}f]4}]4},@(y15:*skint-options*),.2,@(y28:ge"
|
||||
"t-next-command-line-option)[23}.!0.0^_1[02}PiP09?{PoP09}{f}?{${@(y15:*"
|
||||
"skint-version*),'(s30:SKINT Scheme Interpreter v~a~%25),t,@(y6:format)"
|
||||
"[03}${'(s35:Copyright (c) 2024 False Schemers~%25),t,@(y6:format)[02}}"
|
||||
"t]4",
|
||||
|
||||
0, 0, 0
|
||||
};
|
||||
|
|
|
|||
Loading…
Reference in a new issue