From 951f725b6805da215ef2fbc20d743b70db9c40fa Mon Sep 17 00:00:00 2001 From: ESL Date: Mon, 22 Jul 2024 19:22:27 -0400 Subject: [PATCH] (current-directory) added; ksf2c started --- i.c | 16 ++++++++++++ i.h | 2 ++ n.c | 12 +++++++++ pre/ksf2c.ssc | 67 +++++++++++++++++++++++++++++++++++++++++++++++++++ pre/n.sf | 12 +++++++++ pre/s.scm | 13 +++++++++- pre/t.scm | 2 +- s.c | 15 ++++++++++-- t.c | 66 +++++++++++++++++++++++++------------------------- 9 files changed, 168 insertions(+), 37 deletions(-) create mode 100644 pre/ksf2c.ssc diff --git a/i.c b/i.c index 7b24a70..ab2ec93 100644 --- a/i.c +++ b/i.c @@ -3902,6 +3902,22 @@ define_instruction(fren) { gonexti(); } +define_instruction(getcwd) { + extern char *get_cwd(void); + char *s = get_cwd(); + if (s) ac = string_obj(newstring(s)); + else ac = bool_obj(0); + gonexti(); +} + +define_instruction(setcwd) { + extern int set_cwd(char *cwd); + int res; cks(ac); + res = set_cwd(stringchars(ac)); + ac = bool_obj(res == 0); + gonexti(); +} + define_instruction(argvref) { extern char *argv_ref(int idx); int i; char *s; ckk(ac); diff --git a/i.h b/i.h index 001940c..0404bb0 100644 --- a/i.h +++ b/i.h @@ -520,6 +520,8 @@ declare_instruction(wriw, "W8\0Po", 0, "write-simple", declare_instruction(fexis, "F0", 0, "file-exists?", '1', AUTOGL) declare_instruction(frem, "F1", 0, "delete-file", '1', AUTOGL) declare_instruction(fren, "F2", 0, "rename-file", '2', AUTOGL) +declare_instruction(getcwd, "F8", 0, "%cwd", '0', AUTOGL) +declare_instruction(setcwd, "F9", 0, "%set-cwd!", '1', AUTOGL) declare_instruction(argvref, "Z0", 0, "%argv-ref", '1', AUTOGL) declare_instruction(getenv, "Z1", 0, "get-environment-variable", '1', AUTOGL) declare_instruction(envvref, "Z2", 0, "%envv-ref", '1', AUTOGL) diff --git a/n.c b/n.c index c63362e..f1293a1 100644 --- a/n.c +++ b/n.c @@ -1042,4 +1042,16 @@ extern char *envv_ref(int idx) return *pv; } +extern char *get_cwd(void) +{ + static char buf[FILENAME_MAX]; + if (getcwd(buf, FILENAME_MAX) == NULL) return NULL; + return buf; +} + +extern int set_cwd(char *cwd) +{ + return chdir(cwd); +} + diff --git a/pre/ksf2c.ssc b/pre/ksf2c.ssc new file mode 100644 index 0000000..76ea7ba --- /dev/null +++ b/pre/ksf2c.ssc @@ -0,0 +1,67 @@ +;--------------------------------------------------------------------------------------------- +; Skint k.sf precursor compiler (k.sf => k.c) +;--------------------------------------------------------------------------------------------- + +(import (only (skint hidden) + list2? list3?)) + +(define (list4? x) (and (pair? x) (list3? (cdr x)))) + +(define (path-strip-directory filename) + (let loop ([l (reverse (string->list filename))] [r '()]) + (cond [(null? l) (list->string r)] + [(memv (car l) '(#\\ #\/ #\:)) (list->string r)] + [else (loop (cdr l) (cons (car l) r))]))) + +(define (path-strip-extension filename) + (let ([l (reverse (string->list filename))]) + (let ([r (memv #\. l)]) + (if r (list->string (reverse (cdr r))) filename)))) + +(define (module-name filename) + (path-strip-extension (path-strip-directory filename))) + +(define *local-definitions* + '("#ifdef NAN_BOXING" "#ifndef FLONUMS_BOXED" "#else" "#endif")) + +(define (process-top-form x oport) + (when (and (list2? x) (symbol? (car x)) (string? (cadr x))) + (case (car x) + [(%definition) + ; make an exception for some conditional definitions! + (when (member (cadr x) *local-definitions*) + (display (cadr x) oport) (newline oport) (newline oport))] + [(%localdef) (display (cadr x) oport) (newline oport) (newline oport)] ; does not go into n.h + [(%include)]))) ; went into n.h + +(define (process-file sfcpath 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 ifname)) + (display "/* " oport) (display mname oport) + (display ".c -- generated via skint nsf2c.ssc " oport) + (display (path-strip-directory ifname) oport) + (display " */" oport) (newline oport) (newline oport) + (let loop ([x (read iport)] [end-of-includes? #f]) + (unless (eof-object? x) + (cond [end-of-includes? + (process-top-form x oport) + (loop (read iport) #t)] + [(and (list2? x) (eq? (car x) '%include) (string? (cadr x))) + (display "#include " oport) (write (cadr x) oport) (newline oport) + (loop (read iport) #f)] + [else ; switching to body forms + (display "#include \"" oport) (display mname oport) + (display ".h\"" oport) (newline oport) (newline oport) + (process-top-form x oport) + (loop (read iport) #t)]))) + (close-input-port iport) + (if (pair? ?ofname) (close-output-port oport))) + +(define (main args) + (cond [(list3? args) (process-file (cadr args) (caddr args))] + [(list4? args) (process-file (cadr args) (caddr args) (cadddr args))] + [else (error "usage: scint ksf2c.ssc SFCPATH INFILE [OUTFILE]" args)])) + +; this is not a real #! script, so call main manually +;(main (command-line)) diff --git a/pre/n.sf b/pre/n.sf index a037687..f6d00ca 100644 --- a/pre/n.sf +++ b/pre/n.sf @@ -1569,4 +1569,16 @@ extern char *envv_ref(int idx) while (idx-- > 0) if (*pv++ == NULL) return NULL; return *pv; } + +extern char *get_cwd(void) +{ + static char buf[FILENAME_MAX]; + if (getcwd(buf, FILENAME_MAX) == NULL) return NULL; + return buf; +} + +extern int set_cwd(char *cwd) +{ + return chdir(cwd); +} ") diff --git a/pre/s.scm b/pre/s.scm index 9af86cc..2eb10b9 100644 --- a/pre/s.scm +++ b/pre/s.scm @@ -2003,6 +2003,11 @@ ; ; (load s (env (interaction-environment))) +(define current-directory + (case-lambda + [() (%cwd)] + [(d) (or (%set-cwd! d) (error "cannot change directory to" d))] + [(d s) (if s (current-directory d) d)])) (define (%command-line) (let loop ([r '()] [i 0]) @@ -2013,7 +2018,13 @@ (define command-line (make-parameter (%command-line))) ; can be changed later in (main) -(define (features) '(r7rs exact-closed skint skint-1.0.0)) +(define *features* (list r7rs exact-closed skint skint-1.0.0)) + +(define features + (case-lambda + [() *features*] + [(f) (if (list? f) (set! *features* f) (error "cannot change features to" f))] + [(f s) (if s (features f) f)])) (define (feature-available? f) (and (symbol? f) (memq f (features)))) diff --git a/pre/t.scm b/pre/t.scm index 993964d..8df1071 100644 --- a/pre/t.scm +++ b/pre/t.scm @@ -1993,7 +1993,7 @@ (list*) (char-cmp) (char-ci-cmp) (string-cat) (string-position) (string-cmp) (string-ci-cmp) (vector-cat) (bytevector=?) (bytevector->list) (list->bytevector) (subbytevector) (standard-input-port) (standard-output-port) (standard-error-port) (tty-port?) - (port-fold-case?) (set-port-fold-case!) (rename-file) (void) (void?) + (port-fold-case?) (set-port-fold-case!) (rename-file) (current-directory) (void) (void?) ; (repl hidden) library entries below the auto-adder need to be added explicitly (*user-name-registry* . hidden) (make-readonly-environment . hidden) (make-controlled-environment . hidden) (make-sld-environment . hidden) diff --git a/s.c b/s.c index 87c3e48..817616a 100644 --- a/s.c +++ b/s.c @@ -1028,6 +1028,11 @@ char *s_code[] = { "(y19:write-subbytevector)[34}%x,&0{%2.1,.1W3]2}%x,&0{%1Po,.1W3]1}%x,&4" "{|10|21|32|43%%}@!(y16:write-bytevector)", + "C", 0, + "&0{%2.1?{.0,@(y17:current-directory)[21}.0]2}%x,&0{%1.0F9,.0?{.0]2}.1," + "'(s26:cannot change directory to),@(y5:error)[22}%x,&0{%0F8]0}%x,&3{|0" + "0|11|22%%}@!(y17:current-directory)", + "P", "%command-line", "%0'0,n,,#0.0,&1{%2.1Z0,.0?{'1,.3I+,.2,.2c,:0^[32}.1A9]3}.!0.0^_1[02", @@ -1035,8 +1040,14 @@ char *s_code[] = { "${${@(y13:%25command-line)[00},@(y14:make-parameter)[01}@!(y12:command" "-line)", - "P", "features", - "%0'(l4:y4:r7rs;y12:exact-closed;y5:skint;y11:skint-1.0.0;)]0", + "C", 0, + "@(y11:skint-1.0.0),@(y5:skint),@(y12:exact-closed),@(y4:r7rs),l4@!(y10" + ":*features*)", + + "C", 0, + "&0{%2.1?{.0,@(y8:features)[21}.0]2}%x,&0{%1.0L0?{.0@!(y10:*features*)]" + "1}.0,'(s25:cannot change features to),@(y5:error)[12}%x,&0{%0@(y10:*fe" + "atures*)]0}%x,&3{|00|11|22%%}@!(y8:features)", "P", "feature-available?", "%1.0Y0?{${@(y8:features)[00},.1A0]1}f]1", diff --git a/t.c b/t.c index 3680a19..2d7171c 100644 --- a/t.c +++ b/t.c @@ -1101,7 +1101,7 @@ char *t_code[] = { "0:*root-name-registry*),@(y11:name-lookup)[03}", "C", 0, - "${'(l505:l3:y1:*;y1:v;y1:b;;l3:y1:+;y1:v;y1:b;;l3:y1:-;y1:v;y1:b;;l4:y" + "${'(l506:l3:y1:*;y1:v;y1:b;;l3:y1:+;y1:v;y1:b;;l3:y1:-;y1:v;y1:b;;l4:y" "3:...;y1:v;y1:u;y1:b;;l3:y1:/;y1:v;y1:b;;l3:y1:<;y1:v;y1:b;;l3:y2:<=;y" "1:v;y1:b;;l3:y1:=;y1:v;y1:b;;l4:y2:=>;y1:v;y1:u;y1:b;;l3:y1:>;y1:v;y1:" "b;;l3:y2:>=;y1:v;y1:b;;l2:y1:_;y1:b;;l3:y3:abs;y1:v;y1:b;;l4:y3:and;y1" @@ -1263,38 +1263,38 @@ char *t_code[] = { "l1:y12:bytevector=?;;l1:y16:bytevector->list;;l1:y16:list->bytevector;" ";l1:y13:subbytevector;;l1:y19:standard-input-port;;l1:y20:standard-out" "put-port;;l1:y19:standard-error-port;;l1:y9:tty-port?;;l1:y15:port-fol" - "d-case?;;l1:y19:set-port-fold-case!;;l1:y11:rename-file;;l1:y4:void;;l" - "1:y5:void?;;py20:*user-name-registry*;y6:hidden;;py25:make-readonly-en" - "vironment;y6:hidden;;py27:make-controlled-environment;y6:hidden;;py20:" - "make-sld-environment;y6:hidden;;py21:make-repl-environment;y6:hidden;;" - "py19:find-library-in-env;y6:hidden;;py16:root-environment;y6:hidden;;p" - "y16:repl-environment;y6:hidden;;py17:empty-environment;y6:hidden;;py32" - ":make-historic-report-environment;y6:hidden;;py16:r5rs-environment;y6:" - "hidden;;py21:r5rs-null-environment;y6:hidden;;py9:*verbose*;y6:hidden;" - ";py7:*quiet*;y6:hidden;;py25:compile-and-run-core-expr;y6:hidden;;py17" - ":evaluate-top-form;y6:hidden;;py10:run-script;y6:hidden;;py11:run-prog" - "ram;y6:hidden;;py22:repl-evaluate-top-form;y6:hidden;;py9:repl-read;y6" - ":hidden;;py17:repl-exec-command;y6:hidden;;py14:repl-from-port;y6:hidd" - "en;;py13:run-benchmark;y6:hidden;;py4:repl;y6:hidden;;),&0{%1,,,,#0#1#" - "2#3&0{%1.0,'(y1:w),.1v?{'(l2:y6:scheme;y5:write;)]2}'(y1:t),.1v?{'(l2:" - "y6:scheme;y4:time;)]2}'(y1:p),.1v?{'(l2:y6:scheme;y4:repl;)]2}'(y1:r)," - ".1v?{'(l2:y6:scheme;y4:read;)]2}'(y1:v),.1v?{'(l2:y6:scheme;y4:r5rs;)]" - "2}'(y1:u),.1v?{'(l2:y6:scheme;y9:r5rs-null;)]2}'(y1:d),.1v?{'(l2:y6:sc" - "heme;y4:load;)]2}'(y1:z),.1v?{'(l2:y6:scheme;y4:lazy;)]2}'(y1:s),.1v?{" - "'(l2:y6:scheme;y15:process-context;)]2}'(y1:i),.1v?{'(l2:y6:scheme;y7:" - "inexact;)]2}'(y1:f),.1v?{'(l2:y6:scheme;y4:file;)]2}'(y1:e),.1v?{'(l2:" - "y6:scheme;y4:eval;)]2}'(y1:o),.1v?{'(l2:y6:scheme;y7:complex;)]2}'(y1:" - "h),.1v?{'(l2:y6:scheme;y4:char;)]2}'(y1:l),.1v?{'(l2:y6:scheme;y11:cas" - "e-lambda;)]2}'(y1:a),.1v?{'(l2:y6:scheme;y3:cxr;)]2}'(y1:b),.1v?{'(l2:" - "y6:scheme;y4:base;)]2}'(y1:x),.1v?{'(l2:y6:scheme;y3:box;)]2}.1I0?{.1," - "'(y4:srfi),l2]2}.1,l1]2}.!0&0{%1${&0{%1n,'(l1:y5:begin;),V12]1},.3,@(y" - "20:*root-name-registry*),@(y11:name-lookup)[03}z]1}.!1&0{%3'1,.1V4,.0," - ".3A3,.0?{.4,.1sd]5}.1,.5,.5cc,'1,.4V5]5}.!2&0{%1&0{%1.0,'(y5:const),l2" - "]1},.1,@(y20:*root-name-registry*),@(y11:name-lookup)[13}.!3.4d,.5a,,#" - "0.0,.6,.5,.7,.(i10),&5{%2.1u?{${.2,:0^[01},.1,${'(l1:y5:skint;),:1^[01" - "},:3^[23}.1p~?{${.2,:0^[01},.1,${n,.6c,'(y5:skint)c,:1^[01},:3^[23}${$" - "{.4,:0^[01},.3,${${.9a,:2^[01},:1^[01},:3^[03}.1d,.1,:4^[22}.!0.0^_1[5" - "2},@(y10:%25for-each1)[02}", + "d-case?;;l1:y19:set-port-fold-case!;;l1:y11:rename-file;;l1:y17:curren" + "t-directory;;l1:y4:void;;l1:y5:void?;;py20:*user-name-registry*;y6:hid" + "den;;py25:make-readonly-environment;y6:hidden;;py27:make-controlled-en" + "vironment;y6:hidden;;py20:make-sld-environment;y6:hidden;;py21:make-re" + "pl-environment;y6:hidden;;py19:find-library-in-env;y6:hidden;;py16:roo" + "t-environment;y6:hidden;;py16:repl-environment;y6:hidden;;py17:empty-e" + "nvironment;y6:hidden;;py32:make-historic-report-environment;y6:hidden;" + ";py16:r5rs-environment;y6:hidden;;py21:r5rs-null-environment;y6:hidden" + ";;py9:*verbose*;y6:hidden;;py7:*quiet*;y6:hidden;;py25:compile-and-run" + "-core-expr;y6:hidden;;py17:evaluate-top-form;y6:hidden;;py10:run-scrip" + "t;y6:hidden;;py11:run-program;y6:hidden;;py22:repl-evaluate-top-form;y" + "6:hidden;;py9:repl-read;y6:hidden;;py17:repl-exec-command;y6:hidden;;p" + "y14:repl-from-port;y6:hidden;;py13:run-benchmark;y6:hidden;;py4:repl;y" + "6:hidden;;),&0{%1,,,,#0#1#2#3&0{%1.0,'(y1:w),.1v?{'(l2:y6:scheme;y5:wr" + "ite;)]2}'(y1:t),.1v?{'(l2:y6:scheme;y4:time;)]2}'(y1:p),.1v?{'(l2:y6:s" + "cheme;y4:repl;)]2}'(y1:r),.1v?{'(l2:y6:scheme;y4:read;)]2}'(y1:v),.1v?" + "{'(l2:y6:scheme;y4:r5rs;)]2}'(y1:u),.1v?{'(l2:y6:scheme;y9:r5rs-null;)" + "]2}'(y1:d),.1v?{'(l2:y6:scheme;y4:load;)]2}'(y1:z),.1v?{'(l2:y6:scheme" + ";y4:lazy;)]2}'(y1:s),.1v?{'(l2:y6:scheme;y15:process-context;)]2}'(y1:" + "i),.1v?{'(l2:y6:scheme;y7:inexact;)]2}'(y1:f),.1v?{'(l2:y6:scheme;y4:f" + "ile;)]2}'(y1:e),.1v?{'(l2:y6:scheme;y4:eval;)]2}'(y1:o),.1v?{'(l2:y6:s" + "cheme;y7:complex;)]2}'(y1:h),.1v?{'(l2:y6:scheme;y4:char;)]2}'(y1:l),." + "1v?{'(l2:y6:scheme;y11:case-lambda;)]2}'(y1:a),.1v?{'(l2:y6:scheme;y3:" + "cxr;)]2}'(y1:b),.1v?{'(l2:y6:scheme;y4:base;)]2}'(y1:x),.1v?{'(l2:y6:s" + "cheme;y3:box;)]2}.1I0?{.1,'(y4:srfi),l2]2}.1,l1]2}.!0&0{%1${&0{%1n,'(l" + "1:y5:begin;),V12]1},.3,@(y20:*root-name-registry*),@(y11:name-lookup)[" + "03}z]1}.!1&0{%3'1,.1V4,.0,.3A3,.0?{.4,.1sd]5}.1,.5,.5cc,'1,.4V5]5}.!2&" + "0{%1&0{%1.0,'(y5:const),l2]1},.1,@(y20:*root-name-registry*),@(y11:nam" + "e-lookup)[13}.!3.4d,.5a,,#0.0,.6,.5,.7,.(i10),&5{%2.1u?{${.2,:0^[01},." + "1,${'(l1:y5:skint;),:1^[01},:3^[23}.1p~?{${.2,:0^[01},.1,${n,.6c,'(y5:" + "skint)c,:1^[01},:3^[23}${${.4,:0^[01},.3,${${.9a,:2^[01},:1^[01},:3^[0" + "3}.1d,.1,:4^[22}.!0.0^_1[52},@(y10:%25for-each1)[02}", "C", 0, "@(y20:*root-name-registry*),${f,'(l1:y5:skint;),.4,@(y11:name-lookup)["