(current-directory) added; ksf2c started

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);

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)

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);
+}
+
 

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))

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);
+}
 ")

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))))
 

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) 

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",
+  "C", 0,
-  "%0'(l4:y4:r7rs;y12:exact-closed;y5:skint;y11:skint-1.0.0;)]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",

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"
+  "d-case?;;l1:y19:set-port-fold-case!;;l1:y11:rename-file;;l1:y17:curren"
-  "1:y5:void?;;py20:*user-name-registry*;y6:hidden;;py25:make-readonly-en"
+  "t-directory;;l1:y4:void;;l1:y5:void?;;py20:*user-name-registry*;y6:hid"
-  "vironment;y6:hidden;;py27:make-controlled-environment;y6:hidden;;py20:"
+  "den;;py25:make-readonly-environment;y6:hidden;;py27:make-controlled-en"
-  "make-sld-environment;y6:hidden;;py21:make-repl-environment;y6:hidden;;"
+  "vironment;y6:hidden;;py20:make-sld-environment;y6:hidden;;py21:make-re"
-  "py19:find-library-in-env;y6:hidden;;py16:root-environment;y6:hidden;;p"
+  "pl-environment;y6:hidden;;py19:find-library-in-env;y6:hidden;;py16:roo"
-  "y16:repl-environment;y6:hidden;;py17:empty-environment;y6:hidden;;py32"
+  "t-environment;y6:hidden;;py16:repl-environment;y6:hidden;;py17:empty-e"
-  ":make-historic-report-environment;y6:hidden;;py16:r5rs-environment;y6:"
+  "nvironment;y6:hidden;;py32:make-historic-report-environment;y6:hidden;"
-  "hidden;;py21:r5rs-null-environment;y6:hidden;;py9:*verbose*;y6:hidden;"
+  ";py16:r5rs-environment;y6:hidden;;py21:r5rs-null-environment;y6:hidden"
-  ";py7:*quiet*;y6:hidden;;py25:compile-and-run-core-expr;y6:hidden;;py17"
+  ";;py9:*verbose*;y6:hidden;;py7:*quiet*;y6:hidden;;py25:compile-and-run"
-  ":evaluate-top-form;y6:hidden;;py10:run-script;y6:hidden;;py11:run-prog"
+  "-core-expr;y6:hidden;;py17:evaluate-top-form;y6:hidden;;py10:run-scrip"
-  "ram;y6:hidden;;py22:repl-evaluate-top-form;y6:hidden;;py9:repl-read;y6"
+  "t;y6:hidden;;py11:run-program;y6:hidden;;py22:repl-evaluate-top-form;y"
-  ":hidden;;py17:repl-exec-command;y6:hidden;;py14:repl-from-port;y6:hidd"
+  "6:hidden;;py9:repl-read;y6:hidden;;py17:repl-exec-command;y6:hidden;;p"
-  "en;;py13:run-benchmark;y6:hidden;;py4:repl;y6:hidden;;),&0{%1,,,,#0#1#"
+  "y14:repl-from-port;y6:hidden;;py13:run-benchmark;y6:hidden;;py4:repl;y"
-  "2#3&0{%1.0,'(y1:w),.1v?{'(l2:y6:scheme;y5:write;)]2}'(y1:t),.1v?{'(l2:"
+  "6:hidden;;),&0{%1,,,,#0#1#2#3&0{%1.0,'(y1:w),.1v?{'(l2:y6:scheme;y5:wr"
-  "y6:scheme;y4:time;)]2}'(y1:p),.1v?{'(l2:y6:scheme;y4:repl;)]2}'(y1:r),"
+  "ite;)]2}'(y1:t),.1v?{'(l2:y6:scheme;y4:time;)]2}'(y1:p),.1v?{'(l2:y6:s"
-  ".1v?{'(l2:y6:scheme;y4:read;)]2}'(y1:v),.1v?{'(l2:y6:scheme;y4:r5rs;)]"
+  "cheme;y4:repl;)]2}'(y1:r),.1v?{'(l2:y6:scheme;y4:read;)]2}'(y1:v),.1v?"
-  "2}'(y1:u),.1v?{'(l2:y6:scheme;y9:r5rs-null;)]2}'(y1:d),.1v?{'(l2:y6:sc"
+  "{'(l2:y6:scheme;y4:r5rs;)]2}'(y1:u),.1v?{'(l2:y6:scheme;y9:r5rs-null;)"
-  "heme;y4:load;)]2}'(y1:z),.1v?{'(l2:y6:scheme;y4:lazy;)]2}'(y1:s),.1v?{"
+  "]2}'(y1:d),.1v?{'(l2:y6:scheme;y4:load;)]2}'(y1:z),.1v?{'(l2:y6:scheme"
-  "'(l2:y6:scheme;y15:process-context;)]2}'(y1:i),.1v?{'(l2:y6:scheme;y7:"
+  ";y4:lazy;)]2}'(y1:s),.1v?{'(l2:y6:scheme;y15:process-context;)]2}'(y1:"
-  "inexact;)]2}'(y1:f),.1v?{'(l2:y6:scheme;y4:file;)]2}'(y1:e),.1v?{'(l2:"
+  "i),.1v?{'(l2:y6:scheme;y7:inexact;)]2}'(y1:f),.1v?{'(l2:y6:scheme;y4:f"
-  "y6:scheme;y4:eval;)]2}'(y1:o),.1v?{'(l2:y6:scheme;y7:complex;)]2}'(y1:"
+  "ile;)]2}'(y1:e),.1v?{'(l2:y6:scheme;y4:eval;)]2}'(y1:o),.1v?{'(l2:y6:s"
-  "h),.1v?{'(l2:y6:scheme;y4:char;)]2}'(y1:l),.1v?{'(l2:y6:scheme;y11:cas"
+  "cheme;y7:complex;)]2}'(y1:h),.1v?{'(l2:y6:scheme;y4:char;)]2}'(y1:l),."
-  "e-lambda;)]2}'(y1:a),.1v?{'(l2:y6:scheme;y3:cxr;)]2}'(y1:b),.1v?{'(l2:"
+  "1v?{'(l2:y6:scheme;y11:case-lambda;)]2}'(y1:a),.1v?{'(l2:y6:scheme;y3:"
-  "y6:scheme;y4:base;)]2}'(y1:x),.1v?{'(l2:y6:scheme;y3:box;)]2}.1I0?{.1,"
+  "cxr;)]2}'(y1:b),.1v?{'(l2:y6:scheme;y4:base;)]2}'(y1:x),.1v?{'(l2:y6:s"
-  "'(y4:srfi),l2]2}.1,l1]2}.!0&0{%1${&0{%1n,'(l1:y5:begin;),V12]1},.3,@(y"
+  "cheme;y3:box;)]2}.1I0?{.1,'(y4:srfi),l2]2}.1,l1]2}.!0&0{%1${&0{%1n,'(l"
-  "20:*root-name-registry*),@(y11:name-lookup)[03}z]1}.!1&0{%3'1,.1V4,.0,"
+  "1:y5:begin;),V12]1},.3,@(y20:*root-name-registry*),@(y11:name-lookup)["
-  ".3A3,.0?{.4,.1sd]5}.1,.5,.5cc,'1,.4V5]5}.!2&0{%1&0{%1.0,'(y5:const),l2"
+  "03}z]1}.!1&0{%3'1,.1V4,.0,.3A3,.0?{.4,.1sd]5}.1,.5,.5cc,'1,.4V5]5}.!2&"
-  "]1},.1,@(y20:*root-name-registry*),@(y11:name-lookup)[13}.!3.4d,.5a,,#"
+  "0{%1&0{%1.0,'(y5:const),l2]1},.1,@(y20:*root-name-registry*),@(y11:nam"
-  "0.0,.6,.5,.7,.(i10),&5{%2.1u?{${.2,:0^[01},.1,${'(l1:y5:skint;),:1^[01"
+  "e-lookup)[13}.!3.4d,.5a,,#0.0,.6,.5,.7,.(i10),&5{%2.1u?{${.2,:0^[01},."
-  "},:3^[23}.1p~?{${.2,:0^[01},.1,${n,.6c,'(y5:skint)c,:1^[01},:3^[23}${$"
+  "1,${'(l1:y5:skint;),:1^[01},:3^[23}.1p~?{${.2,:0^[01},.1,${n,.6c,'(y5:"
-  "{.4,:0^[01},.3,${${.9a,:2^[01},:1^[01},:3^[03}.1d,.1,:4^[22}.!0.0^_1[5"
+  "skint)c,:1^[01},:3^[23}${${.4,:0^[01},.3,${${.9a,:2^[01},:1^[01},:3^[0"
-  "2},@(y10:%25for-each1)[02}",
+  "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)["