service -c compiler reborn as ccomp.ssc!

src/ccomp.ssc

@@ -0,0 +1,203 @@
+;---------------------------------------------------------------------------------------------
+; Skint File compiler (Limited Scheme => Serialized code as C data)
+;---------------------------------------------------------------------------------------------
+
+(import (only (skint hidden) 
+  list2? list3? location-set-val! root-environment
+  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))
+
+(define *transformers*
+  (list
+    (cons 'syntax-quote 'syntax-quote) 
+    (cons 'quote 'quote)
+    (cons 'set! 'set!)
+    (cons 'set& 'set&)
+    (cons 'if 'if)
+    (cons 'lambda 'lambda)
+    (cons 'lambda* 'lambda*)
+    (cons 'letcc 'letcc)
+    (cons 'withcc 'withcc)
+    (cons 'body 'body)
+    (cons 'begin 'begin)
+    (cons 'define 'define)
+    (cons 'define-syntax 'define-syntax)
+    (cons 'syntax-lambda 'syntax-lambda)
+    (cons 'syntax-rules 'syntax-rules)
+    (cons 'syntax-length 'syntax-length)
+    (cons 'syntax-error 'syntax-error)
+    (cons 'define-library 'define-library)
+    (cons 'program 'program)
+    (cons 'import 'import)
+    (cons 'export 'export)
+    (cons '... '...)
+    (cons '_ '_)))
+
+(define *top-transformer-env* #f)
+
+(define (top-transformer-env id at)
+  (unless *top-transformer-env*
+    (set! *top-transformer-env* 
+      (map (lambda (bnd)
+             (case (car bnd)
+               [(... _) ; syntax-rules looks them up in skint's root env!!
+                (cons (car bnd) (root-environment (car bnd) 'ref))]
+               [else ; for the rest, it is val that matters
+                (cons (car bnd) (make-location (cdr bnd)))])) 
+         *transformers*)))
+  (if (new-id? id)
+      (new-id-lookup id at) ; nonsymbolic ids can't be globally bound
+      (cond [(assq id *top-transformer-env*) => cdr]
+            [else 
+             (let ([loc (make-location (or (lookup-integrable id) (list 'ref id)))])
+               (set! *top-transformer-env* (cons (cons id loc) *top-transformer-env*))
+               loc)])))
+
+
+(define (install-transformer! s t)
+  (location-set-val! (top-transformer-env s 'ref) t))
+
+(define (transform appos? sexp . ?env)
+  (xform appos? sexp (if (null? ?env) top-transformer-env (car ?env))))
+
+(define *hide-refs* '())
+
+(define (display-code cstr oport)
+  (let loop ([i 0] [l (string-length cstr)])
+    (let ([r (fx- l i)])
+      (cond [(<= r 70)
+             (display "  \"" oport)
+             (display (substring cstr i l) oport)
+             (display "\"," oport)]
+            [else
+             (display "  \"" oport)
+             (display (substring cstr i (fx+ i 70)) oport)
+             (display "\"\n" oport)             
+             (loop (fx+ i 70) l)]))))  
+
+(define (process-syntax id xval oport)
+  (newline oport)
+  (display "  \"S\", \"" oport) (display id oport) (display "\",\n" oport)
+  (let ([p (open-output-string)]) (write-serialized-sexp xval p)
+    (display-code (get-output-string p) oport) (newline oport)))
+
+(define (process-alias id oldid oport)
+  (newline oport)
+  (display "  \"A\", \"" oport) (display id oport) (display "\"," oport)
+  (display " \"" oport) (display oldid oport) (display "\",\n" oport))
+
+(define (process-command xval oport)
+  (define cstr (compile-to-string xval))
+  (newline oport)
+  (display "  \"C\", 0,\n" oport)
+  (display-code cstr oport) (newline oport))
+
+(define (process-define id xlam oport)
+  (define cstr (compile-to-string xlam))
+  (let ([len (string-length cstr)])
+    (cond [(and (eq? (car xlam) 'lambda)
+                (> len 4) 
+                (char=? (string-ref cstr 0) #\&) 
+                (char=? (string-ref cstr 1) #\0) 
+                (char=? (string-ref cstr 2) #\{)
+                (char=? (string-ref cstr (fx- len 1)) #\}))
+           (newline oport)
+           (display "  \"P\", \"" oport) (display id oport) (display "\",\n" oport)
+           (display-code (substring cstr 3 (fx- len 1)) oport) (newline oport)]
+          [else (process-command (list 'set! id xlam) oport)])))
+
+(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))]
+    [(pair? x)
+     (let ([hval (transform #t (car x))])
+       (cond
+         [(eq? hval 'begin)
+          (for-each scan-top-form (cdr x))]
+         [(eq? hval 'define-syntax)
+          (let ([xval (transform #t (caddr x))])
+            (install-transformer! (cadr x) xval))]
+         [(procedure? hval)
+          (scan-top-form (hval x top-transformer-env))]))]))
+
+(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))]
+    [(pair? x)
+     (let ([hval (transform #t (car x))])
+       (cond
+         [(eq? hval 'begin)
+          (let loop ([x* (cdr x)])
+            (when (pair? x*) 
+              (process-top-form (car x*) oport)
+              (loop (cdr x*))))]
+         [(eq? hval 'define-syntax)
+          (let ([xval (transform #t (caddr x))])
+            (install-transformer! (cadr x) xval)
+            (unless (memq (cadr x) *hide-refs*) 
+              (if (symbol? (caddr x))
+                  (process-alias (cadr x) (caddr x) oport)
+                  (process-syntax (cadr x) (caddr x) oport))))]
+         [(eq? hval 'define)
+          (let* ([dval (transform #f x)] [xval (caddr dval)])
+            (process-define (cadr dval) xval oport))]
+         [(procedure? hval)
+          (process-top-form (hval x top-transformer-env) oport)]
+         [else
+          (process-command (transform #f x) oport)]))]
+    [else
+     (process-command (transform #f x) oport)]))
+
+(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 (process-file fname . ?ofname)
+  (define iport (open-input-file fname))
+  (define oport (if (pair? ?ofname) (open-output-file (car ?ofname)) (current-output-port)))
+  (define mname (module-name fname))
+  (display "/* " oport) (display mname oport) 
+  (display ".c -- generated via skint -c " oport) 
+  (display (path-strip-directory fname) oport) 
+  (display " */" oport) (newline oport) (newline oport)
+  (display "char *" oport) (display mname oport) 
+  (display "_code[] = {" oport) (newline oport)
+  (let loop ([x (read iport)])
+    (unless (eof-object? x)
+      (process-top-form x oport)
+      (loop (read iport))))
+  (display "\n  0, 0, 0\n};\n" oport)
+  (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))

src/s.scm

@@ -274,7 +274,7 @@
   ; 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 string-append (reverse sl)))]
+     (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)))]))) 
   
@@ -1267,13 +1267,13 @@
    (newline ep))
 
 (define (simple-error . args)
-  (let ([ep (current-error-port)])
+  (let ([ep (%current-error-port)])
     (newline ep)
     (print-error-message "Error" args ep)
     (reset)))
 
 (define (assertion-violation . args)
-  (let ([ep (current-error-port)])
+  (let ([ep (%current-error-port)])
     (newline ep)
     (print-error-message "Assertion violation" args ep)
     (reset)))

src/t.scm

@@ -1970,7 +1970,7 @@
     ; selected extracts from r7rs-large and srfis
     (box? x 111) (box x 111) (unbox x 111) (set-box! x 111) (format 28 48) 
     (fprintf) (format-pretty-print) (format-fixed-print) (format-fresh-line) (format-help-string)
-    ; skint extras go into (skint) only
+    ; skint extras go into (skint); the rest goes to (skint hidden)
     (set&) (lambda*) (body) (letcc) (withcc) (syntax-lambda) (syntax-length)
     (record?) (make-record) (record-length) (record-ref) (record-set!) 
     (fixnum?) (fxpositive?) (fxnegative?) (fxeven?) (fxodd?) (fxzero?) (fx+) (fx*) (fx-) (fx/) 
@@ -1986,11 +1986,16 @@
     (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?) (global-store . hidden)
+    (port-fold-case?) (set-port-fold-case!) (rename-file) (void) (void?)
-    (run-script . hidden) (get-next-command-line-option . hidden) (print-command-line-options . hidden)
+    ; (repl hidden) library entries below the auto-adder need to be added explicitly 
-    (xform . hidden) (compile-and-run-core-expr . hidden) (compile-to-thunk-code . hidden) 
+    (*user-name-registry* . hidden) (make-readonly-environment . hidden) 
-    (deserialize-code . hidden) (closure . hidden) (repl-environment . hidden)
+    (make-controlled-environment . hidden) (make-sld-environment . hidden) 
-    (*skint-options* . hidden)
+    (make-repl-environment . hidden) (find-library-in-env . hidden) (root-environment . hidden)
+    (repl-environment . hidden) (empty-environment . hidden) (make-historic-report-environment . hidden)
+    (r5rs-environment . hidden) (r5rs-null-environment . hidden) (*verbose*  . hidden) (*quiet*  . hidden)
+    (compile-and-run-core-expr . hidden) (evaluate-top-form . hidden) (run-script . hidden)
+    (run-program . hidden) (repl-evaluate-top-form . hidden) (repl-read . hidden) 
+    (repl-exec-command . hidden) (repl-from-port . hidden) (run-benchmark . hidden) (repl . hidden) 
     ))
 
 ; clean up root environment by moving all symbolic bindings not in (skint) library
@@ -2007,11 +2012,21 @@
                   (loop prev (cdr lst))]))))
 
 ; make hidden bindings available via (skint hidden) library
+; note: definitions below this expression are not yet in (global-store), so one
+; has to add them explicitly via (foo . hidden) mechanism above
 (let* ([mklib (lambda (ln) (make-library '(begin) '()))]
        [loc (name-lookup *root-name-registry* '(skint hidden) mklib)]
        [lib (location-val loc)] [eal (vector-ref *hidden-name-registry* 0)]
-       [combeal (adjoin-eals eal (library-exports lib))])
+       [combeal (adjoin-eals eal (library-exports lib))]
-  ;(vector-set! *hidden-name-registry* 0 combeal)
+       [skintloc (name-lookup *root-name-registry* '(skint) #f)]
+       [skintlib (and (location? skintloc) (location-val skintloc))]
+       [skinteal (and (val-library? skintlib) (library-exports skintlib))])
+  (define (add-hidden-ref! p)
+    (let* ([id (car p)] [in-sk? (and skinteal (assq id skinteal))])
+      (unless (or in-sk? (assq id combeal))
+        (set! combeal (cons (cons id (make-location (list 'const id))) combeal)))))
+  (let* ([gsv (global-store)] [n (vector-length gsv)])
+    (do ([i 0 (+ i 1)]) [(>= i n)] (for-each add-hidden-ref! (vector-ref gsv i)))) 
   (library-set-exports! lib combeal))
 
 ; private registry for names introduced in repl 
@@ -2511,7 +2526,7 @@
    [help           "-h" "--help" #f              "Display this help"]
 ))
 
-(define *skint-version* "0.1.9")
+(define *skint-version* "0.2.9")
 
 (define (skint-main)
   ; see if command line asks for special processing

t.c

@@ -1096,7 +1096,7 @@ char *t_code[] = {
   "0:*root-name-registry*),@(y11:name-lookup)[03}",
 
   "C", 0,
-  "${'(l492:l3:y1:*;y1:v;y1:b;;l3:y1:+;y1:v;y1:b;;l3:y1:-;y1:v;y1:b;;l4:y"
+  "${'(l505: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"
@@ -1259,30 +1259,37 @@ char *t_code[] = {
   ";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?;;py12:global-store;y6:hidden;;py10:run-script;y6:hidden;;py"
+  "1:y5:void?;;py20:*user-name-registry*;y6:hidden;;py25:make-readonly-en"
-  "28:get-next-command-line-option;y6:hidden;;py26:print-command-line-opt"
+  "vironment;y6:hidden;;py27:make-controlled-environment;y6:hidden;;py20:"
-  "ions;y6:hidden;;py5:xform;y6:hidden;;py25:compile-and-run-core-expr;y6"
+  "make-sld-environment;y6:hidden;;py21:make-repl-environment;y6:hidden;;"
-  ":hidden;;py21:compile-to-thunk-code;y6:hidden;;py16:deserialize-code;y"
+  "py19:find-library-in-env;y6:hidden;;py16:root-environment;y6:hidden;;p"
-  "6:hidden;;py7:closure;y6:hidden;;py16:repl-environment;y6:hidden;;py15"
+  "y16:repl-environment;y6:hidden;;py17:empty-environment;y6:hidden;;py32"
-  ":*skint-options*;y6:hidden;;),&0{%1,,,,#0#1#2#3&0{%1.0,'(y1:w),.1v?{'("
+  ":make-historic-report-environment;y6:hidden;;py16:r5rs-environment;y6:"
-  "l2:y6:scheme;y5:write;)]2}'(y1:t),.1v?{'(l2:y6:scheme;y4:time;)]2}'(y1"
+  "hidden;;py21:r5rs-null-environment;y6:hidden;;py9:*verbose*;y6:hidden;"
-  ":p),.1v?{'(l2:y6:scheme;y4:repl;)]2}'(y1:r),.1v?{'(l2:y6:scheme;y4:rea"
+  ";py7:*quiet*;y6:hidden;;py25:compile-and-run-core-expr;y6:hidden;;py17"
-  "d;)]2}'(y1:v),.1v?{'(l2:y6:scheme;y4:r5rs;)]2}'(y1:u),.1v?{'(l2:y6:sch"
+  ":evaluate-top-form;y6:hidden;;py10:run-script;y6:hidden;;py11:run-prog"
-  "eme;y9:r5rs-null;)]2}'(y1:d),.1v?{'(l2:y6:scheme;y4:load;)]2}'(y1:z),."
+  "ram;y6:hidden;;py22:repl-evaluate-top-form;y6:hidden;;py9:repl-read;y6"
-  "1v?{'(l2:y6:scheme;y4:lazy;)]2}'(y1:s),.1v?{'(l2:y6:scheme;y15:process"
+  ":hidden;;py17:repl-exec-command;y6:hidden;;py14:repl-from-port;y6:hidd"
-  "-context;)]2}'(y1:i),.1v?{'(l2:y6:scheme;y7:inexact;)]2}'(y1:f),.1v?{'"
+  "en;;py13:run-benchmark;y6:hidden;;py4:repl;y6:hidden;;),&0{%1,,,,#0#1#"
-  "(l2:y6:scheme;y4:file;)]2}'(y1:e),.1v?{'(l2:y6:scheme;y4:eval;)]2}'(y1"
+  "2#3&0{%1.0,'(y1:w),.1v?{'(l2:y6:scheme;y5:write;)]2}'(y1:t),.1v?{'(l2:"
-  ":o),.1v?{'(l2:y6:scheme;y7:complex;)]2}'(y1:h),.1v?{'(l2:y6:scheme;y4:"
+  "y6:scheme;y4:time;)]2}'(y1:p),.1v?{'(l2:y6:scheme;y4:repl;)]2}'(y1:r),"
-  "char;)]2}'(y1:l),.1v?{'(l2:y6:scheme;y11:case-lambda;)]2}'(y1:a),.1v?{"
+  ".1v?{'(l2:y6:scheme;y4:read;)]2}'(y1:v),.1v?{'(l2:y6:scheme;y4:r5rs;)]"
-  "'(l2:y6:scheme;y3:cxr;)]2}'(y1:b),.1v?{'(l2:y6:scheme;y4:base;)]2}'(y1"
+  "2}'(y1:u),.1v?{'(l2:y6:scheme;y9:r5rs-null;)]2}'(y1:d),.1v?{'(l2:y6:sc"
-  ":x),.1v?{'(l2:y6:scheme;y3:box;)]2}.1I0?{.1,'(y4:srfi),l2]2}.1,l1]2}.!"
+  "heme;y4:load;)]2}'(y1:z),.1v?{'(l2:y6:scheme;y4:lazy;)]2}'(y1:s),.1v?{"
-  "0&0{%1${&0{%1n,'(l1:y5:begin;),V12]1},.3,@(y20:*root-name-registry*),@"
+  "'(l2:y6:scheme;y15:process-context;)]2}'(y1:i),.1v?{'(l2:y6:scheme;y7:"
-  "(y11:name-lookup)[03}z]1}.!1&0{%3'1,.1V4,.0,.3A3,.0?{.4,.1sd]5}.1,.5,."
+  "inexact;)]2}'(y1:f),.1v?{'(l2:y6:scheme;y4:file;)]2}'(y1:e),.1v?{'(l2:"
-  "5cc,'1,.4V5]5}.!2&0{%1&0{%1.0,'(y5:const),l2]1},.1,@(y20:*root-name-re"
+  "y6:scheme;y4:eval;)]2}'(y1:o),.1v?{'(l2:y6:scheme;y7:complex;)]2}'(y1:"
-  "gistry*),@(y11:name-lookup)[13}.!3.4d,.5a,,#0.0,.6,.5,.7,.(i10),&5{%2."
+  "h),.1v?{'(l2:y6:scheme;y4:char;)]2}'(y1:l),.1v?{'(l2:y6:scheme;y11:cas"
-  "1u?{${.2,:0^[01},.1,${'(l1:y5:skint;),:1^[01},:3^[23}.1p~?{${.2,:0^[01"
+  "e-lambda;)]2}'(y1:a),.1v?{'(l2:y6:scheme;y3:cxr;)]2}'(y1:b),.1v?{'(l2:"
-  "},.1,${n,.6c,'(y5:skint)c,:1^[01},:3^[23}${${.4,:0^[01},.3,${${.9a,:2^"
+  "y6:scheme;y4:base;)]2}'(y1:x),.1v?{'(l2:y6:scheme;y3:box;)]2}.1I0?{.1,"
-  "[01},:1^[01},:3^[03}.1d,.1,:4^[22}.!0.0^_1[52},@(y10:%25for-each1)[02}",
+  "'(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}",
 
   "C", 0,
   "@(y20:*root-name-registry*),${f,'(l1:y5:skint;),.4,@(y11:name-lookup)["
@@ -1294,7 +1301,12 @@ char *t_code[] = {
   "C", 0,
   "&0{%1n,'(l1:y5:begin;),V12]1},${.2,'(l2:y5:skint;y6:hidden;),@(y20:*ro"
   "ot-name-registry*),@(y11:name-lookup)[03},.0z,'0,@(y22:*hidden-name-re"
-  "gistry*)V4,${'1,.4V4,.3,@(y11:adjoin-eals)[02},.0,'1,.4V5_1_1_1_1_1",
+  "gistry*)V4,${'1,.4V4,.3,@(y11:adjoin-eals)[02},#0${f,'(l1:y5:skint;),@"
+  "(y20:*root-name-registry*),@(y11:name-lookup)[03},.0Y2?{.0z}{f},.0V0?{"
+  "'1,.1V4}{f},,#0.4,.2,&2{%1.0a,:0?{:0,.1A3}{f},.0,.0?{.0}{:1^,.3A3}_1~?"
+  "{:1^,.2,'(y5:const),l2b,.3cc:!1]3}]3}.!0U2,.0V3,${'0,,#0.0,.7,.7,.7,&4"
+  "{%1:0,.1<!?{]1}${.2,:1V4,:2^,@(y10:%25for-each1)[02}'1,.1+,:3^[11}.!0."
+  "0^_1[01}_1_1.4^,'1,.8V5_1_1_1_1_1_1_1_1_1",
 
   "C", 0,
   "${'(i200),@(y18:make-name-registry)[01}@!(y20:*user-name-registry*)",
@@ -1593,7 +1605,7 @@ char *t_code[] = {
   ";s2:-h;s6:--help;f;s17:Display this help;;)@!(y15:*skint-options*)",
 
   "C", 0,
-  "'(s5:0.1.9)@!(y15:*skint-version*)",
+  "'(s5:0.2.9)@!(y15:*skint-version*)",
 
   "P", "skint-main",
   "%0,,,,#0#1#2#3&0{%2${.2,@(y16:read-from-string)[01},${@(y4:list),.3,&1"