From c48e935bba8fc2591fa9b51f61c5cdd0ed680af8 Mon Sep 17 00:00:00 2001 From: ESL Date: Sun, 21 Jul 2024 11:35:13 -0400 Subject: [PATCH] script-related fixes; fully operational ccomp --- src/ccomp.ssc | 47 +++++++++++----------- src/s.scm | 5 ++- src/t.scm | 107 ++++++++++++++++++++++++-------------------------- t.c | 70 ++++++++++++++++----------------- 4 files changed, 112 insertions(+), 117 deletions(-) diff --git a/src/ccomp.ssc b/src/ccomp.ssc index 7a70e58..1a03773 100644 --- a/src/ccomp.ssc +++ b/src/ccomp.ssc @@ -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) @@ -195,9 +193,10 @@ (close-input-port iport) (if (pair? ?ofname) (close-output-port oport))) - (define (main args) - (cond [(list2? args) (process-file (cadr args))] - [(list3? args) (process-file (cadr args) (caddr args))] - [else (error "usage: ccomp INFILE [OUTFILE]" args)])) - - ;(main (command-line)) +(define (main args) + (cond [(list2? args) (process-file (cadr args))] + [(list3? args) (process-file (cadr args) (caddr args))] + [else (error "usage: ccomp INFILE [OUTFILE]" args)])) + +; this is not a real #! script, so call main manually +(main (command-line)) diff --git a/src/s.scm b/src/s.scm index 5bc4f3b..9af86cc 100644 --- a/src/s.scm +++ b/src/s.scm @@ -273,8 +273,9 @@ ; should be something like (cons name fields), but that would complicate procedure? ; 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)))] + (let loop ([fl (cons name fields)] [sl '("rtd://")]) + ; 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)))]))) diff --git a/src/t.scm b/src/t.scm index 566778e..993964d 100644 --- a/src/t.scm +++ b/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 - (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))))))))) + (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)))))) ; we aren't asked by the spec to call last expr tail-recursively, so this (void)) @@ -2330,33 +2332,30 @@ (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 - (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)] - [(string-position "r5rs" shs) - (set! env (scheme-report-environment 5)) - (set! ci? #t)] - [else (error "only scheme-r[57]rs scripts are supported" shs)]) - (when ci? (set-port-fold-case! port #t)) - (set! callmain #t) - (set! x0 (read-code-sexp port)))) - (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))) + (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)] ; skint env will do + [(string-position "skint" shs)] ; ditto + [(string-position "r5rs" shs) + (set! env (scheme-report-environment 5)) + (set! ci? #t)] + [else (error "only scheme-r[57]rs scripts are supported" shs)]) + (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))))) + (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 - (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))) + (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)))))) + ; 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))) diff --git a/t.c b/t.c index 600b5af..c6f1303 100644 --- a/t.c +++ b/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 };