ref: 008d2886ab8f7bd5138019ec48b75bbaf88fc769
parent: 886ae13525ade62f45bffd74a207145f0410971e
author: Sigrid Solveig Haflínudóttir <sigrid@ftrv.se>
date: Mon Nov 25 13:28:51 EST 2024
compiler: refactor flisp compiler to handle internal define much more cleanly This is from Julia, 0c4abb27f3d1495e83656c550799e271ba9fd318, by Jeff Bezanson.
--- a/compiler.lsp
+++ b/compiler.lsp
@@ -1,11 +1,14 @@
; -*- scheme -*-
+;; code generation state, constant tables, bytecode encoding
+
(define (make-code-emitter) (vector () (table) 0 +inf.0))
(define (bcode:code b) (aref b 0))
(define (bcode:ctable b) (aref b 1))
(define (bcode:nconst b) (aref b 2))
(define (bcode:cdepth b d) (aset! b 3 (min (aref b 3) d)))
-; get an index for a referenced value in a bytecode object
+
+;; get an index for a referenced value in a bytecode object
(define (bcode:indexfor b v)
(let ((const-to-idx (bcode:ctable b))
(nconst (bcode:nconst b)))
@@ -14,6 +17,7 @@
(begin (put! const-to-idx v nconst)
(prog1 nconst
(aset! b 2 (+ nconst 1)))))))
+
(define (emit e inst . args)
(if (null? args)
(if (and (eq? inst 'car) (pair? (aref e 0))
@@ -74,14 +78,14 @@
(define (make-label e) (gensym))
(define (mark-label e l) (emit e 'label l))
-; convert symbolic bytecode representation to a byte array.
-; labels are fixed-up.
+;; convert symbolic bytecode representation to a byte array.
+;; labels are fixed-up.
(define (encode-byte-code e)
(let* ((cl (reverse! e))
(v (list->vector cl))
- (long? (>= (+ (length v) ; 1 byte for each entry, plus...
- ; at most half the entries in this vector can be
- ; instructions accepting 32-bit arguments
+ (long? (>= (+ (length v) ;; 1 byte for each entry, plus...
+ ;; at most half the entries in this vector can be
+ ;; instructions accepting 32-bit arguments
(* 3 (div0 (length v) 2)))
65536)))
(let ((n (length v))
@@ -164,6 +168,10 @@
(bcode:ctable e))
cvec))
+;; variables
+
+(define (quoted? e) (eq? (car e) 'quote))
+
(define (index-of item lst start)
(cond ((null? lst) #f)
((eq? item (car lst)) start)
@@ -206,6 +214,8 @@
(emit g 'loadv (top-level-value s))
(emit g (aref Is 2) s))))))
+;; control flow
+
(define (compile-if g env tail? x)
(let ((elsel (make-label g))
(endl (make-label g))
@@ -292,6 +302,8 @@
(define (compile-or g env tail? forms)
(compile-short-circuit g env tail? forms #f 'brt))
+;; calls
+
(define (compile-arglist g env lst)
(for-each (λ (a)
(compile-in g env #f a))
@@ -379,18 +391,7 @@
(compile-builtin-call g env tail? x head b nargs)
(emit g (if tail? 'tcall 'call) nargs))))))))))
-(define (expand-define x)
- (let ((form (cadr x))
- (body (if (pair? (cddr x))
- (cddr x)
- (if (symbol? (cadr x))
- `(,(void))
- (error "compile error: invalid syntax "
- (print-to-string x))))))
- (if (symbol? form)
- `(set! ,form ,(car body))
- `(set! ,(car form)
- (λ ,(cdr form) ,@body . ,(car form))))))
+;; lambda, main compilation loop
(define (fits-i8 x) (and (fixnum? x) (>= x -128) (<= x 127)))
@@ -427,12 +428,10 @@
(for (compile-for g env (cadr x) (caddr x) (cadddr x)))
(return (compile-in g env #t (cadr x))
(emit g 'ret))
- (set! (compile-in g env #f (caddr x))
- (or (symbol? (cadr x))
- (error "set!: second argument must be a symbol"))
+ (set! (unless (symbol? (cadr x))
+ (error "set!: second argument must be a symbol"))
+ (compile-in g env #f (caddr x))
(compile-sym g env (cadr x) #(seta setc setg)))
- (define (compile-in g env tail?
- (expand-define x)))
(trycatch (compile-in g env #f `(λ () ,(cadr x)))
(unless (1arg-lambda? (caddr x))
(error "trycatch: second form must be a 1-argument lambda"))
@@ -440,28 +439,8 @@
(emit g 'trycatch))
(else (compile-app g env tail? x))))))
-(define (compile-f env f)
- (receive (ff ignore)
- (compile-f- env f)
- ff))
+;; optional and keyword args
-(define get-defined-vars
- (letrec ((get-defined-vars-
- (λ (expr)
- (cond ((atom? expr) ())
- ((and (eq? (car expr) 'define)
- (pair? (cdr expr)))
- (or (and (symbol? (cadr expr))
- (list (cadr expr)))
- (and (pair? (cadr expr))
- (symbol? (caadr expr))
- (list (caadr expr)))
- ()))
- ((eq? (car expr) 'begin)
- (apply nconc (map get-defined-vars- (cdr expr))))
- (else ())))))
- (λ (expr) (delete-duplicates (get-defined-vars- expr)))))
-
(define (keyword-arg? x) (and (pair? x) (keyword? (car x))))
(define (keyword->symbol k)
(if (keyword? k)
@@ -512,82 +491,117 @@
(mark-label g nxt)
(emit-optional-arg-inits g env (cdr opta) vars (+ i 1)))))
-#;(define (free-vars e)
- (cond ((symbol? e) (list e))
- ((or (atom? e) (eq? (car e) 'quote)) ())
- ((or (eq? (car e) 'λ) (eq? (car e) 'lambda))
- (diff (free-vars (cddr e))
- (nconc (get-defined-vars (cons 'begin (cddr e)))
- (lambda-arg-names (cadr e)))))
- (else (delete-duplicates (apply nconc (map free-vars (cdr e)))))))
+;; define
-(define compile-f-
- (let ((*defines-processed-token* (gensym)))
- ; to eval a top-level expression we need to avoid internal define
- (set-top-level-value!
- 'compile-thunk
- (λ (expr)
- (compile `(λ () ,expr . ,*defines-processed-token*))))
+(define (expand-define x)
+ ;; expand a single `define` expression to `set!`
+ (let ((form (cadr x))
+ (body (if (pair? (cddr x))
+ (cddr x)
+ (if (symbol? (cadr x))
+ `(,(void))
+ (error "compile error: invalid syntax "
+ (print-to-string x))))))
+ (if (symbol? form)
+ `(set! ,form ,(car body))
+ `(set! ,(car form)
+ (λ ,(cdr form) ,@body . ,(car form))))))
- (λ (env f)
- ; convert lambda to one body expression and process internal defines
- (define (lambda-body e)
- (let ((B (if (pair? (cddr e))
- (if (pair? (cdddr e))
- (cons 'begin (cddr e))
- (caddr e))
- (void))))
- (let ((V (get-defined-vars B)))
- (if (null? V)
- B
- (cons (list* 'λ V B *defines-processed-token*)
- (map (λ (x) (void)) V))))))
- (define (lam:body f)
- (if (eq? (lastcdr f) *defines-processed-token*)
- (caddr f)
- (lambda-body f)))
+(define get-defined-vars
+ (letrec ((get-defined-vars-
+ (λ (expr)
+ (cond ((atom? expr) ())
+ ((and (eq? (car expr) 'define)
+ (pair? (cdr expr)))
+ (or (and (symbol? (cadr expr))
+ (list (cadr expr)))
+ (and (pair? (cadr expr))
+ (symbol? (caadr expr))
+ (list (caadr expr)))
+ ()))
+ ((eq? (car expr) 'begin)
+ (apply nconc (map get-defined-vars- (cdr expr))))
+ (else ())))))
+ (λ (expr) (delete-duplicates (get-defined-vars- expr)))))
- (let ((g (make-code-emitter))
- (args (cadr f))
- (atail (lastcdr (cadr f)))
- (vars (lambda-vars (cadr f)))
- (opta (filter pair? (cadr f)))
- (name (if (eq? (lastcdr f) *defines-processed-token*)
- 'λ
- (lastcdr f))))
- (let* ((nargs (if (atom? args) 0 (length args)))
- (nreq (- nargs (length opta)))
- (kwa (filter keyword-arg? opta)))
+(define (lower-define e)
+ ;; convert lambda to one body expression and process internal defines
+ (define (λ-body e)
+ (let ((B (if (pair? (cddr e))
+ (if (pair? (cdddr e))
+ (cons 'begin (cddr e))
+ (caddr e))
+ (void))))
+ (let ((V (get-defined-vars B))
+ (new-B (lower-define B)))
+ (if (null? V)
+ new-B
+ (cons `(λ ,V ,new-B)
+ (map (λ (x) (void)) V))))))
+ (cond ((or (atom? e) (quoted? e))
+ e)
+ ((eq? (car e) 'define)
+ (lower-define (expand-define e)))
+ ((is-lambda? (car e))
+ `(λ ,(cadr e) ,(λ-body e) . ,(lastcdr e)))
+ (else
+ (map lower-define e))))
- ; emit argument checking prologue
- (if (not (null? opta))
- (begin
- (if (null? kwa)
- (emit g 'optargs nreq
- (if (null? atail) nargs (- nargs)))
- (begin
- (bcode:indexfor g (make-perfect-hash-table
- (map cons
- (map car kwa)
- (iota (length kwa)))))
- (emit g 'keyargs nreq (length kwa)
- (if (null? atail) nargs (- nargs)))))
- (emit-optional-arg-inits g env opta vars nreq)))
+;; main entry points
- (cond ((> nargs 255) (emit g (if (null? atail)
- 'largc 'lvargc)
- nargs))
- ((not (null? atail)) (emit g 'vargc nargs))
- ((null? opta) (emit g 'argc nargs)))
+(define (compile f) (compile-f () (lower-define f)))
- ; compile body and return
- (compile-in g (cons vars env) #t (lam:body f))
- (emit g 'ret)
- (values (function (encode-byte-code (bcode:code g))
- (const-to-idx-vec g) name)
- (aref g 3)))))))
+(define (compile-thunk expr)
+ ;; to eval a top-level expression we need to avoid internal define
+ (compile-f () `(λ () ,(lower-define expr))))
-(define (compile f) (compile-f () f))
+(define (compile-f env f)
+ (receive (ff ignore)
+ (compile-f- env f)
+ ff))
+
+(define (compile-f- env f)
+ ;; compile lambda expression, assuming defines already lowered
+ (let ((g (make-code-emitter))
+ (args (cadr f))
+ (atail (lastcdr (cadr f)))
+ (vars (lambda-vars (cadr f)))
+ (opta (filter pair? (cadr f)))
+ (last (lastcdr f)))
+ (let* ((name (if (null? last) 'λ last))
+ (nargs (if (atom? args) 0 (length args)))
+ (nreq (- nargs (length opta)))
+ (kwa (filter keyword-arg? opta)))
+
+ ;; emit argument checking prologue
+ (if (not (null? opta))
+ (begin
+ (if (null? kwa)
+ (emit g 'optargs nreq
+ (if (null? atail) nargs (- nargs)))
+ (begin
+ (bcode:indexfor g (make-perfect-hash-table
+ (map cons
+ (map car kwa)
+ (iota (length kwa)))))
+ (emit g 'keyargs nreq (length kwa)
+ (if (null? atail) nargs (- nargs)))))
+ (emit-optional-arg-inits g env opta vars nreq)))
+
+ (cond ((> nargs 255) (emit g (if (null? atail)
+ 'largc 'lvargc)
+ nargs))
+ ((not (null? atail)) (emit g 'vargc nargs))
+ ((null? opta) (emit g 'argc nargs)))
+
+ ;; compile body and return
+ (compile-in g (cons vars env) #t (caddr f))
+ (emit g 'ret)
+ (values (function (encode-byte-code (bcode:code g))
+ (const-to-idx-vec g) name)
+ (aref g 3)))))
+
+;; disassembler
(define (ref-int32-LE a i)
(int32 (+ (ash (aref a (+ i 0)) 0)
--- a/flisp.boot
+++ b/flisp.boot
@@ -49,9 +49,9 @@
#fn("<000n1200910e2e12122e12324>9115252e3:" #(let #fn(nconc) cond #fn(map) #fn("8000n1910A0<520=P:" #()))) #fn(gensym))))) receive #fn("@000|22021q1e32221e10e123825153e3:" #(call-with-values- λ #fn(nconc) #fn(copy-list))) unwind-protect #fn("8000n220>2150215062:" #(#fn("@000n220121qFe3e2e12223A210e1241e1250e2e3e3e31e1e3e3:" #(let- λ prog1 trycatch begin raise)) #fn(gensym))) dotimes #fn(";000|120>0<0T62:" #(#fn("=000n220E211Ke32223e10e1e124F5153e4:" #(for- - #fn(nconc) λ #fn(copy-list))))) throw #fn(":000n220212223e201e4e2:" #(raise+ λ #fn(nconc) #fn(copy-list))) dotimes #fn(";000|120>0<0T62:" #(#fn("=000n220E211Ke32223e10e1e124F5153e4:" #(for+ - #fn(nconc) λ #fn(copy-list))))) unwind-protect #fn("8000n220>2150215062:" #(#fn("@000n220121qFe3e2e12223A210e1241e1250e2e3e3e31e1e3e3:" #(let+ λ prog1 trycatch begin raise)) #fn(gensym))) throw #fn(":000n220212223e201e4e2:" #(raiselist quote thrown-value)))
1+ #fn("7000n10KM:" #() 1+) 1- #fn("7000n10K\x80:" #() 1-) 1arg-lambda? #fn("8000n10B;3U04700<51;3J040=B;3B040TB;3:04710TK62:" #(is-lambda?@@ -58,7 +58,7 @@
length=) 1arg-lambda?)
<= #fn("7000n210L;IB0470051;380470151S:" #(nan?) <=) > #fn("7000n210L:" #() >) >= #fn("7000n201L;IB0470051;380470151S:" #(nan?) >=)- Instructions #table(call.l 83 largc 81 trycatch 77 loadg.l 68 cadr 36 setg 71 argc 62 load0 21 vector? 45 fixnum? 41 loada0 0 div0 59 keyargs 91 call 5 loada.l 69 brt.l 50 pair? 18 sub2 80 add2 29 loadc.l 70 loadc 9 builtin? 43 set-car! 47 brt 25 loadi8 66 tapply 79 ret 10 loada1 1 boolean? 39 cdr 13 atom? 24 brne.l 85 / 58 loadf 31 equal? 52 apply 54 jmp.l 48 loadt 20 dup 11 = 60 not 35 null? 38 set-cdr! 30 loadc01 22 eq? 33 * 57 load1 27 dummy_t 93 bound? 42 brf 3 function? 44 setc.l 75 < 28 brnn.l 86 for 78 loadv 2 jmp 16 lvargc 82 dummy_eof 95 + 55 dummy_f 92 setc 74 brne 19 compare 61 neg 37 loadv.l 67 brn 87 vargc 76 number? 40 brbound 90 vector 63 setg.l 72 aref 23 brf.l 49 symbol? 34 aset! 64 car 12 cons 32 tcall.l 84 - 56 brn.l 88 optargs 89 nop 46 closure 14 pop 4 eqv? 51 list 53 seta 15 seta.l 73 brnn 26 loadnil 65 loadc00 17 loadg 7 loada 8 dummy_nil 94 tcall 6)
+ Instructions #table(call.l 83 trycatch 77 largc 81 loadg.l 68 cadr 36 argc 62 setg 71 load0 21 vector? 45 fixnum? 41 loada0 0 div0 59 keyargs 91 call 5 loada.l 69 brt.l 50 pair? 18 sub2 80 add2 29 loadc.l 70 loadc 9 builtin? 43 set-car! 47 brt 25 ret 10 loadi8 66 tapply 79 loada1 1 boolean? 39 atom? 24 cdr 13 brne.l 85 / 58 loadf 31 equal? 52 apply 54 dup 11 loadt 20 jmp.l 48 null? 38 not 35 = 60 set-cdr! 30 loadc01 22 eq? 33 * 57 load1 27 dummy_t 93 bound? 42 brf 3 function? 44 setc.l 75 < 28 brnn.l 86 jmp 16 loadv 2 for 78 lvargc 82 dummy_eof 95 + 55 dummy_f 92 setc 74 brne 19 compare 61 neg 37 loadv.l 67 number? 40 vargc 76 brn 87 brbound 90 vector 63 setg.l 72 brf.l 49 aref 23 symbol? 34 aset! 64 car 12 cons 32 tcall.l 84 - 56 brn.l 88 optargs 89 nop 46 closure 14 pop 4 eqv? 51 list 53 seta 15 seta.l 73 brnn 26 loadnil 65 loadg 7 loadc00 17 loada 8 dummy_nil 94 tcall 6)
__init_globals #fn("6000n020w1422w3474w5476w7478w9:" #("/"*directory-separator*
"\n"
@@ -82,7 +82,7 @@
__start #fn("8000n1705040=B3D00=w14Ow24730T51@C00w14Dw24745047550426E61:" #(__init_globals*argv* *interactive* __script __rcscript repl #fn(exit)) __start)
abs #fn("7000n10EL3500U:0:" #() abs) any- #fn("8000n21B;3D0401<51;I:047001=62:" #(any) any) arg-counts #table(bound? 1 function? 1 symbol? 1 aset! 3 car 1 cons 2 cadr 1 < 2 vector? 1 boolean? 1 fixnum? 1 atom? 1 cdr 1 div0 2 equal? 2 eqv? 2 pair? 1 compare 2 null? 1 = 2 number? 1 not 1 set-cdr! 2 eq? 2 builtin? 1 set-car! 2 aref 2)+ #fn("8000n21B;3D0401<51;I:047001=62:" #(any) any) arg-counts #table(bound? 1 function? 1 symbol? 1 aset! 3 car 1 cons 2 < 2 cadr 1 vector? 1 fixnum? 1 boolean? 1 atom? 1 cdr 1 div0 2 equal? 2 eqv? 2 pair? 1 compare 2 null? 1 not 1 number? 1 = 2 set-cdr! 2 eq? 2 builtin? 1 set-car! 2 aref 2) argc-error #fn("<000n2702102211Kl37023@402465:" #(error "compile error: "" expects " " argument."
" arguments.") argc-error)
@@ -118,7 +118,7 @@
cadar #fn("6000n10<T:" #() cadar) caddar #fn("6000n10<=T:" #() caddar) cadddr #fn("6000n10==T:" #() cadddr) caddr #fn("6000n10=T:" #() caddr) call-with-values- #fn("7000n220>05061:" #(#fn("7000n10B;39049100<Q380F0=\x7f2:F061:" #())) #2=#((*values*)+ #fn("7000n220>05061:" #(#fn("7000n10B;39049100<Q380F0=\x7f2:F061:" #())) #1=#((*values*)()))
cdaaar #fn("6000n10<<<=:" #() cdaaar) cdaadr #fn("6000n10T<=:" #() cdaadr) cdaar #fn("6000n10<<=:" #() cdaar)@@ -132,8 +132,8 @@
#fn("6000n10==:" #() cddr) char? #fn("7000n12005121Q:" #(#fn(typeof)rune) char?)
closure? #fn("7000n10\\;36040[S:" #() closure?) compile- #fn("8000n170q062:" #(compile-f) compile) compile-and #fn("<000n470018283D2166:" #(compile-short-circuit- brf) compile-and)
+ #fn("9000n170q7105162:" #(compile-f lower-define) compile)+ compile-and #fn("<000n470018283D2166:" #(compile-short-circuit brf) compile-and) compile-app #fn("7000n420>83<61:" #(#fn("9000n120>0R;3V04710F52S;3J040Z;3C0422051;390423051[3:023051@30061:" #(#fn(":000n170913=21523S072910911O054423>74910911913=5361:25>0[;38047605161:" #(length> 255 compile-in #fn(":000n17092092237021@4022063:" #(emit tcall.l call.l)) compile-arglist #fn(";000n1A20Q;3X0471A92152S;3J0422205123d;3<0474923r2523L075920921O923T544769202062:0IA075920921OA54@30D427>78920921923=5361:" #(cadr@@ -150,16 +150,13 @@
apply tapply)))) #fn(get) arg-counts) compile-builtin-call)
compile-f #fn("8000n27021>2262:" #(call-with-values #fn("8000n070AF62:" #(compile-f-)) #fn("6000n20:" #())) compile-f)- compile-f- #fn("8000n220>DD62:" #(#fn(">000n220>?0421>?1422>7350FT74FT5175FT517627FT5274F51910C7028@7074F5166:" #(#fn("9000n120>71051B3N072051B3=02371051P@7074051@60755061:" #(#fn("8000n120>7105161:" #(#fn(":000n10J40A:20210A940542223052P:" #(#fn(list*)- λ #fn(map) #fn("6000n17060:" #(void)))) get-defined-vars)) cddr cdddr begin- caddr void) lambda-body) #fn("7000n170051920C8071061:A061:" #(lastcdr caddr) lam:body)- #fn("9000n620>1H360E@702115161:" #(#fn("9000n120>02190451\x8061:" #(#fn("9000n120>71729145261:" #(#fn("C000n1924\x87\xa900JO07092021A922J80910@60910U54@s072920732425242605277280515153515247092029A28051922J80910@60910U5547:920940924923A55@30D47;9102<523L070920922J702=@402>91053@]0922\x87A0709202?91053@H0924JA0709202@91053@30O47A920923940PD93194151544709202B5247C2D7E7F92051517G9205192553920r3G62:" #(emit+ compile-f- #fn("=000n220>71501T721T51731T5174251T527215166:" #(#fn("8000n620>85J7021@408561:" #(#fn("9000n120>FH360E@7021F5161:" #(#fn("9000n120>02191451\x8061:" #(#fn("9000n120>71729245261:" #(#fn("C000n1934\x87\xa900JO07093021A932J80910@60910U54@s072930732425242605277280515153515247093029A28051932J80910@60910U5547:930940934933A55@30D47;9102<523L070930932J702=@402>91053@]0932\x87A0709302?91053@H0934JA0709302@91053@30O47A930933940PD7B94151544709302C5247D2E7F7G93051517H9305192053930r3G62:" #(emitoptargs bcode:indexfor make-perfect-hash-table
#fn(map) #.cons #.car iota #fn(length) keyargs emit-optional-arg-inits > 255
- largc lvargc vargc argc compile-in ret values #fn(function) encode-byte-code
- bcode:code const-to-idx-vec)) filter keyword-arg?))
- #fn(length))) #fn(length))) make-code-emitter lastcdr lambda-vars filter #.pair?
- λ))) #0=#(#:g728 ()))
+ largc lvargc vargc argc compile-in caddr ret values #fn(function)
+ encode-byte-code bcode:code const-to-idx-vec)) filter keyword-arg?))
+ #fn(length))) #fn(length))) λ)) make-code-emitter lastcdr lambda-vars filter
+ #.pair?) compile-f-)
compile-for #fn(":000n57084513X07101O825447101O835447101O845447202362:742561:" #(1arg-lambda?compile-in emit for error "for: third form must be a 1-argument lambda") compile-for)
compile-if #fn("<000n420>710517105183T728351738351B3;0748351@60755065:" #(#fn(";000n582DC>070AF9028364:82OC>070AF9028464:70AFO8254471A22053470AF902835449023<071A2352@:071A24153475A052470AF9028454475A162:" #(compile-in@@ -166,7 +163,7 @@
emit brf ret jmp mark-label)) make-label caddr cdddr cadddr void) compile-if)
compile-in #fn(";000n483R3=07001832164:83H3\xaf083EC:07202362:83KC:07202462:83DC:07202562:83OC:07202662:83qC:07202762:7883513<0720298363:2:83513C07;01822<2=51e164:7202>8363:83<RS;ID0483<Z;I;047?83<1523=07@01828364:2A>83<61:" #(compile-sym#(loada loadc loadg) emit load0 load1 loadt loadf loadnil fits-i8 loadi8 #fn(eof-object?)
- compile-in #fn(top-level-value) eof-object loadv in-env? compile-app #fn("<000n1020CW071903T513@072AF902903T64:73A24903T63:025C?076AF90290364:027C@078AF902903=64:029C<07:AF90363:02;C=07<2=>2>>62:02?C@07@AF902903=64:02AC@07BAF902903=64:02CCG07DAF903T277E90351P64:02FCK07GAF903T7H903517I9035165:02JCF072AFD903T54473A2K62:02LC_072AFO7H90351544903TR;I9047M2N5147OAF903T2P64:02QCC072AF9027R9035164:02SCs072AFO2;q903Te35447T7H9035151360O@807M2U51472AFO7H9035154473A2S62:7VAF90290364:" #(quote+ compile-in #fn(top-level-value) eof-object loadv in-env? compile-app #fn("=000n1020CW071903T513@072AF902903T64:73A24903T63:025C?076AF90290364:027C@078AF902903=64:029C<07:AF90363:02;C=07<2=>2>>62:02?C@07@AF902903=64:02AC@07BAF902903=64:02CCG07DAF903T277E90351P64:02FCK07GAF903T7H903517I9035165:02JCF072AFD903T54473A2K62:02LCa0903TR360O@807M2N51472AFO7H903515447OAF903T2P64:02QCs072AFO2;q903Te35447R7H9035151360O@807M2S51472AFO7H9035154473A2Q62:7TAF90290364:" #(quoteself-evaluating? compile-in emit loadv if compile-if begin compile-begin
prog1 compile-prog1 λ call-with-values #fn("8000n07091191362:" #(compile-f-)) #fn("9000n27091021053472910152417391151L3<0709102462:D:" #(emit loadv@@ -174,7 +171,7 @@
closure)) and
compile-and or compile-or while compile-while cddr for compile-for caddr
cadddr return ret set! error "set!: second argument must be a symbol"
- compile-sym #(seta setc setg) define expand-define trycatch 1arg-lambda? "trycatch: second form must be a 1-argument lambda"
+ compile-sym #(seta setc setg) trycatch 1arg-lambda? "trycatch: second form must be a 1-argument lambda"
compile-app))) compile-in)
compile-or #fn("<000n470018283O2166:" #(compile-short-circuit brt) compile-or) compile-prog1 #fn(";000n37001O82T544718251B3H07201O7182515447302462:D:" #(compile-in@@ -185,8 +182,8 @@
compile-sym #fn(";000n420>71821ED5461:" #(#fn(":000n10X3>070A903EG063:0<X3R070A903KG0<0=54471A72F=51K0<h362:2390251;3>04742590251513A070A26259025163:70A903r2G90263:" #(emitbcode:cdepth nnn #fn(constant?) printable? #fn(top-level-value) loadv))
lookup-sym) compile-sym)
- compile-thunk #fn(";000n1702122e1qe10e1A5461:" #(compile #fn(nconc)- λ) #0#)
+ compile-thunk #fn(";000n170q21q72051e362:" #(compile-f λ+ lower-define) compile-thunk)
compile-while #fn("9000n420>710517105162:" #(#fn(":000n270AFO715054472A052470AFO90254473A24153473A2552470AFO90354473A26053472A162:" #(compile-invoid mark-label emit brf pop jmp)) make-label) compile-while)
const-to-idx-vec #fn("9000n120>21720515161:" #(#fn("9000n17021>72A515240:" #(table-foreach@@ -272,8 +269,8 @@
foldl #fn(":000n382J401:700082<15282=63:" #(foldl) foldl) foldr #fn(";000n382J401:082<700182=5362:" #(foldr) foldr) for-each #fn(";000|220>D61:" #(#fn(":000n120>?04902JJ0DFB3A04AF<514F=z01@\x1e/@;00AF902P524D:" #(#fn(":000n21<B3I002021152f24A0202215262:D:" #(#fn(map)#.car #.cdr) for-each-n)))) for-each)
- get-defined-vars #fn("8000n170A05161:" #(delete-duplicates) #1=#(#fn("9000n10H340q:0<20Q;36040=B3d00TR;37040Te1;IS040TB;3E0471051R;3:0471051e1;I404q:0<22C>02324A0=52\x7f2:q:" #(define- caadr begin #fn(nconc) #fn(map)) #1#) ()))
+ get-defined-vars #fn("8000n170A05161:" #(delete-duplicates) #0=#(#fn("9000n10H340q:0<20Q;36040=B3d00TR;37040Te1;IS040TB;3E0471051R;3:0471051e1;I404q:0<22C>02324A0=52\x7f2:q:" #(define+ caadr begin #fn(nconc) #fn(map)) #0#) ()))
hex5 #fn("9000n170210r@52r52263:" #(string-lpad #fn(number->string)#\0) hex5)
identity #fn("6000n10:" #() identity) in-env?@@ -290,8 +287,6 @@
#fn(symbol) #fn(";000n1200E71220515163:" #(#fn(string-sub) 1- #fn(string-length)))#fn(string)) keyword->symbol)
keyword-arg? #fn("7000n10B;3904200<61:" #(#fn(keyword?)) keyword-arg?)- lambda-arg-names #fn("9000n170217205162:" #(map! #fn("7000n10B390700<61:0:" #(keyword->symbol))- to-proper) lambda-arg-names)
lambda-vars #fn("7000n120>D61:" #(#fn(":000n120>?040AAOO544212273A5162:" #(#fn(";000n40V;I5040R340D:0B;36040<R3S082;I504833<0702112263:A0=1828364:0B;36040<B3\x870730<r252;390474051R360O@=070250<2615442774051513<0A0=182D64:833<0702112863:A0=1D8364:0B3>070290<26164:01C:07021162:7029026164:" #(error"compile error: invalid argument list "
". optional arguments must come after required." length= caar "compile error: invalid optional argument "
@@ -315,6 +310,10 @@
#fn("7000n41J5020:21>1<61:" #((global) #fn(":000n120>71A0E5361:" #(#fn(";000n103@09133400:9120P:70910911=913;I504AV380912@70912KMO64:" #(lookup-sym))index-of))) lookup-sym)
+ lower-define #fn("7000n120>D61:" #(#fn(";000n120?04AH;I80471A51340A:A<22C<07374A5161:75A<513J02627e1ATe10A51e178A5164:2973A62:" #(#fn("9000n12071051B3N072051B3=02371051P@7074051@60755061:" #(#fn("9000n120710517205162:" #(#fn("9000n20J401:2001e32122052P:" #(λ+ #fn(map) #fn("6000n17060:" #(void)))) get-defined-vars lower-define)) cddr+ cdddr begin caddr void) λ-body) quoted? define lower-define expand-define
+ is-lambda? #fn(nconc) λ lastcdr #fn(map)))) lower-define)
macrocall? #fn("7000n10<R;3904700<61:" #(symbol-syntax) macrocall?) macroexpand-1 #fn("8000n10H3400:20>7105161:" #(#fn("7000n103800A=\x7f2:A:" #())macrocall?) macroexpand-1)
@@ -384,9 +383,9 @@
printable? #fn("7000n120051;I80421051S:" #(#fn(iostream?)#fn(eof-object?)) printable?)
quote-value #fn("7000n1700513400:210e2:" #(self-evaluating? quote) quote-value)- random #fn("8000n1200513<0712250062:23500i2:" #(#fn(integer?) mod- #fn(rand)
- #fn(rand-double)) random)
+ quoted? #fn("7000n10<20Q:" #(quote) quoted?) random+ #fn("8000n1200513<0712250062:23500i2:" #(#fn(integer?) mod #fn(rand)+ #fn(rand-double)) random)
read-all #fn("8000n17021062:" #(read-all-of #fn(read)) read-all) read-all-of #fn("9000n220>D51q015162:" #(#fn("6000n120>?040:" #(#fn("9000n2209115138071061:A10P9109115162:" #(#fn(io-eof?)reverse!))))) read-all-of)
@@ -461,7 +460,7 @@
untrace #fn("8000n120>2105161:" #(#fn("9000n1700513@021A22051r2G62:D:" #(traced?#fn(set-top-level-value!) #fn(function:vals)))
#fn(top-level-value)) untrace)
- values #fn("9000|00B;36040=V3500<:A0P:" #() #2#) vector->list+ values #fn("9000|00B;36040=V3500<:A0P:" #() #1#) vector->list #fn("8000n120>21051q62:" #(#fn(":000n2K020>~41:" #(#fn("8000n1910A0\x80GFPz01:" #())))#fn(length)) vector->list)
vector-map #fn("8000n220>2115161:" #(#fn("8000n120>2105161:" #(#fn(":000n1EAK\x8020>~40:" #(#fn(":000n1A09209210G51p:" #())))--- a/mkboot0.lsp
+++ b/mkboot0.lsp
@@ -16,16 +16,19 @@
(set! update-compiler (λ () ()))))))
(define (compile-file inf)
- (update-compiler)
(let ((in (file inf :read)))
(let next ((E (read in)))
(if (not (io-eof? in))
- (begin
- (print (compile-thunk (expand E)))
- (princ "\n")
- (next (read in)))))
+ (begin
+ (print (compile-thunk (expand E)))
+ (princ "\n")
+ (next (read in)))))
(io-close in)))
-(for-each (λ (file)
- (compile-file file))
- (cdr *argv*))
+(define (do-boot0)
+ (for-each (λ (file)
+ (compile-file file))
+ (cdr *argv*)))
+
+(update-compiler)
+(do-boot0)