diff --git a/src/ccomp.ssc b/src/ccomp.ssc new file mode 100644 index 0000000..7a70e58 --- /dev/null +++ b/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)) diff --git a/src/s.scm b/src/s.scm index e2acc61..5bc4f3b 100644 --- a/src/s.scm +++ b/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))) diff --git a/src/t.scm b/src/t.scm index db47a93..566778e 100644 --- a/src/t.scm +++ b/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) - (run-script . hidden) (get-next-command-line-option . hidden) (print-command-line-options . hidden) - (xform . hidden) (compile-and-run-core-expr . hidden) (compile-to-thunk-code . hidden) - (deserialize-code . hidden) (closure . hidden) (repl-environment . hidden) - (*skint-options* . hidden) + (port-fold-case?) (set-port-fold-case!) (rename-file) (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) + (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))]) - ;(vector-set! *hidden-name-registry* 0 combeal) + [combeal (adjoin-eals eal (library-exports lib))] + [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 diff --git a/t.c b/t.c index f0a6dfe..600b5af 100644 --- a/t.c +++ b/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" - "28:get-next-command-line-option;y6:hidden;;py26:print-command-line-opt" - "ions;y6:hidden;;py5:xform;y6:hidden;;py25:compile-and-run-core-expr;y6" - ":hidden;;py21:compile-to-thunk-code;y6:hidden;;py16:deserialize-code;y" - "6:hidden;;py7:closure;y6:hidden;;py16:repl-environment;y6:hidden;;py15" - ":*skint-options*;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:rea" - "d;)]2}'(y1:v),.1v?{'(l2:y6:scheme;y4:r5rs;)]2}'(y1:u),.1v?{'(l2:y6:sch" - "eme;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: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: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:scheme;y3:box;)]2}.1I0?{.1,'(y4:srfi),l2]2}.1,l1]2}.!" - "0&0{%1${&0{%1n,'(l1: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-re" - "gistry*),@(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[52},@(y10:%25for-each1)[02}", + "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}", "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