Miroirs/skint
1
0
Fork 0
mirror of https://github.com/false-schemers/skint.git synced 2024-12-26 21:58:51 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

service -c compiler reborn as ccomp.ssc!

Browse source
This commit is contained in:
ESL 2024-07-21 03:55:04 -04:00
parent 2f92eac26e
commit a511e77df9
4 changed files with 269 additions and 39 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

203
src/ccomp.ssc Normal file
View file

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

6
src/s.scm
View file

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

33
src/t.scm
View file

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

66
t.c
View file

@ -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<!?{]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"