ref: fef346ae1ec13ea7dae5a8b497b6c54e2fa17691
parent: 30337092f06fce2eba1ce5087bb21e8f35391c81
author: Sigrid Solveig Haflínudóttir <sigrid@ftrv.se>
date: Tue Jan 28 10:32:52 EST 2025
rearrange files
--- a/.gitignore
+++ b/.gitignore
@@ -7,5 +7,5 @@
docs_ops.lsp
builtin_fns.h
*.core
-plan9/flisp.boot.s
+flisp.boot.s
cross/*-toolchain
--- a/README.md
+++ b/README.md
@@ -59,7 +59,7 @@
Now build femtolisp:
cd femtolisp
- ln -s ../retro68-build/toolchain cross/macos-toolchain
+ export PATH="$PATH:$(pwd)/../retro68-build/toolchain/bin"
# for PowerPC:
meson setup build . -Dbuildtype=minsize --cross-file cross/powerpc-apple.txt
# for m68k:
@@ -75,7 +75,7 @@
Build DJGPP cross-compiler, then:
- ln -s djgpp-toolchain-prefix cross/djgpp-toolchain
+ export PATH=$PATH:path-to-djgpp-toolchain/bin
meson setup build . -Dbuildtype=minsize --cross-file cross/djgpp.txt
ninja -C build
--- a/bitvector.c
+++ /dev/null
@@ -1,16 +1,0 @@
-#include "flisp.h"
-
-uint32_t *
-bitvector_resize(uint32_t *b, uint64_t oldsz, uint64_t newsz, int initzero)
-{- uint32_t *p;
- size_t sz = ((newsz+31)>>5) * sizeof(uint32_t);
- p = MEM_REALLOC(b, sz);
- if(p == nil)
- return nil;
- if(initzero && newsz>oldsz){- size_t osz = ((oldsz+31)>>5) * sizeof(uint32_t);
- memset(&p[osz/sizeof(uint32_t)], 0, sz-osz);
- }
- return p;
-}
--- a/bitvector.h
+++ /dev/null
@@ -1,11 +1,0 @@
-uint32_t *bitvector_resize(uint32_t *b, uint64_t oldsz, uint64_t newsz, int initzero);
-
-#define bitvector_new(n, initzero) bitvector_resize(nil, 0, (n), (initzero))
-#define bitvector_nwords(nbits) (((uint64_t)(nbits)+31)>>5)
-#define bitvector_get(b, n) (b[(n)>>5] & (1U<<((n)&31)))
-#define bitvector_set(b, n) do{ \- b[(n)>>5] |= 1U<<((n)&31); \
- }while(0)
-#define bitvector_reset(b, n) do{ \- b[(n)>>5] &= ~(1U<<((n)&31)); \
- }while(0)
--- /dev/null
+++ b/boot/flisp.boot
@@ -1,0 +1,448 @@
+(*builtins* #(0 0 0 0 0 0 0 0 0 0 0 0 #fn("5000n10<:" #())+ #fn("5000n10=:" #()) 0 0 0 0 #fn("5000n10B:" #()) 0 0 0 0 0 #fn("5000n10H:" #()) 0 0+ 0 #fn("8000z0700}2:" #(<)) 0 #fn("6000n201N:" #()) 0 #fn("6000n201P:" #())+ #fn("6000n201Q:" #()) #fn("5000n10R:" #())+ #fn("5000n10S:" #()) #fn("5000n10T:" #()) 0 #fn("5000n10V:" #())+ #fn("5000n10W:" #()) #fn("5000n10X:" #())+ #fn("5000n10Y:" #()) #fn("5000n10Z:" #())+ #fn("5000n10[:" #()) #fn("5000n10\\:" #())+ #fn("5000n10]:" #()) 0 #fn("6000n201_:" #()) 0 0 0 #fn("6000n201c:" #())+ #fn("6000n201d:" #()) #fn("7000z00:" #())+ #fn("8000z0700}2:" #(apply)) #fn("8000z0700}2:" #(+))+ #fn("8000z0700}2:" #(-)) #fn("8000z0700}2:" #(*))+ #fn("8000z0700}2:" #(/)) #fn("8000z0700}2:" #(div0))+ #fn("8000z0700}2:" #(=)) #fn("6000n201m:" #()) 0 #fn("8000z0700}2:" #(vector))+ #fn("8000z0700}2:" #(aset!)) 0 0 0 0 0 0 0 0 0 0 0 #fn("9000n3012082>1|:" #(#fn("6000n1A061:" #())))+ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 #fn("8000z0700}2:" #(aref)) 0 #fn("5000n10\x8e:" #())+ 0)
+ *properties* #table(*funvars* #table(lz-unpack ((data :to destination)
+ (data :size decompressed-bytes)) void? ((x)) >= ((a . rest)) help ((term)) length= ((lst
+ n)) = ((a . rest)) <= ((a . rest)) car ((lst)) /= ((a . rest)) lz-pack ((data (level 0))) void (rest) nan? ((x)) *prompt* (#f) cons? ((value)) vm-stats (nil) * ((number…)) > ((a . rest)) cdr ((lst)) + ((number…))) *doc* #table(> "Return #t if the arguments are in strictly decreasing order (previous\none is greater than the next one)." lz-unpack "Return decompressed data previously compressed using lz-pack.\nEither destination for the decompressed data or the expected size of\nthe decompressed data must be specified. In the latter case a new\narray is allocated." void? "Return #t if x is #<void> and #f otherwise." >= "Return #t if the arguments are in non-increasing order (previous\none is greater than or equal to the next one)." help "Display documentation for the specified term, if available." length= "Bounded length test.\nUse this instead of (= (length lst) n), since it avoids unnecessary\nwork and always terminates." = "Return #t if the arguments are equal." car "Returns the first element of a list or nil if not available." *builtins* "VM instructions as closures." <= "Return #t if the arguments are in non-decreasing order (previous\none is less than or equal to the next one)." /= "Return #t if not all arguments are equal. Shorthand for (not (= …))." lz-pack "Return data compressed using Lempel-Ziv.\nThe data must be an array, returned value will have the same type.\nThe optional level is between 0 and 10. With level 0 a simple LZSS\nusing hashing will be performed. Levels between 1 and 9 offer a\ntrade-off between time/space and ratio. Level 10 is optimal but very\nslow." arg-counts "VM instructions mapped to their expected arguments count." nan? "Return #t if the argument is NaN, regardless of the sign." void "Return the constant #<void> while ignoring any arguments.\n#<void> is mainly used when a function has side effects but does not\nproduce any meaningful value to return, so even though #t or nil could\nbe returned instead, in case of #<void> alone, REPL will not print\nit." Instructions "VM instructions mapped to their encoded byte representation." cons? "Returns #t if the value is a cons cell." vm-stats "Print various VM-related information, such as the number of GC calls\nso far, heap and stack size, etc." * "Return product of the numbers or 1 with no arguments." *prompt* "Function called by REPL to signal the user input is required.\nDefault function prints \"#;> \"." cdr "Returns the tail of a list or nil if not available." + "Return sum of the numbers or 0 with no arguments." *properties* "All properties of symbols recorded with putprop are recorded in this table."))
+ *runestring-type* (array rune) *string-type* (array byte)
+ *syntax-environment* #table(bcode:nconst #fn("7000n1200r2e3:" #(aref)) doc-for #fn("@000\x8710002000\x881000I60O?140B;35040<;I40402086510B;35040=88II087\\3?07122862353@30O@F087\\360O@<071228624534252686e2261e22688e2e4:" #(#fn(top-level-value)+ error "docs: " ": no funvars specified" ": funvars set but isn't a function" symbol-set-doc quote)) with-input-from #fn("<000z12021e1220e2e1e12315163:" #(#fn(nconc)+ with-bindings *input-stream* #fn(copy-list))) unless #fn("<000z1200O211Pe4:" #(if begin)) time #fn(">000n12050218522e1e2e123024252622e185e32728e5e3e3:" #(#fn(gensym)+ let time-now prog1 princ "Elapsed time: " - " seconds" *linefeed*)) cond #fn(";000z0\x8d\x8a520852185>1_51485<061:" #(#0=#fn("7000z0\x8d:" #() void)+ #fn(">000n10H340O:0<85<20Q;I80485<DQ3C085=J6085<:2185=P:85=J@02285<A<0=51e3:85T23C\x98074758551513c07675855151278685<e2e12886217975855151PA<0=51e4e3:2:50278685<e2e1288675855186e2A<0=51e4e3:2885<2185=PA<0=51e4:" #(else+ begin or => 1arg-lambda? caddr caadr let if cddr #fn(gensym)) cond-clauses->if))) do #fn("J000z220501<2172052217305221240522587268927882829e12:1=51522829e12:82512887e18;52e153e4e3e2e12887e18:52e3:" #(#fn(gensym)+ #fn(map) car cadr #fn("6000n170051B38071061:0<:" #(cddr caddr)) letrec λ if #fn(nconc) begin #fn(copy-list))) mark-label #fn("8000n22002122e21e4:" #(emit+ quote label)) with-bindings #fn("G000z12071052207205220230522425e12076888653e12720288687535129242:e12715152242:e127202;8688535152e3e164:" #(#fn(map)+ car cadr #fn("5000n12060:" #(#fn(gensym))) #fn(nconc) let list #fn(copy-list)+ #fn("7000n22001e3:" #(set!)) unwind-protect begin #fn("7000n22001e3:" #(set!)))) let #fn(">000z1O0R3B00?641<?041=?1@30O42021e12223052e124151532225052863C0268687e2e186e3@408788P:" #(#fn(nconc)+ λ #fn(map) #fn("5000n10B3500<:0:" #()) #fn(copy-list)+ #fn("5000n10B3500T:7060:" #(void)) letrec)) bcode:code #fn("7000n1200Ee3:" #(aref)) define-macro #fn("A000z170151863D0710<860=5341=?1@30O42223240<e22526e10=e12715153e3e2:" #(value-get-doc+ symbol-set-doc void set-syntax! quote #fn(nconc) λ #fn(copy-list))) make-label #fn("5000n120e1:" #(gensym)) bcode:cenv #fn("7000n1200r3e3:" #(aref)) > #fn("<000z12021e12273151510e163:" #(#fn(nconc)+ < #fn(copy-list) reverse!)) quasiquote #fn("7000n1700E62:" #(bq-process)) when #fn(";000z1200211POe4:" #(if+ begin)) help #fn(";000n17002152853W072855147350424250>170026q535247350@B0722728051524735047960:" #(getprop+ *doc* princ newline #fn(for-each) #fn("7000n17050471A0P61:" #(newline print)) *funvars* "no help for "+ #fn(string) void)) bcode:ctable #fn("7000n1200Ke3:" #(aref)) with-output-to #fn("<000z12021e1220e2e1e12315163:" #(#fn(nconc)+ with-bindings *output-stream* #fn(copy-list))) catch #fn("@000n220502112286e123242586e2262786e22829e2e3262:86e20e3e42;86e22<86e2e4e3e3:" #(#fn(gensym)+ trycatch λ if and cons? eq? car quote thrown-value cadr caddr raise)) let* #fn("@000z10H3E02021e1qe12215153e1:2021e173051e1e1220=B3H02024e10=e12215153e1@301515375051e2:" #(#fn(nconc)+ λ #fn(copy-list) caar let* cadar)) letrec #fn(">000z1202021e12273052e122240522515154e1227605262:" #(#fn(nconc)+ λ #fn(map) car #fn("8000n12021e12205162:" #(#fn(nconc) set! #fn(copy-list)))+ #fn(copy-list) void)) /= #fn("=000z1202122e10e12315153e2:" #(not #fn(nconc) = #fn(copy-list))) bcode:sp #fn("7000n1200r4e3:" #(aref)) bcode:stack #fn(":000n2200r421220e21e3e4:" #(aset!+ + bcode:sp)) assert #fn(";000n1200D2122230e2e2e2e4:" #(if raise quote assert-failed)) case #fn("A000z1\x8d\x8a6208621_514225023870e2e12425e126278687>215252e3:" #(#0#+ #fn("8000n2120C5020:1J40O:1R3=021072151e3:1H3=023072151e3:1=J>0230721<51e3:74751523=0260271e2e3:280271e2e3:" #(else+ eq? quote-value eqv? every symbol? memq quote memv) vals->cond)
+ #fn(gensym) let #fn(nconc) cond #fn(map) #fn("7000n1A<F0<520=P:" #()))) receive #fn("?000z22021q1e32221e10e123825153e3:" #(call-with-values+ λ #fn(nconc) #fn(copy-list))) unwind-protect #fn("A000n220502050218722q1e3e2e1232402286e12587e12686e2e3e3e387e1e3e3:" #(#fn(gensym)+ let λ prog1 trycatch begin raise)) dotimes #fn("A000z10<0T20E2187Ke32223e186e1e12415153e4:" #(for+ - #fn(nconc) λ #fn(copy-list))) throw #fn("9000n220212223e201e4e2:" #(raise list quote+ thrown-value)))
+ 1+ #fn("6000n10KM:" #() 1+) 1-+ #fn("6000n10K~:" #() 1-) 1arg-lambda? #fn("7000n10B;3E04700<51;3:04710TK62:" #(is-lambda?+ length=) 1arg-lambda?)
+ <= #fn(";000z1\x8d\x8a6862086>1_486<^10162:" #(#fn("7000n21V;IL041<0L2;I5040\x8e340O:A<1<1=62:" #())) <=)+ > #fn(";000z1\x8d\x8a6862086>1_486<^10162:" #(#fn("7000n21V;IE041<0L2;3;04A<1<1=62:" #())) >)+ >= #fn(";000z1\x8d\x8a6862086>1_486<^10162:" #(#fn("7000n21V;IL0401<L2;I5040\x8e340O:A<1<1=62:" #())) >=)+ Instructions #table(call.l 81 trycatch 75 largc 79 loadg.l 68 aref2 23 box 90 cadr 36 argc 62 setg 71 load0 21 nan? 94 vector? 45 fixnum? 41 loadc0 17 loada0 0 div0 59 keyargs 89 call 5 loada.l 69 brt.l 50 sub2 78 add2 29 loadc.l 70 loadc 9 builtin? 43 set-car! 47 brt 25 ret 10 loadi8 66 tapply 77 loadvoid 93 loada1 1 shift 46 boolean? 39 atom? 24 cdr 13 brne.l 83 / 58 loadf 31 equal? 52 apply 54 dup 11 loadt 20 jmp.l 48 null? 38 not 35 = 60 set-cdr! 30 eq? 33 * 57 load1 27 bound? 42 brf 3 function? 44 box.l 91 < 28 brnn.l 84 jmp 16 loadv 2 for 76 lvargc 80 dummy_eof 95 + 55 brne 19 compare 61 neg 37 loadv.l 67 number? 40 vargc 74 brn 85 brbound 88 vector 63 loadc1 22 setg.l 72 cons? 18 brf.l 49 aref 92 symbol? 34 aset! 64 car 12 cons 32 tcall.l 82 - 56 brn.l 86 optargs 87 closure 14 pop 4 eqv? 51 list 53 seta 15 seta.l 73 brnn 26 loadnil 65 loadg 7 loada 8 tcall 6)
+ __init_globals #fn("7000n07021d37022@402384w4^147025d;350426;I50427w8429w:47;w<47=w>47?w@:" #(*os-name*+ "macos" #fn("6000n0702161:" #(princ "\e[0m\e[1m#;> \e[0m"))+ #fn("6000n0702161:" #(princ "#;> ")) *prompt* "dos" "\\" "/" *directory-separator* "\n"+ *linefeed* *stdout* *output-stream* *stdin* *input-stream* *stderr* *error-stream*) __init_globals)
+ __rcscript #fn("=000n0708421c360O@T08422c37023@G08424c3=07526514O@4027^184;390428845185;3=0429857:2;53863B02<86513907=8661:O:" #(*os-name*+ "unknown" "plan9" "home" "macos" princ "\e]0;femtolisp v0.999\a" "HOME" #fn(os-getenv)
+ #fn(string) *directory-separator* ".flisprc" #fn(path-exists?) load) __rcscript)
+ __script #fn("6000n1200>121{:" #(#fn("6000n070A61:" #(load))+ #fn("6000n170051421K61:" #(top-level-exception-handler+ #fn(exit)))) __script)
+ __start #fn("7000n1705040=B3D00=w14Ow24730T51@C00w14Dw24745047550426E61:" #(__init_globals+ *argv*
+ *interactive*
+ __script
+ __rcscript
+ repl #fn(exit)) __start)
+ abs #fn("6000n10EL23500U:0:" #() abs) any+ #fn("7000n21B;3D0401<51;I:047001=62:" #(any) any) arg-counts #table(bound? 1 function? 1 symbol? 1 car 1 cons 2 cadr 1 nan? 1 for 3 boolean? 1 fixnum? 1 vector? 1 cdr 1 atom? 1 div0 2 equal? 2 eqv? 2 compare 2 null? 1 not 1 number? 1 set-cdr! 2 builtin? 1 eq? 2 cons? 1 set-car! 2)+ argc-error #fn(";000n2702102211Kl237023@402465:" #(error "compile error: " " expects "+ " argument." " arguments.") argc-error)
+ array? #fn("7000n10];IF042005185B;390485<21Q:" #(#fn(typeof) array) array?) assoc+ #fn("7000n21J40O:701510d3501<:7101=62:" #(caar assoc) assoc) assv #fn("7000n21J40O:701510c3501<:7101=62:" #(caar+ assv) assv)
+ bcode:indexfor #fn(";000n20KG0r2G20861523:02186162:2286187534870r287KMp4:" #(#fn(has?)+ #fn(get) #fn(put!)) bcode:indexfor)
+ box-vars #fn("9000n2\x8d\x8a68620086>2_486<^1161:" #(#fn("9000n10B3Q00<T3B070A21720<5153@30O4F<0=61:O:" #(emit+ box caddr))) box-vars)
+ bq-bracket #fn(";000n20H3=070710152e2:0<22CS01El2380700=P:707324710=1K~52e3e2:0<25CT01El2390260Te2:707027710T1K~52e3e2:0<28CP01El23500T:707029710T1K~52e3e2:70710152e2:" #(list+ bq-process unquote cons 'unquote unquote-splicing copy-list 'unquote-splicing unquote-nsplicing
+ 'unquote-nsplicing) bq-bracket)
+ bq-bracket1 #fn(":000n20B3S00<20CL01El23500T:7122730=1K~52e3:730162:" #(unquote cons 'unquote+ bq-process) bq-bracket1)
+ bq-process #fn("<000n20R380200e2:0]3T0717205115286<73C907486=P:757486e3:0H3400:0<26CB07327710T1KM52e3:0<28CV01El23?0790r2523500T:7:2;710=1K~52e3:7<7=052It07>0512?2@1>105286J807387P:87=JA07:87<7186152e3:2A7B87P7186152e162:\x8d\x8a6862C186>2_486<^10q62:" #(quote+ bq-process vector->list list vector apply quasiquote 'quasiquote unquote length= cons 'unquote
+ any splice-form? lastcdr #fn(map) #fn("7000n1700A62:" #(bq-bracket1))+ #fn(nconc) list* #fn("=000n20J;02071151P:0B3o00<22CX020731AEl23700=@C07425e2760=AK~52e252P:F<0=770<A521P62:2071760A521P51P:" #(nconc+ reverse! unquote nreconc list 'unquote bq-process bq-bracket))) bq-process)
+ builtin->instruction #fn("8000n120A0O63:" #(#fn(get)) #(#table(#.cadr cadr #.aset! aset! #.nan? nan? #.+ + #.- - #.equal? equal? #.eq? eq? #.builtin? builtin? #.not not #.cons? cons? #.cdr cdr #./ / #.div0 div0 #.set-car! set-car! #.vector vector #.set-cdr! set-cdr! #.< < #.for for #.cons cons #.apply apply #.eqv? eqv? #.vector? vector? #.list list #.aref aref #.car car #.bound? bound? #.function? function? #.null? null? #.symbol? symbol? #.compare compare #.boolean? boolean? #.fixnum? fixnum? #.atom? atom? #.= = #.number? number? #.* *)))+ caaaar #fn("5000n10<<<<:" #() caaaar) caaadr+ #fn("5000n10T<<:" #() caaadr) caaar #fn("5000n10<<<:" #() caaar) caadar+ #fn("5000n10<T<:" #() caadar) caaddr #fn("5000n10=T<:" #() caaddr) caadr+ #fn("5000n10T<:" #() caadr) caar #fn("5000n10<<:" #() caar) cadaar+ #fn("5000n10<<T:" #() cadaar) cadadr #fn("5000n10TT:" #() cadadr) cadar+ #fn("5000n10<T:" #() cadar) caddar #fn("5000n10<=T:" #() caddar) cadddr+ #fn("5000n10==T:" #() cadddr) caddr #4=#fn("5000n10=T:" #() caddr) call-with-values+ #fn("7000n205086B3@0A86<C90186=}2:18661:" #() #(#3=(*values*))) capture-var! #fn("<000n20r3G70186E5387;IG042186510r322861e152p4:" #(index-of+ #fn(length) #fn(nconc)) capture-var!)
+ cdaaar #fn("5000n10<<<=:" #() cdaaar) cdaadr+ #fn("5000n10T<=:" #() cdaadr) cdaar #fn("5000n10<<=:" #() cdaar) cdadar+ #fn("5000n10<T=:" #() cdadar) cdaddr #fn("5000n10=T=:" #() cdaddr) cdadr+ #fn("5000n10T=:" #() cdadr) cdar #fn("5000n10<=:" #() cdar) cddaar+ #fn("5000n10<<==:" #() cddaar) cddadr #fn("5000n10T==:" #() cddadr) cddar+ #fn("5000n10<==:" #() cddar) cdddar #fn("5000n10<===:" #() cdddar) cddddr+ #fn("5000n10====:" #() cddddr) cdddr #fn("5000n10===:" #() cdddr) cddr+ #fn("5000n10==:" #() cddr) char? #fn("6000n12005121Q:" #(#fn(typeof) rune) char?)+ closure? #fn("6000n10\\;36040[S:" #() closure?) compile+ #fn("8000n170q7105162:" #(compile-f lower-define) compile) compile-and #fn("<000n570018283D218467:" #(compile-short-circuit+ brf) compile-and)
+ compile-app #fn("E000n483<88R3U07088152IK088Z3E0218851[3;0218851@40887283=23523q07401O895440r40r4GKMp4750183=530r40r4G8:UMp47608237027@40288:63:89[;3904798951892:Cf07089152I\\0212:517:d3P07;83r2523E07401O83T5447602:62:89B3P07<89<513F07=83513=07>01828364:8:360O@F07401O895440r40r4GKMp4750183=530r40r4G8;UMp48:360O@=00r40r4Gr/Mp48:3C07?018283898:8;67:760823702@@402A8;63:" #(in-env?+ #fn(top-level-value) length> 255 compile-in compile-arglist emit tcall.l call.l
+ builtin->instruction cadr length= is-lambda? inlineable? compile-let compile-builtin-call tcall
+ call) compile-app)
+ compile-arglist #fn("8000n3202101>282524228261:" #(#fn(for-each)+ #fn("9000n170AFO0544Ar4Ar4GKMp:" #(compile-in))+ #fn(length)) compile-arglist)
+ compile-aset! #fn("=000n3208251r2~87Kl23?07101O2282P64:K87L23h07101O2374828752P544750176828752530r40r4G88UMp47702262:7822r362:" #(#fn(length)+ compile-app aset! aref list-head compile-arglist list-tail emit argc-error) compile-aset!)
+ compile-begin #fn("9000n483H3?0700182715064:83=H3>070018283<64:7001O83<5447202352474018283=64:" #(compile-in+ void emit pop compile-begin) compile-begin)
+ compile-builtin-call #fn(">000n7\x8d202186850>3?;514227385O538<3I07483=8<52I=075858<52@30O4858=26CL086El23:07702862:770858663:8=29C708;60:8=2:C708;60:8=2;C]086El23:07702<62:86r2l23:07702=62:770858663:8=2>Cm086El23:07585K62:86Kl23:07702?62:86r2l23:07702@62:770858663:8=2ACL086El23:07702B62:770858663:8=2CCL086El23:07585K62:770858663:8=2DCN086El23<07702E2F63:770858663:8=2GCX086r2L23;07585r262:770823702H@402G8663:8=2ICb086r2l23:07702J62:r286L23?07708586r3~63:7585r262:7708562:" #(#0#+ #fn("8000n0AEl239070FK62:7192FA63:" #(argc-error emit) num-compare)+ #fn(get) arg-counts length= argc-error list emit loadnil < = + load0 add2 - neg sub2 * load1 /
+ vector loadv #() apply tapply aref aref2) compile-builtin-call)
+ compile-f #fn("8000n2702101>22262:" #(call-with-values #fn("7000n070AF62:" #(compile-f-))+ #fn("5000n20:" #())) compile-f)+ compile-f- #fn("O000n270501T711T517215173741T52711518;J7025@408;87H360E@802687518=268:51~73778:528:\x85\xa208?JL07886298>88J708=@508=U54@r07:867;2<7=2<7>8?527?268?5151535152478862@8>268?5188J708=@508=U5547A8608:898>55@30O42B8=L23I0788688J702C@402D8=53@W088\x85?078862E8=53@E08:J?078862F8=53@30O47G0897H7I1518952537J868@<52486r4268951r4Mp47K868@D7I15154478862L5247M2N7O86EG517P86518<5386r3G62:" #(make-code-emitter+ lastcdr lambda:vars filter cons? λ #fn(length) keyword-arg? emit optargs bcode:indexfor
+ make-perfect-hash-table #fn(map) cons car iota keyargs emit-optional-arg-inits 255 largc lvargc
+ vargc argc extend-env complex-bindings lambda:body box-vars compile-in ret values #fn(function)
+ encode-byte-code const-to-idx-vec) compile-f-)
+ compile-if #fn("A000n420502050205083T718351728351B3;0738351@30O8;DC=07401828<64:8;OC=07401828=64:7401O8;89554750268953475027885347401828<544823<07502852@;0750298:53475027895347401828=544750278:63:" #(#fn(gensym)+ caddr cdddr cadddr compile-in emit brf label ret jmp) compile-if)
+ compile-in #fn("B000\x8740005000\x884000I60O?4483R3<0700183D64:83H3\xa6083EC:07102262:83KC:07102362:83DC:07102462:83OC:07102562:83qC:07102662:7783513:07102862:7983513<07102:8363:7102;8363:83<2<C<07=0183=63:83<RS;ID0483<Z;I;047>83<1523=07?01828364:83<892@CS07A83T513>07B018283T64:7102;83T63:892CC=07D01828364:892EC>07F018283=64:892GC;07H018363:892ICD07J2K183>22L01>262:892MC@07N018283=8465:892OC>07P018283=64:892QCE07R0183T2E7S8351P64:892TCE07B01D83T5447102U62:892VC\x93083T7S83517W8;518:R360O@807X2Y5148<3`08;=?;47Z8:8<8;<B;3G047[8;<<51;3:047\\8;<5153@30O47]018:8;<64:892^Cp07B01O2Iq83Te35447_7`835151360O@807X2a5147B01O7`83515447102^62:7?01828364:" #(compile-sym+ emit load0 load1 loadt loadf loadnil void? loadvoid fits-i8 loadi8 loadv aset! compile-aset!
+ in-env? compile-app quote self-evaluating? compile-in if compile-if begin compile-begin prog1
+ compile-prog1 λ call-with-values #fn("7000n070AF62:" #(compile-f-))+ #fn("9000n270A2105341\x85K02223AF>2152470A242515163:O:" #(emit loadv #fn(for-each)+ #fn("9000n170AF0O64:" #(compile-sym))+ closure #fn(length))) and compile-and
+ or compile-or while compile-while cddr return ret set! value-get-doc error "set!: name must be a symbol"
+ symbol-set-doc is-lambda? lambda:vars compile-set! trycatch 1arg-lambda? caddr "trycatch: second form must be a 1-argument lambda") compile-in)
+ compile-let #fn("A000n483<83=0r4G88T70018953718;727388518;528:537408=524258=1<521=P7608>827388515440r40r4G8<UMp4E8<L23A082I<0770288<63:O:" #(compile-arglist+ vars-to-env complex-bindings caddr box-vars #fn(nconc) compile-in emit shift) compile-let)
+ compile-or #fn("<000n470018283O21O67:" #(compile-short-circuit brt) compile-or)+ compile-prog1 #fn(":000n37001O82T544718251B3_00r40r4GKMp47201O718251544730245240r40r4Gr/Mp:O:" #(compile-in+ cddr compile-begin emit pop) compile-prog1)
+ compile-set! #fn("?000n470821E538821CF07201O83544730248263:88<El288=T893<07588=51@9076082528:3o07308937027@40288;5340r40r4GKMp47201O835440r40r4Gr/Mp47302962:7201O8354489IA07:2;2<825251@30O47302=8;63:" #(lookup-sym+ global compile-in emit setg vinfo:index capture-var! loada loadc set-car! error #fn(string)
+ "internal error: misallocated var " seta) compile-set!)
+ compile-short-circuit #fn("?000n783H3?0700182848665:83=H3@070018283<8665:86;I70421507001O83<865540r40r4GKMp486360O@9072023524720858;5340r40r4Gr/Mp486360O@907202452475018283=84858657486340O:720268;63:" #(compile-in+ #fn(gensym) emit dup pop compile-short-circuit label) compile-short-circuit)
+ compile-sym #fn(";000n470821E538821C`02282513M073248251513@07502624825163:750278263:88<El23W0750287988=51534833A088=T3:07502:62:O:7502;7<08252534833A088=T3:07502:62:O:" #(lookup-sym+ global #fn(constant?) printable? #fn(top-level-value) emit loadv loadg loada vinfo:index car
+ loadc capture-var!) compile-sym)
+ compile-thunk #fn(":000n170q21q72051e362:" #(compile-f λ lower-define) compile-thunk)+ compile-while #fn(";000n4205020507101O72505440r40r4GKMp473024885347101O825447302589534730265240r40r4Gr/Mp47101O835447302788534730248963:" #(#fn(gensym)+ compile-in void emit label brf pop jmp) compile-while)
+ complex-bindings #fn("=000n2205020507101OO8687564722386>174875162:" #(#fn(table)+ complex-bindings-
+ filter #fn("7000n120A062:" #(#fn(has?)))+ table-keys) complex-bindings)
+ complex-bindings- #fn("=000n61J40O:0R3K0833D02001523;021840D63:O:0H;I80472051340O:0<23Co0200T1523Q021850TD534833>021840TD53@30O@30O474750511O83848566:760<513U074770517817905152O82S;I50483848566:740<17:051838485562;2<1838485>40=52P:" #(#fn(memq)+ #fn(put!) quoted? set! complex-bindings- caddr is-lambda? lambda:body diff lambda:vars
+ inlineable? #fn(map) #fn(";000n1700AOF929366:" #(complex-bindings-))) complex-bindings-)+ const-to-idx-vec #fn("9000n1200r2G51212285>10KG52485:" #(#fn(vector-alloc)+ #fn(for-each)
+ #fn("7000n2A10p:" #())) const-to-idx-vec)+ copy-tree #fn("7000n10H3400:700<51700=51P:" #(copy-tree) copy-tree) count+ #fn("9000n2\x8d\x8a620862186>1_51486<01E63:" #(#0#+ #fn("9000n31J5082:A<01=01<5139082KM@408263:" #() count-)) count)+ delete-duplicates #fn(":000n1700rD523O02150\x8d\x8a686228586>2_486<^10q62:0H3400:0<0=73858652390748661:85748651P:" #(length>+ #fn(table) #fn("8000n20H38070161:21A0<523:0F<0=162:22A0<D534F<0=0<1P62:" #(reverse! #fn(has?)+ #fn(put!))) member
+ delete-duplicates) delete-duplicates)
+ diff #fn("8000n20J40q:200<1523:0710=162:0<710=152P:" #(#fn(memq) diff) diff)+ disassemble #fn("U000\x871000.///\x881000I60O?14z282JG07001E534715047260:@30O482<2305124051\x8d\x8d252687>1?:5142527187>2?;514r4288851\x8a<\x8d8<<8=L23\x9124292:888<>2O7;53r48<<L23907150@30O4E87K~2<|48<8<<KM_48>2=8?2>523[08;8>8<<r45348:897?888<<52G5148<8<<r4M_@\x1f12=8?2@523V08;8>8<<K5348:89888<<GG5148<8<<KM_@\xf012=8?2A523e08;8>8<<K5347B2C888<<G8>2DC70r3@30EM515148<8<<KM_@\xb212=8?2E523\\08;8>8<<r45347B2C7?888<<52515148<8<<r4M_@}12=8?2F523\xb808;8>8<<r88>2GC70r4@30EM5347B2C7?888<<52512H5248<8<<r4M_47B2C7?888<<52515148<8<<r4M_48>2GCY07B2H5147B2C7?888<<52512H5248<8<<r4M_@30O@\xec08?2Ic3^08;8>8<<r45347B2C7?888<<52512H5248<8<<r4M_@\xb802=8?2J523e08;8>8<<r25347B2K7L8<<r,7M888<<52g3515248<8<<r2M_@z02=8?2N523e08;8>8<<r45347B2K7L8<<r,7?888<<52g3515248<8<<r4M_@<08;8>8<<E53^1^1@\xc9-:" #(disassemble+ newline void #fn(function:code) #fn(function:vals)
+ #1=#fn("7000z0\x8d:" #() void) #fn("9000n10\\3F00[IA070504710OAKM63:72061:" #(newline disassemble+ print) print-val)
+ #fn(";000n370A3U0FEl23N071A72151523A0A182ML237023@4024751r5~512602765:" #(princ >= 1- " >" " "+ hex5 ": " " ") print-inst)
+ #fn(length) #fn(table-foldl) #fn("7000n382;I?041AF<GQ;34040:" #()) Instructions #fn("6000n1702161:" #(princ+ "\t")) #fn(memq) (loadv.l loadg.l setg.l) ref-int32-LE (loadv loadg setg)
+ (loada seta loadc call tcall list + - * / < = vector argc vargc loadi8 apply tapply closure box
+ shift aref) princ #fn(number->string) aref (loada.l seta.l loadc.l largc lvargc call.l tcall.l
+ box.l) (optargs keyargs) keyargs " " brbound
+ (jmp brf brt brne brnn brn) "@" hex5 ref-int16-LE (jmp.l brf.l brt.l brne.l brnn.l brn.l)) disassemble)
+ div #fn("7000n201k0EL2;3D041EL2;3404K;I504r/;I404EM:" #() div) emit+ #fn("Q000z2\x8d2021?75140EG82Jk0122CB088<23C:08824_@R0125CE08788<513;00E88=p@900E188Pp@\x9a126127523A078082<52e1?2@30O42912:52893D02;82<L23:089T?1@30O^142912<52893D02;82<L23:089T?1@30O^1412=C\\0822>d3=02??14q?2@F0822@d3=02A?14q?2@30O@30O412BC\\0822>d3=02C?14q?2@F0822@d3=02D?14q?2@30O@30O488<12EQ;3\x9b04892FCM088T2GCE00E82<2H7I8851PPp@x0892FCB00E82<2J88=PPp@a0892KCB00E82<2L88=PPp@J0892GCB00E82<2M88=PPp@30O;I]0412JCI0892GCB00E82<2H88=PPp@?00E7N182P8852p^140:" #(#0#+ #fn("7000n17002162:" #(member (load0 load1 loadt loadf loadnil loadvoid)) load?) car cdr cadr pop+ #fn(memq) (loadv loadg setg) bcode:indexfor #fn(assq)
+ ((loadv loadv.l) (loadg loadg.l) (setg setg.l) (loada loada.l) (seta seta.l) (box box.l)) 255 ((loadc
+ loadc.l)) loada (0) loada0 (1) loada1 loadc loadc0 loadc1 brf not null? brn cddr brt eq? brne
+ brnn nreconc) emit)
+ emit-optional-arg-inits #fn("<000n582B3\x91020507102284534710238953474075176838452q53O7782515447102884534710295247102:895347;0182=8384KM65:O:" #(#fn(gensym)+ emit brbound brt compile-in extend-env list-head cadar seta pop label emit-optional-arg-inits) emit-optional-arg-inits)
+ encode-byte-code #fn("S000n17005171855172238651r3238651r2ki2M2452238651E255025502650OO278<28524\x8d8988L23\xda148689G?=48=29CP02:8:8689KMG2;8<5153489r2M?9@\xa91278<2<2=7>873\x8308=8D2?C702@@p08D2AC702B@d08D2CC702D@X08D2EC702F@L08D2GC702H@@08D2IC702J@408=^1@408=525152489KM?948988L23:08689G@30O?>42K8=2L523`02:8;2;8<518>534278<873707M@407NE5152489KM?9@\xeb08=2OCH0278<2P8>5152489KM?9@\xce08>X3\xc708=2K8?2Q523H0278<2P8>5152489KM?9@\x9f02K8?2R523\x810278<2P8>5152489KM?94278<2P8689G5152489KM?948=2SCK0278<2P8689G5152489KM?9@30O@E0278<2T8>5152489KM?9^1@30O@\x81.42U2V8<878:>38;5242W8<61:" #(reverse!+ list->vector >= #fn(length) 65536 #fn(table) #fn(buffer)
+ #fn(io-write) #int32(0) label #fn(put!) #fn(sizeof)
+ #fn(byte) #fn(get) Instructions jmp jmp.l brt brt.l brf brf.l brne brne.l brnn brnn.l brn brn.l
+ #fn(memq) (jmp brf brt brne brnn brn) int32 int16 brbound #fn(int32)
+ (loadv.l loadg.l setg.l loada.l seta.l largc lvargc call.l tcall.l loadc.l box.l) (optargs
+ keyargs)
+ keyargs #fn(uint8) #fn(for-each) #fn(";000n220A052421AF37072@407324921520~5162:" #(#fn(io-seek)+ #fn(io-write)
+ int32 int16 #fn(get)))
+ #fn(iostream->string)) encode-byte-code)
+ error #fn("9000z020210P61:" #(#fn(raise) error) error) eval+ #fn("7000n170710515160:" #(compile-thunk expand) eval) even? #fn("7000n1200K52El2:" #(#fn(logand)) even?)+ every #fn("7000n21H;ID0401<51;3:047001=62:" #(every) every) expand+ #fn("G000n1\x8d\x8d\x8d\x8d\x8d\x8d\x8d\x8d\x8d\x8d\x8d\x8a5\x8a6\x8a7\x8a8\x8a9\x8a:\x8a;\x8a<\x8a=\x8a>\x8a?208521_51420862286>1_514208723e1_51420882485868?87>4_5142089258?89>2_514208:268:>1_514208;278:8988>3_514208<288?8:8988>4_514208=29888?>2_514208>2:_514208?2;8?8>8;8<8=>5_5148?<0q62:" #(#0#+ #fn("7000n20Z;I904200152S:" #(#fn(assq)) top?) #fn("8000n10H3400:020d3400:0<B3P07105122CF023A<7405151A<0=5162:0<A<0=51P:" #(((begin))+ caar begin #fn(append) cdar) splice-begin) *expanded* #fn("A000n20H3400:A<201523:0F<051@300A<21152873;0728651@30q2324758852152\x8a987IA024269289>28662:\x8d\x8a:8:278:928993>4_48:<^186518:\x8d8;B3c0493<788;51QIC08;92<8;<89<52_@;08;798;51_48;=?;@\xfb/48::" #(begin+ define get-defined-vars #fn(nconc) #fn(map) list #fn("7000n1A<0F<62:" #())+ #fn(";000n10H3400:0<B3F02071051C<00<A<0=51P:F<0<92<52922223747585515292<52_493<85PA<0=51P:" #(define+ caar #fn(nconc) #fn(map) list get-defined-vars)) caar cdar) expand-body)
+ #fn("9000n20H3400:0<B3M00<=B3F070051A<71051152e2@400<F<0=152P:" #(caar cadar) expand-lambda-list)+ #fn("7000n10H3600e1:0<B3?070051A<0=51P:0<A<0=51P:" #(caar) l-vars)+ #fn("?000n20T7005171051A<0T5122237489521522225e1F<868:52e192<888:528764:" #(lastcdr cddr #fn(nconc)+ #fn(map) list λ) expand-lambda)
+ #fn("D000n20=V;I6040TH3o070051J400:0T717005151873B00=?0472868752@30O42386A<74051152e3:750517605170051718851F<86512728798:52152893E088=?847287898653@30O42723e18792<868;52Pe193<888;5263:" #(cddr+ value-get-doc symbol-set-doc define caddr cdadr caadr #fn(nconc)
+ #fn(map) list) expand-define) #fn("=000n20T20A<71051222324F1>2865215252P:" #(begin cddr #fn(nconc)+ #fn(map)
+ #fn("9000n10<70A<0TF525150Fe3:" #(compile-thunk))) expand-let-syntax)+ #fn("5000n20:" #() local-expansion-env) #fn("<000n20H3400:0<208615221A10>3873P087=B3I0A<87T0=f2F<72875115262:73051893>0A<890=f2162:87;I?0486RS;I60486Z3708860:8624C400:8625C:092<0162:8625C:092<0162:8626C:093<0162:8627C:094<0162:8860:" #(#fn(assq)+ #fn(":000n0\x8d\x8a48420AF84>3_484<^19261:" #(#fn("8000n10H3400:0<H3700<@90A<0<F5292<0=51P:" #())))+ caddr macrocall? quote λ define let-syntax) expand-in)) expand)
+ expand-define #fn("@000n10T70051B3:070051@H085R37021@=07223740515285R3@021258586<e3e2:212585<2627e185=e128865185<54e3e2:" #(cddr+ #1# error "compile error: invalid syntax " print-to-string set! #fn(nconc) λ #fn(copy-list)) expand-define)
+ extend-env #fn("8000n370182E530P:" #(vars-to-env) extend-env) filter+ #fn("9000n2\x8d20210>1?65148601qe163:" #(#0#+ #fn("8000n382\x8d1B3Q04A1<513?0821<qPN=?2@30O41=?1@\x0e/4=:" #() filter-)) filter)+ fits-i8 #fn("8000n10Y;3<0470r\xaf0r\xb063:" #(>=) fits-i8) foldl+ #fn("9000n382J401:700082<15282=63:" #(foldl) foldl) foldr #fn(":000n382J401:082<700182=5362:" #(foldr) foldr)+ get-defined-vars #fn("7000n170A<05161:" #(delete-duplicates) #(#2=(#fn("8000n10H340q:0<20Cj00=B3d00TR;37040Te1;IS040TB;3E0471051R;3:0471051e1;I404q:0<22C?07324A<0=52}2:q:" #(define+ caadr begin nconc #fn(map)) #(#2#)))))
+ getprop #fn(":000\x8720003000\x882000I60O?2420711O5387;3<04208708253;I50482:" #(#fn(get)+ *properties*) getprop)
+ hex5 #fn("8000n170210r@52r52263:" #(string-lpad #fn(number->string) #\0) hex5) identity+ #fn("5000n10:" #() identity) in-env? #fn("7000n21B;3F042001<52;I:047101=62:" #(#fn(assq)+ in-env?) in-env?)
+ index-of #fn("9000n31J40O:01<C5082:7001=82KM63:" #(index-of) index-of) inlineable?+ #fn("9000n10<85B;3u047085<51;3i047185T51;3]04727385T52;3O047485T2552S;3@047685T270=5162:" #(is-lambda?+ list? every symbol? length> 255 length= #fn(length)) inlineable?)
+ io-readall #fn("8000n1205021850524228561:" #(#fn(buffer)+ #fn(io-copy)
+ #fn(iostream->string)) io-readall)
+ io-readline #fn("7000n12002162:" #(#fn(io-readuntil) #\newline) io-readline)+ io-readlines #fn("7000n17071062:" #(read-all-of io-readline) io-readlines) iota+ #fn("7000n17071062:" #(map-int identity) iota) is-lambda? #fn("6000n1020Q;I704020Q:" #(λ) is-lambda?)+ keyword->symbol #fn(";000n1200513K021220512386K24865153^161:0:" #(#fn(keyword?)+ #fn(symbol)
+ #fn(string)
+ #fn(string-sub)
+ #fn(string-length)) keyword->symbol)
+ keyword-arg? #fn("6000n10B;3904200<61:" #(#fn(keyword?)) keyword-arg?) lambda-vars+ #fn(":000n1\x8d\x8a520852185>1_51485<00OO54422237405162:" #(#0#+ #fn(":000n40V;I5040R340D:0B3Z00<R3T082;I504833<0702112263:A<0=1828364:0B3\x8d00<B3\x870730<r2523?074051R360O@=070250<2615442774051513=0A<0=182D64:833<0702112863:A<0=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 " " in list " #fn(keyword?)
+ ": keyword arguments must come last." "compile error: invalid formal argument ") check-formals)
+ #fn(map)
+ #fn("6000n10B390700<61:0:" #(keyword->symbol))+ to-proper) lambda-vars)
+ lambda:body #fn("6000n170061:" #(caddr) lambda:body) lambda:vars+ #fn("6000n1700T61:" #(lambda-vars) lambda:vars) last-pair #fn("6000n10=H3400:700=61:" #(last-pair) last-pair)+ lastcdr #fn("6000n10H3400:70051=:" #(last-pair) lastcdr) length=+ #fn("8000n21EL2340O:1El23500H:0H3701El2:700=1K~62:" #(length=) length=) length> #fn("8000n21EL23400:1El23;00B;34040:0H3701EL2:700=1K~62:" #(length>) length>)+ list->vector #fn("6000n1700}2:" #(vector) list->vector) list-head+ #fn("9000n2701E52340q:0<710=1K~52P:" #(<= list-head) list-head) list-ref #fn("7000n2700152<:" #(list-tail) list-ref)+ list-tail #fn("8000n2701E523400:710=1K~62:" #(<= list-tail) list-tail) list?+ #fn("6000n10V;I@040B;3904700=61:" #(list?) list?) load #fn("9000n120021522285>123850>2{:" #(#fn(file)+ :read #fn("9000n0\x8d\x8a48420A84>2_484<^1\x8d\x8d\x8d63:" #(#fn("9000n320A51IG0F<21A510721514735063:24A514737215161:" #(#fn(io-eof?)+ #fn(read) load-process void #fn(io-close))))) #fn("8000n120A5142122F0e361:" #(#fn(io-close)+ #fn(raise)
+ load-error))) load)
+ load-process #fn("6000n170061:" #(eval) load-process) lookup-sym+ #fn(";000n31J5020:1<2108752883808288P:7201=82KM63:" #(global #fn(assq) lookup-sym) lookup-sym)+ lower-define #fn(";000n1\x8d2021?55140H;I804720513400:0<23C<0747505161:760<513K02728e10Te185051e17905164:2:74062:" #(#1#+ #fn("=000n170051B3N071051B3=02270051P@7073051@60745075855176855186J5087:278687e328748652P:" #(cddr+ cdddr begin caddr void get-defined-vars lower-define λ #fn(map)) λ-body) quoted? define
+ lower-define expand-define is-lambda? #fn(nconc) λ lastcdr #fn(map)) lower-define)
+ macrocall? #fn("6000n10<R;3904700<61:" #(symbol-syntax) macrocall?) macroexpand-1+ #fn("7000n10H3400:7005185390850=}2:0:" #(macrocall?) macroexpand-1) make-code-emitter+ #fn("9000n0q2050EqEo5:" #(#fn(table)) make-code-emitter)+ make-perfect-hash-table #fn(";000n1\x8d\x8a5208521_514\x8d\x8a6862285860>3_486<^12305161:" #(#1#+ #fn("8000n270712205151162:" #(mod0 abs #fn(hash)) $hash-keyword)+ #fn("=000n120r20i2O52\x8d\x8a68621A085F86>5_486<^19261:" #(#fn(vector-alloc)+ #fn(":000n10B3p070051r2A<85F52i29286G3;093<FKM61:928685p49286KM71051p494<0=61:92:" #(caar+ cdar)))) #fn(length)) make-perfect-hash-table)
+ make-system-image #fn("@000n120021222354202402552212223542650277879Dw84Dw942:898:>22;88878586>42<8;>1{8;504:" #(#fn(file)+ :write :create :truncate #fn(string) ".builtin" #fn(buffer)
+ (*linefeed* *directory-separator* *argv* that *print-pretty* *print-width* *print-readably*
+ *print-level* *print-length* *os-name* *interactive* *prompt* *os-version*)
+ *print-pretty* *print-readably* #fn("5000n0Aw04Fw1:" #(*print-pretty* *print-readably*))+ #fn("?000n07021A>17223505152742576842577845253f22885F52428859252429927:52^1^142;F512<2=F51r:522>2?E2@2A84522B84r(522B84r 522B84r\x18525629938652429938552^1^1^142C925142C9361:" #(filter+ #fn("8000n10Z;3u0420051S;3j0421051[S;IC0422051222105151dS;3I04230A52S;3=04242105151S:" #(#fn(constant?)+ #fn(top-level-value) #fn(string) #fn(memq) #fn(iostream?))) simple-sort #fn(environment) nconc #fn(map)
+ list top-level-value #fn(write) #fn(io-write) *linefeed* #fn(sizeof)
+ #fn(lz-pack) #fn(iostream->string) #fn(array) byte #fn(logand) 255 #fn(ash)
+ #fn(io-close))) #fn("6000n1A50420061:" #(#fn(raise)))) make-system-image)+ map! #fn("8000n21\x8d1B3B04101<51_41=?1@\x1d/4:" #() map!) map-int+ #fn(";000n2701E52340q:0E51qPq\x8a78786_4K7115122870>2|486:" #(<= 1- #fn("7000n1A<F051qPN4AA<=_:" #())) map-int)+ max #fn(";000z11J400:70210163:" #(foldl #fn("6000n201L23401:0:" #())) max) member+ #fn("7000n21J40O:1<0d3401:7001=62:" #(member) member) memv #fn("7000n21J40O:1<0c3401:7001=62:" #(memv) memv)+ min #fn(";000z11J400:70210163:" #(foldl #fn("6000n201L23400:1:" #())) min) mod+ #fn("8000n207001521i2~:" #(div) mod) mod0 #fn("7000n2001k1i2~:" #() mod0) negative?+ #fn("6000n10EL2:" #() negative?) nestlist #fn(":000n37082E52340q:1710015182K~53P:" #(<=+ nestlist) nestlist)
+ newline #fn("8000\x8700001000\x880000I7070?04210725247360:" #(*output-stream* #fn(io-write)+ *linefeed* void) newline)
+ nreconc #fn("7000n2701062:" #(reverse!-) nreconc) odd?+ #fn("6000n170051S:" #(even?) odd?) partition #fn(":000n2\x8d2021?65148601qe1qe164:" #(#0#+ #fn("9000n48283P\x8d1B3Z0401<513?0821<qPN=?2@<0831<qPN=?341=?1@\x05/47088<=88==62:" #(values) partition-)) partition)+ positive? #fn("6000n1E0L2:" #() positive?) princ+ #fn(";000z070Ow042185>1220>12386>1{86504:" #(*print-readably* #fn("5000n0Aw0:" #(*print-readably*))+ #fn("7000n02071A62:" #(#fn(for-each) write))+ #fn("6000n1A50420061:" #(#fn(raise)))) princ)+ print #fn("9000z02071062:" #(#fn(for-each) write) print) print-exception+ #fn("=000n10B3e00<20C^0710r3523T072230T2425760515127554787605151@\x0e00B3Z00<29CS0710r3523I0722:760512;534780T51@\xe100B3P00<2<CI0710r2523?0722=0T2>53@\xbe00B3I00<2?CB0722@514720=f2@\xa200B3N00<2ACG07B76051514722C0T52@\x8107D0513m0710r2523c0780<51472275140T2E8551;I60485R37072@40788551^1@>0722F514780514727G61:" #(type-error+ length= princ "type error: expected " ", got " #fn(typeof) caddr ": " print bounds-error "index "
+ " out of bounds for " unbound-error "eval: variable " " has no value" error "error: " load-error
+ print-exception "in file " list? #fn(string?) "*** Unhandled exception: " *linefeed*) print-exception)
+ print-stack-trace #fn("@000n1\x8d\x8d\x8a5\x8a620852185>1_51420862285>1_51473740r3523F075076370r5@40r452@300517778292:2;505252E\x8a92<2=868889>38762:" #(#0#+ #fn("=000n32005182P2105121151C?022232487e361:25051E76278851512888A187>4|:" #(#fn(function:name)+ #fn(function:code)
+ #fn(raise)
+ thrown-value ffound
+ #fn(function:vals)
+ 1- #fn(length)
+ #fn("8000n170A0G513>0F<A0G929363:O:" #(closure?))) find-in-f)+ #fn(":000n220A01>321{863E0722374758651522662:27:" #(#fn("8000n02021AF>292524O:" #(#fn(for-each)+ #fn("8000n1A<0Fq63:" #())))+ #fn("6000n10B3F00<20C?00T21C8072061:23061:" #(thrown-value+ ffound caddr #fn(raise))) string-join #fn(map) string reverse! "/" "λ") fn-name) reverse! length>
+ list-tail *interactive* filter closure? #fn(map) #fn("6000n10Z;380420061:" #(#fn(top-level-value)))+ #fn(environment) #fn(for-each) #fn("9000n17021A<0KGF52524222374051==52470257652492<El23?0770KG0EG52@30O49292<KM_:" #(princ+ "(" #fn(for-each) #fn("6000n1702151472061:" #(princ " " print)) vector->list ")" *linefeed*+ disassemble))) print-stack-trace)
+ print-to-string #fn("8000n1205021085524228561:" #(#fn(buffer)+ #fn(write)
+ #fn(iostream->string)) print-to-string)
+ printable? #fn("6000n120051;IB0471051;I80422051S:" #(#fn(iostream?) void? #fn(eof-object?)) printable?)+ procedure? #.function? putprop
+ #fn(";000n320711O5387360O@F02250237118853488?7^14238708253482:" #(#fn(get) *properties*+ #fn(table)
+ #fn(put!)) putprop)
+ quote-value #fn("6000n1700513400:210e2:" #(self-evaluating? quote) quote-value) quoted?+ #fn("6000n10<20Q:" #(quote) quoted?) random #fn("7000n1200513<0712250062:23500i2:" #(#fn(integer?)+ mod #fn(rand) #fn(rand-double)) random)
+ read-all #fn("7000n17071062:" #(read-all-of read) read-all) read-all-of+ #fn(":000n2\x8d\x8a686201860>3_486<^1q015162:" #(#fn("8000n220A5138071061:F<10P92A5162:" #(#fn(io-eof?)+ reverse!))) read-all-of)
+ ref-int16-LE #fn(":000n2202101EMGE522101KMGr852M61:" #(#fn(int16)+ #fn(ash)) ref-int16-LE)
+ ref-int32-LE #fn("<000n2202101EMGE522101KMGr8522101r2MGr@522101r3MGrH52g461:" #(#fn(int32)+ #fn(ash)) ref-int32-LE)
+ remprop #fn("8000n220711O5386;3F042286052;3:042386062:" #(#fn(get) *properties* #fn(has?)+ #fn(del!)) remprop)
+ repl #fn(";000n0\x8d\x8d\x8a4\x8a5208421_5142085228485>2_51485<5047360:" #(#0#+ #fn("9000n07050421725142324{257651S;3Z04778451788551360O@=079855147:5047;85w<61:" #(*prompt*+ #fn(io-flush) *output-stream* #fn("5000n02060:" #(#fn(read)))+ #fn("6000n1207151422061:" #(#fn(io-discardbuffer) *input-stream* #fn(raise)))+ #fn(io-eof?) *input-stream* load-process void? print newline void that) prompt)
+ #fn("6000n020A>121{370F<60:O:" #(#fn("5000n0A<60:" #())+ #fn("6000n1700514D:" #(top-level-exception-handler))) reploop) newline) repl)+ revappend #fn("7000n2701062:" #(reverse-) revappend) reverse+ #fn("7000n170q062:" #(reverse-) reverse) reverse! #fn("7000n170q062:" #(reverse!-) reverse!)+ reverse!- #fn("8000n2\x8d1B3B041=101?04N4?1@\x1d/40:" #() reverse!-) reverse-+ #fn("7000n21J400:701<0P1=62:" #(reverse-) reverse-) self-evaluating? #fn("7000n10H;36040RS;IK0420051;3A040R;3:04021051Q:" #(#fn(constant?)+ #fn(top-level-value)) self-evaluating?)
+ set-syntax! #fn("8000n220710163:" #(#fn(put!)+ *syntax-environment*) set-syntax!)
+ simple-sort #fn("9000n10V;I6040=V3400:0<7021850>22285>162:" #(call-with-values #fn("7000n07021A>1F=62:" #(partition+ #fn("6000n10AL2:" #()))) #fn("9000n22071051Ae17115163:" #(#fn(nconc) simple-sort))) simple-sort)+ splice-form? #fn("7000n10B;3X040<20Q;IN040<21Q;ID040<22Q;3:04730r252;I704022Q:" #(unquote-splicing+ unquote-nsplicing unquote length>) splice-form?)
+ string-join #fn("9000n20J5020:215022860<5242324861>20=524258661:" #("" #fn(buffer)+ #fn(io-write)
+ #fn(for-each)
+ #fn("7000n120AF52420A062:" #(#fn(io-write)))+ #fn(iostream->string)) string-join)
+ string-lpad #fn(":000n3207182122051~52062:" #(#fn(string) string-rep #fn(string-length)) string-lpad)+ string-map #fn("=000n2205021151E\x8d8887L23O0422860231885251524748851?8@\x0c/^14258661:" #(#fn(buffer)+ #fn(string-length) #fn(io-putc) #fn(string-char) 1+ #fn(iostream->string)) string-map)
+ string-rep #fn(":000n21r4L23b0701E5235021:1Kl238022061:1r2l2390220062:2200063:731513@02207401K~5262:742200521r2j262:" #(<=+ "" #fn(string) odd? string-rep) string-rep)
+ string-rpad #fn(";000n32007182122051~5262:" #(#fn(string) string-rep #fn(string-length)) string-rpad)+ string-tail #fn("7000n2200162:" #(#fn(string-sub)) string-tail) string-trim+ #fn(">000n3\x8d\x8d\x8a7\x8a820872187>1_51420882288>1_5142305124087<01E895488<082895363:" #(#0#+ #fn("9000n48283L23P02012108252523A0A<017282518364:82:" #(#fn(string-find)+ #fn(string-char) 1+) trim-start)
+ #fn(":000n3E82L23R020121072825152523?0A<0172825163:82:" #(#fn(string-find)+ #fn(string-char) 1-) trim-end)
+ #fn(string-length) #fn(string-sub)) string-trim)
+ symbol-set-doc #fn("A000z213=070021153@30O482B3H0700222374022q53825263:O:" #(putprop+ *doc* *funvars* #fn(append) getprop) symbol-set-doc)
+ symbol-syntax #fn("8000n120710O63:" #(#fn(get)+ *syntax-environment*) symbol-syntax)
+ table-clone #fn("9000n12050212285>1q053485:" #(#fn(table)+ #fn(table-foldl)
+ #fn("8000n320A0163:" #(#fn(put!)))) table-clone)+ table-invert #fn("9000n12050212285>1q053485:" #(#fn(table)+ #fn(table-foldl)
+ #fn("8000n320A1063:" #(#fn(put!)))) table-invert)+ table-keys #fn("8000n12021q063:" #(#fn(table-foldl)+ #fn("6000n3082P:" #())) table-keys)+ table-pairs #fn("8000n12021q063:" #(#fn(table-foldl)+ #fn("6000n301P82P:" #())) table-pairs)+ table-values #fn("8000n12021q063:" #(#fn(table-foldl)+ #fn("6000n3182P:" #())) table-values)+ to-proper #fn("7000n10J400:0H3600e1:0<700=51P:" #(to-proper) to-proper)+ top-level-bound? #.bound? top-level-exception-handler
+ #fn("9000n17071w042285>1230>12486>1{86504:" #(*output-stream* *stderr* #fn("5000n0Aw0:" #(*output-stream*))+ #fn("6000n070A51471225061:" #(print-exception+ print-stack-trace
+ #fn(stacktrace)))
+ #fn("6000n1A50420061:" #(#fn(raise)))) top-level-exception-handler)+ trace #fn("A000n1200512150728551Ig0230742586262728290e286e3e22:e12;2985e286e3e4e35152@30O^1^147<60:" #(#fn(top-level-value)+ #fn(gensym) traced? #fn(set-top-level-value!) eval λ begin write cons quote newline apply void) trace)
+ traced? #fn("7000n170051;3?042105121A<51d:" #(closure? #fn(function:code)) #((#fn("9000z020210P51472504230}2:" #(#fn(write)+ x newline #.apply)))))
+ untrace #fn("9000n1200517185513C0220238551r3G52@30O^147460:" #(#fn(top-level-value)+ traced? #fn(set-top-level-value!)
+ #fn(function:vals) void) untrace)
+ value-get-doc #fn("8000n10<0=208551;3=0486B;350485:" #(#fn(string?)) value-get-doc)+ values #fn("8000z00B3:00=J500<:A0P:" #() #(#3#)) vars-to-env+ #fn(":000n32021182>2072230515163:" #(#fn(map)+ #fn("9000n2700210A52SS1FM63:" #(vinfo #fn(memq)))+ iota #fn(length)) vars-to-env)
+ vector->list #fn("<000n120051q\x8a6K852186085>3|486<:" #(#fn(length)+ #fn("8000n1AF920~GA<P_:" #())) vector->list)+ vector-map #fn("<000n220151218651E86K~228701>3|487:" #(#fn(length)+ #fn(vector-alloc)
+ #fn("9000n1A0F920G51p:" #())) vector-map)+ vinfo #fn("7000n30182e3:" #() vinfo) vinfo:heap? #.cadr vinfo:index+ #4# vinfo:sym #.car void
+ #1# void? #fn("6000n10\x8dQ:" #() void?) zero?+ #fn("6000n10El2:" #() zero?))binary files /dev/null b/boot/flisp.boot.builtin differ
--- a/boot2h.sh
+++ /dev/null
@@ -1,3 +1,0 @@
-#!/bin/sh
-set -e
-od -t x1 -v -A n $* | sed -E 's/^[^ ]*[ ]+/ /g;s/[ ]+([^ ]+)/0x\1,/g'
--- a/bootstrap.sh
+++ /dev/null
@@ -1,12 +1,0 @@
-#!/bin/sh
-test -e
-F=./build/flisp
-test -x $F || { CC=clang meson setup -Dbuildtype=debug build . && ninja -C build || exit 1; }-test -x $F || { echo no $F found; exit 1; }-$F gen.lsp && \
-cp flisp.boot flisp.boot.bak && \
-$F mkboot0.lsp builtins.lsp instructions.lsp system.lsp compiler.lsp > flisp.boot && \
-cp flisp.boot flisp.boot.builtin && \
-ninja -C build && \
-$F mkboot1.lsp && \
-ninja -C build || { cp flisp.boot.bak flisp.boot; exit 1; }--- a/builtins.c
+++ /dev/null
@@ -1,508 +1,0 @@
-/*
- Extra femtoLisp builtin functions
-*/
-
-#include "flisp.h"
-#include "operators.h"
-#include "cvalues.h"
-#include "timefuncs.h"
-#include "table.h"
-#include "random.h"
-#include "nan.h"
-
-#define DBL_MAXINT (1LL<<53)
-#define FLT_MAXINT (1<<24)
-
-size_t
-llength(value_t v)
-{- size_t n = 0;
- while(iscons(v)){- n++;
- v = cdr_(v);
- }
- return n;
-}
-
-BUILTIN("nconc", nconc)-{- if(nargs == 0)
- return FL_nil;
-
- value_t lst, first = FL_nil;
- value_t *pcdr = &first;
- cons_t *c;
- uint32_t i = 0;
-
- while(1){- lst = args[i++];
- if(i >= nargs)
- break;
- if(iscons(lst)){- *pcdr = lst;
- c = ptr(lst);
- while(iscons(c->cdr))
- c = ptr(c->cdr);
- pcdr = &c->cdr;
- }else if(lst != FL_nil)
- type_error("cons", lst);- }
- *pcdr = lst;
- return first;
-}
-
-fl_purefn
-BUILTIN("assq", assq)-{- argcount(nargs, 2);
-
- value_t item = args[0];
- value_t v = args[1];
- value_t bind;
-
- while(iscons(v)){- bind = car_(v);
- if(iscons(bind) && car_(bind) == item)
- return bind;
- v = cdr_(v);
- }
- return FL_f;
-}
-
-fl_purefn
-BUILTIN("memq", memq)-{- argcount(nargs, 2);
-
- value_t v;
- cons_t *c;
- for(v = args[1]; iscons(v); v = c->cdr){- if((c = ptr(v))->car == args[0])
- return v;
- }
- return FL_f;
-}
-
-BUILTIN("length", length)-{- argcount(nargs, 1);
-
- value_t a = args[0];
- cvalue_t *cv;
-
- if(iscons(a)){- size_t n = 0;
- value_t v = a, v2 = a;
- do{- n++;
- v = cdr_(v);
- v2 = cdr_(v2);
- if(iscons(v2))
- v2 = cdr_(v2);
- }while(iscons(v) && iscons(v2) && v != v2);
- if(iscons(v2))
- return mk_double(D_PINF);
- n += llength(v);
- return size_wrap(n);
- }
- if(iscprim(a)){- cv = ptr(a);
- if(cp_class(cv) == FL(bytetype))
- return fixnum(1);
- if(cp_class(cv) == FL(runetype))
- return fixnum(runelen(*(Rune*)cp_data(cv)));
- }
- if(iscvalue(a) && cv_class(ptr(a))->eltype != nil)
- return size_wrap(cvalue_arraylen(a));
- if(isvector(a))
- return size_wrap(vector_size(a));
- if(ishashtable(a)){- htable_t *h = totable(a);
- void **t = h->table;
- size_t sz = h->size;
- size_t n = 0;
- for(size_t i = 0; i < sz; i += 2){- if(t[i+1] != HT_NOTFOUND)
- n++;
- }
- return size_wrap(n);
- }
- if(a == FL_nil)
- return fixnum(0);
- type_error("sequence", a);-}
-
-_Noreturn
-BUILTIN("raise", raise)-{- argcount(nargs, 1);
- fl_raise(args[0]);
-}
-
-_Noreturn
-BUILTIN("exit", exit)-{- if(nargs > 1)
- argcount(nargs, 1);
- fl_exit(nargs > 0 ? tofixnum(args[0]) : 0);
-}
-
-BUILTIN("symbol", symbol)-{- argcount(nargs, 1);
- if(fl_unlikely(!fl_isstring(args[0])))
- type_error("string", args[0]);- return symbol(cvalue_data(args[0]), true);
-}
-
-fl_purefn
-BUILTIN("keyword?", keywordp)-{- argcount(nargs, 1);
- return (issymbol(args[0]) && iskeyword((symbol_t*)ptr(args[0]))) ? FL_t : FL_f;
-}
-
-fl_purefn
-BUILTIN("top-level-value", top_level_value)-{- argcount(nargs, 1);
- symbol_t *sym = tosymbol(args[0]);
- if(sym->binding == UNBOUND)
- unbound_error(args[0]);
- return sym->binding;
-}
-
-BUILTIN("set-top-level-value!", set_top_level_value)-{- argcount(nargs, 2);
- symbol_t *sym = tosymbol(args[0]);
- if(!isconstant(sym))
- sym->binding = args[1];
- return args[1];
-}
-
-BUILTIN("makunbound", makunbound)-{- argcount(nargs, 1);
- symbol_t *sym = tosymbol(args[0]);
- if(!isconstant(sym))
- sym->binding = UNBOUND;
- return FL_void;
-}
-
-BUILTIN("environment", environment)-{- USED(args);
- argcount(nargs, 0);
- value_t lst = FL_nil;
- fl_gc_handle(&lst);
- const char *k = nil;
- symbol_t *v;
- while(Tnext(FL(symtab), &k, (void**)&v)){- if(v->binding != UNBOUND && (v->flags & FLAG_KEYWORD) == 0)
- lst = fl_cons(tagptr(v, TAG_SYM), lst);
- }
- fl_free_gc_handles(1);
- return lst;
-}
-
-fl_purefn
-BUILTIN("constant?", constantp)-{- argcount(nargs, 1);
- if(issymbol(args[0]))
- return isconstant((symbol_t*)ptr(args[0])) ? FL_t : FL_f;
- if(iscons(args[0])){- if(car_(args[0]) == FL_quote)
- return FL_t;
- return FL_f;
- }
- return FL_t;
-}
-
-fl_purefn
-BUILTIN("integer-valued?", integer_valuedp)-{- argcount(nargs, 1);
- value_t v = args[0];
- if(isfixnum(v))
- return FL_t;
- if(iscprim(v)){- numerictype_t nt = cp_numtype(ptr(v));
- if(nt < T_FLOAT)
- return FL_t;
- void *data = cp_data(ptr(v));
- if(nt == T_FLOAT){- float f = *(float*)data;
- if(f < 0)
- f = -f;
- if(f <= FLT_MAXINT && (float)(int32_t)f == f)
- return FL_t;
- }else{- assert(nt == T_DOUBLE);
- double d = *(double*)data;
- if(d < 0)
- d = -d;
- if(d <= DBL_MAXINT && (double)(int64_t)d == d)
- return FL_t;
- }
- }
- return FL_f;
-}
-
-fl_purefn
-BUILTIN("integer?", integerp)-{- argcount(nargs, 1);
- value_t v = args[0];
- return (isfixnum(v) ||
- (iscprim(v) && cp_numtype(ptr(v)) < T_FLOAT)) ?
- FL_t : FL_f;
-}
-
-fl_purefn
-BUILTIN("bignum?", bignump)-{- argcount(nargs, 1);
- value_t v = args[0];
- return (iscvalue(v) && cp_numtype(ptr(v)) == T_MPINT) ?
- FL_t : FL_f;
-}
-
-BUILTIN("fixnum", fixnum)-{- argcount(nargs, 1);
- value_t v = args[0];
- if(isfixnum(v))
- return v;
- void *p = ptr(v);
- if(iscprim(v))
- return fixnum(conv_to_int64(cp_data(p), cp_numtype(p)));
- if(iscvalue(v) && cp_numtype(p) == T_MPINT)
-#ifdef BITS64
- return fixnum(mptov(*(mpint**)cv_data(p)));
-#else
- return fixnum(mptoi(*(mpint**)cv_data(p)));
-#endif
- type_error("number", v);-}
-
-BUILTIN("truncate", truncate)-{- argcount(nargs, 1);
- if(isfixnum(args[0]))
- return args[0];
- if(iscprim(args[0])){- cprim_t *cp = ptr(args[0]);
- void *data = cp_data(cp);
- numerictype_t nt = cp_numtype(cp);
- double d;
- if(nt == T_FLOAT)
- d = (double)*(float*)data;
- else if(nt == T_DOUBLE)
- d = *(double*)data;
- else
- return args[0];
-
- if(d > 0){- if(d > (double)INT64_MAX)
- return args[0];
- return return_from_uint64((uint64_t)d);
- }
- if(d > (double)INT64_MAX || d < (double)INT64_MIN)
- return args[0];
- return return_from_int64((int64_t)d);
- }
- type_error("number", args[0]);-}
-
-BUILTIN("vector-alloc", vector_alloc)-{- size_t i, k, a;
- value_t f, v;
- if(nargs < 1)
- argcount(nargs, 1);
- i = tosize(args[0]);
- v = alloc_vector(i, 0);
- a = 1;
- for(k = 0; k < i; k++){- f = a < nargs ? args[a] : FL_void;
- vector_elt(v, k) = f;
- if((a = (a + 1) % nargs) < 1)
- a = 1;
- }
- return v;
-}
-
-BUILTIN("time-now", time_now)-{- argcount(nargs, 0);
- USED(args);
- return mk_double(sec_realtime());
-}
-
-BUILTIN("nanoseconds-monotonic", nanoseconds_monotonic)-{- argcount(nargs, 0);
- USED(args);
- return mk_uint64(nanosec_monotonic());
-}
-
-double
-todouble(value_t a)
-{- if(isfixnum(a))
- return (double)numval(a);
- if(iscprim(a)){- cprim_t *cp = ptr(a);
- numerictype_t nt = cp_numtype(cp);
- return conv_to_double(cp_data(cp), nt);
- }
- type_error("number", a);-}
-
-BUILTIN("time->string", time_string)-{- argcount(nargs, 1);
- double t = todouble(args[0]);
- char buf[64];
- timestring(t, buf, sizeof(buf));
- return string_from_cstr(buf);
-}
-
-BUILTIN("string->time", string_time)-{- argcount(nargs, 1);
- char *ptr = tostring(args[0]);
- double t = parsetime(ptr);
- int64_t it = (int64_t)t;
- if((double)it == t && fits_fixnum(it))
- return fixnum(it);
- return mk_double(t);
-}
-
-BUILTIN("path-cwd", path_cwd)-{- if(nargs > 1)
- argcount(nargs, 1);
- if(nargs == 0){- char buf[4096];
- if(getcwd(buf, sizeof(buf)) == nil)
- lerrorf(FL_IOError, "could not get current dir");
- return string_from_cstr(buf);
- }
- char *ptr = tostring(args[0]);
- if(chdir(ptr) != 0)
- lerrorf(FL_IOError, "could not cd to %s", ptr);
- return FL_void;
-}
-
-BUILTIN("path-exists?", path_existsp)-{- argcount(nargs, 1);
- const char *path = tostring(args[0]);
- return access(path, F_OK) == 0 ? FL_t : FL_f;
-}
-
-BUILTIN("delete-file", delete_file)-{- argcount(nargs, 1);
- const char *path = tostring(args[0]);
- if(remove(path) != 0)
- lerrorf(FL_IOError, "could not remove %s", path);
- return FL_void;
-}
-
-BUILTIN("os-getenv", os_getenv)-{- argcount(nargs, 1);
- char *name = tostring(args[0]);
- char *val = getenv(name);
- if(val == nil)
- return FL_f;
- return cvalue_static_cstring(val);
-}
-
-BUILTIN("os-setenv", os_setenv)-{- argcount(nargs, 2);
- char *name = tostring(args[0]);
- int result;
- if(args[1] == FL_f)
- result = unsetenv(name);
- else{- char *val = tostring(args[1]);
- result = setenv(name, val, 1);
- }
- if(result != 0)
- lerrorf(FL_ArgError, "invalid environment variable");
- return FL_t;
-}
-
-BUILTIN("rand", rand)-{- USED(args); USED(nargs);
-#ifdef BITS64
- uint64_t x = genrand_uint64();
-#else
- uint32_t x = genrand_uint32();
-#endif
- return fixnum(x >> 3);
-}
-
-BUILTIN("rand-uint32", rand_uint32)-{- USED(args); USED(nargs);
- return mk_uint32(genrand_uint32());
-}
-
-BUILTIN("rand-uint64", rand_uint64)-{- USED(args); USED(nargs);
- return mk_uint64(genrand_uint64());
-}
-
-BUILTIN("rand-double", rand_double)-{- USED(args); USED(nargs);
- return mk_double(genrand_double());
-}
-
-BUILTIN("rand-float", rand_float)-{- USED(args); USED(nargs);
- return mk_float(genrand_double());
-}
-
-#define BUILTIN_(lname, cname) \
- BUILTIN(lname, cname) \
- { \- argcount(nargs, 1); \
- return mk_double(cname(todouble(args[0]))); \
- }
-
-BUILTIN_("sqrt", sqrt)-BUILTIN_("exp", exp)-BUILTIN_("log", log)-BUILTIN_("log10", log10)-BUILTIN_("sin", sin)-BUILTIN_("cos", cos)-BUILTIN_("tan", tan)-BUILTIN_("asin", asin)-BUILTIN_("acos", acos)-BUILTIN_("atan", atan)-BUILTIN_("floor", floor)-BUILTIN_("ceiling", ceil)-BUILTIN_("sinh", sinh)-BUILTIN_("cosh", cosh)-BUILTIN_("tanh", tanh)-
-#undef BUILTIN_
-#define BUILTIN_(lname, cname) \
- BUILTIN(lname, cname) \
- { \- argcount(nargs, 2); \
- return mk_double(cname(todouble(args[0]), todouble(args[1]))); \
- }
-
-BUILTIN_("expt", pow)--- a/builtins2h.sh
+++ /dev/null
@@ -1,7 +1,0 @@
-#!/bin/sh
-set -e
-awk -F '[()]' '\
- /^fl_.*fn/ {attr=$1; next} \- /^_Noreturn/ {attr=$1; next} \- /^BUILTIN[_]?/ {printf "BUILTIN_FN(%s, %s)\n", $2, attr} \- {attr=""}' $* | sort--- a/builtins_plan9.c
+++ /dev/null
@@ -1,11 +1,0 @@
-#include "platform.h"
-
-int
-fl_clz(uint32_t x)
-{- uint32_t r;
- if(x == 0)
- return 32;
- for(r = 0; (x & (1UL<<31)) == 0; x <<= 1, r++);
- return r;
-}
--- a/builtins_plan9_amd64.s
+++ /dev/null
@@ -1,4 +1,0 @@
-TEXT fl_clz(SB),1,$0
- BYTE $0x0F; BYTE $0xBD; BYTE $0xC5 /* BSRL RARG, AX */
- XORL $31, AX
- RET
--- a/builtins_plan9_arm64.s
+++ /dev/null
@@ -1,3 +1,0 @@
-TEXT fl_clz(SB),1,$0
- CLZW R0, R0
- RETURN
--- a/cc.h
+++ /dev/null
@@ -1,58 +1,0 @@
-#pragma once
-
-#ifdef __GNUC__
-
-#define fl_unlikely(x) __builtin_expect(!!(x), 0)
-#define fl_likely(x) __builtin_expect(!!(x), 1)
-#define fl_printfmt(x, y) __attribute__((format(printf, x, y)))
-#if defined(NDEBUG) && !defined(__macos__) && !defined(__dos__)
-#define fl_thread(x) __thread x
-#else
-#define fl_thread(x) x
-#endif
-#define fl_prefetch(x) __builtin_prefetch(x)
-#define fl_constfn __attribute__((const))
-#define fl_purefn __attribute__((pure))
-#define fl_hotfn __attribute__((hot))
-#define fl_aligned(x) __attribute__((aligned(x)))
-#define fl_popcount(x) __builtin_popcount(x)
-#define fl_clz(x) __builtin_clz(x)
-#define sadd_overflow __builtin_add_overflow
-#define sadd_overflow_64 __builtin_add_overflow
-#define smul_overflow_64 __builtin_mul_overflow
-
-#else
-
-#define fl_unlikely(x) (x)
-#define fl_likely(x) (x)
-#define fl_printfmt(x, y)
-#define fl_thread(x) x
-#define fl_prefetch(x)
-#define fl_constfn
-#define fl_purefn
-#define fl_hotfn
-#define fl_aligned(x)
-
-/* FIXME(sigrid): s*_overflow_* can be more optimal */
-#define sadd_overflow_64(a, b, c) ( \
- (b < 1) ? \
- ((INT64_MAX-(b) <= (a)) ? ((*(c)=(a)+(b)), 0) : 1) : \
- ((INT64_MAX-(b) >= (a)) ? ((*(c)=(a)+(b)), 0) : 1) \
-)
-#define smul_overflow_64(a, b, c) ( \
- ((a)>0 ? ((b)>0 ? (a)>INT64_MAX/(b) : (b)<INT64_MIN/(a)) \
- : ((b)>0 ? (a)<INT64_MIN/(b) : ((a)!=0 && (b)<INT64_MAX/(a)))) \
- ? 1 \
- : ((*(c)=(a)*(b)), 0) \
-)
-#if defined(BITS64)
-#define sadd_overflow(a, b, c) sadd_overflow_64(a, b, c)
-#else
-#define sadd_overflow(a, b, c) ( \
- (b < 1) ? \
- ((INT32_MAX-(b) <= (a)) ? ((*(c)=(a)+(b)), 0) : 1) : \
- ((INT32_MAX-(b) >= (a)) ? ((*(c)=(a)+(b)), 0) : 1) \
-)
-#endif
-
-#endif
--- a/compiler.lsp
+++ /dev/null
@@ -1,881 +1,0 @@
-; -*- scheme -*-
-
-;; code generation state, constant tables, bytecode encoding
-
-(define (make-code-emitter) (vector () (table) 0 () 0))
-(define-macro (bcode:code b) `(aref ,b 0))
-(define-macro (bcode:ctable b) `(aref ,b 1))
-(define-macro (bcode:nconst b) `(aref ,b 2))
-(define-macro (bcode:cenv b) `(aref ,b 3))
-(define-macro (bcode:sp b) `(aref ,b 4))
-(define-macro (bcode:stack b n) `(aset! ,b 4 (+ (bcode:sp ,b) ,n)))
-
-;; 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)))
- (if (has? const-to-idx v)
- (get const-to-idx v)
- (begin (put! const-to-idx v nconst)
- (prog1 nconst
- (aset! b 2 (+ nconst 1)))))))
-
-(define (emit e inst . args)
- (define (load? i)
- (member i '(load0 load1 loadt loadf loadnil loadvoid))) ; FIXME no load immediate here yet
- (let ((bc (aref e 0)))
- (if (null? args)
- (if (and (eq? inst 'car)
- (eq? (car bc) 'cdr))
- (set-car! bc 'cadr)
- (cond ((and (eq? inst 'pop) (load? (car bc)))
- (aset! e 0 (cdr bc)))
- (else
- (aset! e 0 (cons inst bc)))))
- (begin
- (if (memq inst '(loadv loadg setg))
- (set! args (list (bcode:indexfor e (car args)))))
- (let ((longform
- (assq inst '((loadv loadv.l) (loadg loadg.l) (setg setg.l)
- (loada loada.l) (seta seta.l) (box box.l)))))
- (if (and longform
- (> (car args) 255))
- (set! inst (cadr longform))))
- (let ((longform
- (assq inst '((loadc loadc.l)))))
- (if (and longform (> (car args) 255))
- (set! inst (cadr longform))))
- (if (eq? inst 'loada)
- (cond ((equal? args '(0))
- (set! inst 'loada0)
- (set! args ()))
- ((equal? args '(1))
- (set! inst 'loada1)
- (set! args ()))))
- (if (eq? inst 'loadc)
- (cond ((equal? args '(0))
- (set! inst 'loadc0)
- (set! args ()))
- ((equal? args '(1))
- (set! inst 'loadc1)
- (set! args ()))))
-
- (let ((lasti (car bc)))
- (cond ((and (eq? inst 'brf)
- (cond ((and (eq? lasti 'not)
- (eq? (cadr bc) 'null?))
- (aset! e 0 (cons (car args) (cons 'brn (cddr bc)))))
- ((eq? lasti 'not)
- (aset! e 0 (cons (car args) (cons 'brt (cdr bc)))))
- ((eq? lasti 'eq?)
- (aset! e 0 (cons (car args) (cons 'brne (cdr bc)))))
- ((eq? lasti 'null?)
- (aset! e 0 (cons (car args) (cons 'brnn (cdr bc)))))
- (else #f))))
- ((and (eq? inst 'brt) (eq? lasti 'null?))
- (aset! e 0 (cons (car args) (cons 'brn (cdr bc)))))
- (else
- (aset! e 0 (nreconc (cons inst args) bc)))))))
- e))
-
-(define-macro (make-label e) `(gensym))
-(define-macro (mark-label e l) `(emit ,e 'label ,l))
-
-;; 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
- (* 3 (div0 (length v) 2)))
- 65536)))
- (let ((n (length v))
- (i 0)
- (label-to-loc (table))
- (fixup-to-label (table))
- (bcode (buffer))
- (vi #f)
- (nxt #f))
- (io-write bcode #int32(0))
- (while (< i n)
- (begin
- (set! vi (aref v i))
- (if (eq? vi 'label)
- (begin (put! label-to-loc (aref v (+ i 1)) (sizeof bcode))
- (set! i (+ i 2)))
- (begin
- (io-write bcode
- (byte
- (get Instructions
- (if long?
- (case vi
- (jmp 'jmp.l)
- (brt 'brt.l)
- (brf 'brf.l)
- (brne 'brne.l)
- (brnn 'brnn.l)
- (brn 'brn.l)
- (else vi))
- vi))))
- (set! i (+ i 1))
- (set! nxt (if (< i n) (aref v i) #f))
- (cond ((memq vi '(jmp brf brt brne brnn brn))
- (put! fixup-to-label (sizeof bcode) nxt)
- (io-write bcode ((if long? int32 int16) 0))
- (set! i (+ i 1)))
- ((eq? vi 'brbound)
- (io-write bcode (int32 nxt))
- (set! i (+ i 1)))
- ((number? nxt)
- (case vi
- ((loadv.l loadg.l setg.l loada.l seta.l
- largc lvargc call.l tcall.l loadc.l box.l)
- (io-write bcode (int32 nxt))
- (set! i (+ i 1)))
-
- ((optargs keyargs) ; 2 int32 args
- (io-write bcode (int32 nxt))
- (set! i (+ i 1))
- (io-write bcode (int32 (aref v i)))
- (set! i (+ i 1))
- (if (eq? vi 'keyargs)
- (begin (io-write bcode (int32 (aref v i)))
- (set! i (+ i 1)))))
-
- (else
- ; other number arguments are always uint8
- (io-write bcode (uint8 nxt))
- (set! i (+ i 1)))))
- (else #f))))))
-
- (for-each
- (λ (addr labl)
- (begin (io-seek bcode addr)
- (io-write bcode ((if long? int32 int16)
- (- (get label-to-loc labl)
- addr)))))
- fixup-to-label)
- (iostream->string bcode))))
-
-(define (const-to-idx-vec e)
- (let ((cvec (vector-alloc (bcode:nconst e))))
- (for-each (λ (val idx) (aset! cvec idx val))
- (bcode:ctable e))
- cvec))
-
-;; variables
-
-(define (vinfo sym heap? index) (list sym heap? index))
-(define vinfo:sym car)
-(define vinfo:heap? cadr)
-(define vinfo:index caddr)
-
-(define (quoted? e) (eq? (car e) 'quote))
-
-(define (capture-var! g sym)
- (let ((ce (bcode:cenv g)))
- (let ((n (index-of sym ce 0)))
- (or n
- (prog1 (length ce)
- (aset! g 3 (nconc ce (list sym))))))))
-
-(define (index-of item lst start)
- (cond ((null? lst) #f)
- ((eq? item (car lst)) start)
- (else (index-of item (cdr lst) (+ start 1)))))
-
-(define (in-env? s env)
- (and (cons? env)
- (or (assq s (car env))
- (in-env? s (cdr env)))))
-
-(define (lookup-sym s env lev)
- (if (null? env)
- 'global
- (let* ((curr (car env))
- (vi (assq s curr)))
- (if vi
- (cons lev vi)
- (lookup-sym s
- (cdr env)
- (+ lev 1))))))
-
-(define (printable? x) (not (or (iostream? x)
- (void? x)
- (eof-object? x))))
-
-(define (compile-sym g env s deref)
- (let ((loc (lookup-sym s env 0)))
- (cond ((eq? loc 'global)
- (if (and (constant? s)
- (printable? (top-level-value s)))
- (emit g 'loadv (top-level-value s))
- (emit g 'loadg s)))
-
- ((= (car loc) 0)
- (emit g 'loada (vinfo:index (cdr loc)))
- (if (and deref (vinfo:heap? (cdr loc)))
- (emit g 'car)))
-
- (else
- (emit g 'loadc (capture-var! g s))
- (if (and deref (vinfo:heap? (cdr loc)))
- (emit g 'car))))))
-
-(define (compile-aset! g env args)
- (let ((nref (- (length args) 2)))
- (cond ((= nref 1)
- (compile-app g env #f (cons 'aset! args)))
- ((> nref 1)
- (compile-app g env #f (cons 'aref (list-head args nref)))
- (let ((nargs (compile-arglist g env (list-tail args nref))))
- (bcode:stack g (- nargs))
- (emit g 'aset!)))
- (else (argc-error 'aset! 3)))))
-
-(define (compile-set! g env s rhs)
- (let ((loc (lookup-sym s env 0)))
- (if (eq? loc 'global)
- (begin (compile-in g env #f rhs)
- (emit g 'setg s))
- (let ((arg? (= (car loc) 0)))
- (let ((h? (vinfo:heap? (cdr loc)))
- (idx (if arg?
- (vinfo:index (cdr loc))
- (capture-var! g s))))
- (if h?
- (begin (emit g (if arg? 'loada 'loadc) idx)
- (bcode:stack g 1)
- (compile-in g env #f rhs)
- (bcode:stack g -1)
- (emit g 'set-car!))
-
- (begin (compile-in g env #f rhs)
- (if (not arg?) (error (string "internal error: misallocated var " s)))
- (emit g 'seta idx))))))))
-
-(define (box-vars g env)
- (let loop ((e env))
- (if (cons? e)
- (begin (if (cadr (car e))
- (emit g 'box (caddr (car e))))
- (loop (cdr e))))))
-
-;; control flow
-
-(define (compile-if g env tail? x)
- (let ((thenl (make-label g))
- (elsel (make-label g))
- (endl (make-label g))
- (test (cadr x))
- (then (caddr x))
- (else (if (cons? (cdddr x))
- (cadddr x)
- #f)))
- (cond ((eq? test #t)
- (compile-in g env tail? then))
- ((eq? test #f)
- (compile-in g env tail? else))
- (else
- (compile-in g env #f test elsel)
- (emit g 'brf elsel)
- (mark-label g thenl)
- (compile-in g env tail? then)
- (if tail?
- (emit g 'ret)
- (emit g 'jmp endl))
- (mark-label g elsel)
- (compile-in g env tail? else)
- (mark-label g endl)))))
-
-(define (compile-begin g env tail? forms)
- (cond ((atom? forms) (compile-in g env tail? (void)))
- ((atom? (cdr forms))
- (compile-in g env tail? (car forms)))
- (else
- (compile-in g env #f (car forms))
- (emit g 'pop)
- (compile-begin g env tail? (cdr forms)))))
-
-(define (compile-prog1 g env x)
- (compile-in g env #f (cadr x))
- (if (cons? (cddr x))
- (begin (bcode:stack g 1)
- (compile-begin g env #f (cddr x))
- (emit g 'pop)
- (bcode:stack g -1))))
-
-(define (compile-while g env cond body)
- (let ((top (make-label g))
- (end (make-label g)))
- (compile-in g env #f (void))
- (bcode:stack g 1)
- (mark-label g top)
- (compile-in g env #f cond)
- (emit g 'brf end)
- (emit g 'pop)
- (bcode:stack g -1)
- (compile-in g env #f body)
- (emit g 'jmp top)
- (mark-label g end)))
-
-(define (is-lambda? a)
- (or (eq? a 'λ)
- (eq? a 'lambda)))
-
-(define (1arg-lambda? func)
- (and (cons? func)
- (is-lambda? (car func))
- (length= (cadr func) 1)))
-
-(define (compile-short-circuit g env tail? forms default branch outl)
- (cond ((atom? forms) (compile-in g env tail? default outl))
- ((atom? (cdr forms)) (compile-in g env tail? (car forms) outl))
- (else
- (let ((end (or outl (make-label g))))
- (compile-in g env #f (car forms) outl)
- (bcode:stack g 1)
- (unless outl (emit g 'dup))
- (emit g branch end)
- (bcode:stack g -1)
- (unless outl (emit g 'pop))
- (compile-short-circuit g env tail? (cdr forms) default branch outl)
- (unless outl (mark-label g end))))))
-
-(define (compile-and g env tail? forms outl)
- (compile-short-circuit g env tail? forms #t 'brf outl))
-(define (compile-or g env tail? forms)
- (compile-short-circuit g env tail? forms #f 'brt #f))
-
-;; calls
-
-(define (compile-arglist g env lst)
- (for-each (λ (a)
- (compile-in g env #f a)
- (bcode:stack g 1))
- lst)
- (length lst))
-
-(define (argc-error head count)
- (error "compile error: " head " expects " count
- (if (= count 1)
- " argument."
- " arguments.")))
-
-(define builtin->instruction
- (let ((b2i (table number? 'number? cons 'cons
- fixnum? 'fixnum? equal? 'equal?
- eq? 'eq? symbol? 'symbol?
- div0 'div0 builtin? 'builtin?
- aset! 'aset! - '- boolean? 'boolean? not 'not
- apply 'apply atom? 'atom? nan? 'nan?
- set-cdr! 'set-cdr! / '/
- function? 'function? vector 'vector
- list 'list bound? 'bound?
- < '< * '* cdr 'cdr cadr 'cadr null? 'null?
- + '+ eqv? 'eqv? compare 'compare aref 'aref
- set-car! 'set-car! car 'car for 'for
- cons? 'cons? = '= vector? 'vector?)))
- (λ (b)
- (get b2i b #f))))
-
-(define (compile-builtin-call g env tail? x head b nargs)
- (define (num-compare)
- (if (= nargs 0)
- (argc-error b 1)
- (emit g b nargs)))
- (let ((count (get arg-counts b #f)))
- (if (and count
- (not (length= (cdr x) count)))
- (argc-error b count))
- (case b ; handle special cases of vararg builtins
- (list (if (= nargs 0)
- (emit g 'loadnil)
- (emit g b nargs)))
- (< (num-compare))
- (= (num-compare))
- (+ (cond ((= nargs 0) (emit g 'load0))
- ((= nargs 2) (emit g 'add2))
- (else (emit g b nargs))))
- (- (cond ((= nargs 0) (argc-error b 1))
- ((= nargs 1) (emit g 'neg))
- ((= nargs 2) (emit g 'sub2))
- (else (emit g b nargs))))
- (* (if (= nargs 0)
- (emit g 'load1)
- (emit g b nargs)))
- (/ (if (= nargs 0)
- (argc-error b 1)
- (emit g b nargs)))
- (vector (if (= nargs 0)
- (emit g 'loadv #())
- (emit g b nargs)))
- (apply (if (< nargs 2)
- (argc-error b 2)
- (emit g (if tail? 'tapply 'apply) nargs)))
- (aref (cond ((= nargs 2) (emit g 'aref2))
- ((> nargs 2) (emit g b (- nargs 3)))
- (else (argc-error b 2))))
- (else (emit g b)))))
-
-(define (inlineable? form)
- (let ((lam (car form)))
- (and (cons? lam)
- (is-lambda? (car lam))
- (list? (cadr lam))
- (every symbol? (cadr lam))
- (not (length> (cadr lam) 255))
- (length= (cadr lam) (length (cdr form))))))
-
-;; compile call to lambda in head position, inlined
-(define (compile-let g env tail? form)
- (let ((lam (car form))
- (args (cdr form))
- (sp (bcode:sp g)))
- (let ((vars (cadr lam))
- (n (compile-arglist g env args)))
- (let ((newvars
- (vars-to-env vars (complex-bindings (caddr lam) vars) sp)))
- (box-vars g newvars)
- (let ((newenv
- (cons (nconc newvars (car env))
- (cdr env))))
- (compile-in g newenv tail? (caddr lam))
- (bcode:stack g (- n))
- (if (and (> n 0) (not tail?))
- (emit g 'shift n)))))))
-
-(define (compile-app g env tail? x)
- (let ((head (car x)))
- (let ((head
- (if (and (symbol? head)
- (not (in-env? head env))
- (bound? head)
- (builtin? (top-level-value head)))
- (top-level-value head)
- head)))
- (if (length> (cdr x) 255)
- ;; more than 255 arguments, need long versions of instructions
- (begin (compile-in g env #f head)
- (bcode:stack g 1)
- (let ((nargs (compile-arglist g env (cdr x))))
- (bcode:stack g (- nargs))
- (emit g (if tail? 'tcall.l 'call.l) nargs)))
- (let ((b (and (builtin? head)
- (builtin->instruction head))))
- (if (and (eq? head 'cadr)
- (not (in-env? head env))
- (equal? (top-level-value 'cadr) cadr)
- (length= x 2))
- (begin (compile-in g env #f (cadr x))
- (emit g 'cadr))
- (if (and (cons? head)
- (is-lambda? (car head))
- (inlineable? x))
- (compile-let g env tail? x)
- (begin
- (unless b
- (compile-in g env #f head)
- (bcode:stack g 1))
- (let ((nargs (compile-arglist g env (cdr x))))
- (bcode:stack g (- nargs))
- (unless b (bcode:stack g -1))
- (if b
- (compile-builtin-call g env tail? x head b nargs)
- (emit g (if tail? 'tcall 'call) nargs)))))))))))
-
-;; lambda, main compilation loop
-
-(define (fits-i8 x) (and (fixnum? x) (>= 127 x -128)))
-
-(define (compile-in g env tail? x (outl #f))
- (cond ((symbol? x) (compile-sym g env x #t))
- ((atom? x)
- (cond ((eq? x 0) (emit g 'load0))
- ((eq? x 1) (emit g 'load1))
- ((eq? x #t) (emit g 'loadt))
- ((eq? x #f) (emit g 'loadf))
- ((eq? x nil) (emit g 'loadnil))
- ((void? x) (emit g 'loadvoid))
- ((fits-i8 x) (emit g 'loadi8 x))
- (else (emit g 'loadv x))))
- ((eq? (car x) 'aset!)
- (compile-aset! g env (cdr x)))
- ((or (not (symbol? (car x))) (bound? (car x)) (in-env? (car x) env))
- (compile-app g env tail? x))
- (else
- (case (car x)
- (quote (if (self-evaluating? (cadr x))
- (compile-in g env tail? (cadr x))
- (emit g 'loadv (cadr x))))
- (if (compile-if g env tail? x))
- (begin (compile-begin g env tail? (cdr x)))
- (prog1 (compile-prog1 g env x))
- (λ (receive (the-f cenv) (compile-f- env x)
- (begin (emit g 'loadv the-f)
- (if (not (null? cenv))
- (begin
- (for-each (λ (var)
- (compile-sym g env var #f))
- cenv)
- (emit g 'closure (length cenv)))))))
- (and (compile-and g env tail? (cdr x) outl))
- (or (compile-or g env tail? (cdr x)))
- (while (compile-while g env (cadr x) (cons 'begin (cddr x))))
- (return (compile-in g env #t (cadr x))
- (emit g 'ret))
- (set! (let* ((name (cadr x))
- (value (cddr x))
- (doc (value-get-doc value)))
- (unless (symbol? name)
- (error "set!: name must be a symbol"))
- (when doc
- (set! value (cdr value))
- (symbol-set-doc name doc (and (cons? (car value))
- (is-lambda? (car (car value)))
- (lambda:vars (car value)))))
- (compile-set! g env name (car value))))
- (trycatch (compile-in g env #f `(λ () ,(cadr x)))
- (unless (1arg-lambda? (caddr x))
- (error "trycatch: second form must be a 1-argument lambda"))
- (compile-in g env #f (caddr x))
- (emit g 'trycatch))
- (else (compile-app g env tail? x))))))
-
-;; optional and keyword args
-
-(define (keyword-arg? x) (and (cons? x) (keyword? (car x))))
-(define (keyword->symbol k)
- (if (keyword? k)
- (symbol (let ((s (string k)))
- (string-sub s 1 (string-length s))))
- k))
-
-(define (lambda-vars l)
- (define (check-formals l o opt kw)
- (cond ((or (null? l) (symbol? l)) #t)
- ((and (cons? l) (symbol? (car l)))
- (if (or opt kw)
- (error "compile error: invalid argument list "
- o ": optional arguments must come after required.")
- (check-formals (cdr l) o opt kw)))
- ((and (cons? l) (cons? (car l)))
- (unless (and (length= (car l) 2)
- (symbol? (caar l)))
- (error "compile error: invalid optional argument " (car l)
- " in list " o))
- (if (keyword? (caar l))
- (check-formals (cdr l) o opt #t)
- (if kw
- (error "compile error: invalid argument list "
- o ": keyword arguments must come last.")
- (check-formals (cdr l) o #t kw))))
- ((cons? l)
- (error "compile error: invalid formal argument " (car l)
- " in list " o))
- (else
- (if (eq? l o)
- (error "compile error: invalid argument list " o)
- (error "compile error: invalid formal argument " l
- " in list " o)))))
- (check-formals l l #f #f)
- (map (λ (s) (if (cons? s) (keyword->symbol (car s)) s))
- (to-proper l)))
-
-(define (emit-optional-arg-inits g env opta vars i)
- ; i is the lexical var index of the opt arg to process next
- (if (cons? opta)
- (let ((nxt (make-label g)))
- (emit g 'brbound i)
- (emit g 'brt nxt)
- (compile-in g (extend-env env (list-head vars i) '()) #f (cadar opta))
- (emit g 'seta i)
- (emit g 'pop)
- (mark-label g nxt)
- (emit-optional-arg-inits g env (cdr opta) vars (+ i 1)))))
-
-;; define
-
-(define (expand-define x)
- ;; expand a single `define` expression to `set!`
- (let* ((form (cadr x))
- (body (if (cons? (cddr x))
- (cddr x)
- (if (symbol? form)
- #.void
- (error "compile error: invalid syntax " (print-to-string x))))))
- (if (symbol? form)
- `(#.void (set! ,form ,(car body)))
- `(#.void (set! ,(car form)
- (λ ,(cdr form) ,@body . ,(car form)))))))
-
-(define get-defined-vars
- (letrec ((get-defined-vars-
- (λ (expr)
- (cond ((atom? expr) ())
- ((and (eq? (car expr) 'define)
- (cons? (cdr expr)))
- (or (and (symbol? (cadr expr))
- (list (cadr expr)))
- (and (cons? (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 (lower-define e)
- ;; convert lambda to one body expression and process internal defines
- (define (λ-body e)
- (let* ((B (if (cons? (cddr e))
- (if (cons? (cdddr e))
- (cons 'begin (cddr e))
- (caddr e))
- (void)))
- (V (get-defined-vars B))
- (new-B (lower-define B)))
- (if (null? V)
- new-B
- (cons `(λ ,V ,new-B)
- (map 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))))
-
-;; closure analysis
-
-(define (lambda:body e) (caddr e))
-(define (lambda:vars e) (lambda-vars (cadr e)))
-
-(define (diff s1 s2)
- (cond ((null? s1) '())
- ((memq (car s1) s2) (diff (cdr s1) s2))
- (else (cons (car s1) (diff (cdr s1) s2)))))
-
-;; bindings that are both captured and set!'d
-(define (complex-bindings- e vars head nested capt setd)
- (cond ((null? vars) #f)
- ((symbol? e)
- (if (and nested (memq e vars))
- (put! capt e #t)))
- ((or (atom? e) (quoted? e)) #f)
- ((eq? (car e) 'set!)
- (if (memq (cadr e) vars)
- (begin (put! setd (cadr e) #t)
- (if nested (put! capt (cadr e) #t))))
- (complex-bindings- (caddr e) vars #f nested capt setd))
- ((is-lambda? (car e))
- (complex-bindings- (lambda:body e)
- (diff vars (lambda:vars e))
- #f
- (or (not head) nested)
- capt setd))
- (else
- (cons (complex-bindings- (car e) vars (inlineable? e) nested capt setd)
- (map (λ (x)
- (complex-bindings- x vars #f nested capt setd))
- (cdr e))))))
-
-(define (complex-bindings e vars)
- (let ((capt (table))
- (setd (table)))
- (complex-bindings- e vars #f #f capt setd)
- (filter (λ (x) (has? capt x))
- (table-keys setd))))
-
-(define (vars-to-env vars cb offs)
- (map (λ (var i) (vinfo var (not (not (memq var cb))) (+ i offs)))
- vars (iota (length vars))))
-
-(define (extend-env env vars cb)
- (cons (vars-to-env vars cb 0)
- env))
-
-;; main entry points
-
-(define (compile f) (compile-f () (lower-define f)))
-
-(define (compile-thunk expr)
- ;; to eval a top-level expression we need to avoid internal define
- (compile-f () `(λ () ,(lower-define expr))))
-
-(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 f))
- (opta (filter cons? (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)))
-
- (let ((newenv (extend-env env vars (complex-bindings (lambda:body f) vars))))
- (box-vars g (car newenv))
- ;; set initial stack pointer
- (aset! g 4 (+ (length vars) 4))
- ;; compile body and return
- (compile-in g newenv #t (lambda:body f))
- (emit g 'ret)
- (values (function (encode-byte-code (bcode:code g))
- (const-to-idx-vec g) name)
- (bcode:cenv g))))))
-
-;; disassembler
-
-(define (ref-int32-LE a i)
- (int32 (+ (ash (aref a (+ i 0)) 0)
- (ash (aref a (+ i 1)) 8)
- (ash (aref a (+ i 2)) 16)
- (ash (aref a (+ i 3)) 24))))
-
-(define (ref-int16-LE a i)
- (int16 (+ (ash (aref a (+ i 0)) 0)
- (ash (aref a (+ i 1)) 8))))
-
-(define (hex5 n)
- (string-lpad (number->string n 16) 5 #\0))
-
-(define (disassemble f (ip #f) . lev?)
- (if (null? lev?)
- (begin (disassemble f ip 0)
- (newline)
- (return (void))))
- (let ((lev (car lev?))
- (code (function:code f))
- (vals (function:vals f)))
- (define (print-val v)
- (if (and (function? v) (not (builtin? v)))
- (begin (newline)
- (disassemble v #f (+ lev 1)))
- (print v)))
- (define (print-inst inst s sz) (princ (if (and ip (= lev 0) (>= ip (1- s)) (< ip (+ s sz)))
- " >"
- " ")
- (hex5 (- s 5)) ": "
- inst " "))
- (let ((i 4)
- (N (length code)))
- (while (< i N)
- ; find key whose value matches the current byte
- (let ((inst (table-foldl (λ (k v z)
- (or z (and (eq? v (aref code i))
- k)))
- #f Instructions)))
- (if (> i 4) (newline))
- (dotimes (xx lev) (princ "\t"))
- (set! i (+ i 1))
- (case inst
- ((loadv.l loadg.l setg.l)
- (print-inst inst i 4)
- (print-val (aref vals (ref-int32-LE code i)))
- (set! i (+ i 4)))
-
- ((loadv loadg setg)
- (print-inst inst i 1)
- (print-val (aref vals (aref code i)))
- (set! i (+ i 1)))
-
- ((loada seta loadc call tcall list + - * / < = vector
- argc vargc loadi8 apply tapply closure box shift aref)
- (print-inst inst i 1)
- (princ (number->string (+ (aref code i) (if (eq? inst 'aref) 3 0))))
- (set! i (+ i 1)))
-
- ((loada.l seta.l loadc.l largc lvargc call.l tcall.l box.l)
- (print-inst inst i 4)
- (princ (number->string (ref-int32-LE code i)))
- (set! i (+ i 4)))
-
- ((optargs keyargs)
- (print-inst inst i (+ 8 (if (eq? inst 'keyargs) 4 0)))
- (princ (number->string (ref-int32-LE code i)) " ")
- (set! i (+ i 4))
- (princ (number->string (ref-int32-LE code i)))
- (set! i (+ i 4))
- (if (eq? inst 'keyargs)
- (begin
- (princ " ")
- (princ (number->string (ref-int32-LE code i)) " ")
- (set! i (+ i 4)))))
-
- ((brbound)
- (print-inst inst i 4)
- (princ (number->string (ref-int32-LE code i)) " ")
- (set! i (+ i 4)))
-
- ((jmp brf brt brne brnn brn)
- (print-inst inst i 2)
- (princ "@" (hex5 (+ i -4 (ref-int16-LE code i))))
- (set! i (+ i 2)))
-
- ((jmp.l brf.l brt.l brne.l brnn.l brn.l)
- (print-inst inst i 4)
- (princ "@" (hex5 (+ i -4 (ref-int32-LE code i))))
- (set! i (+ i 4)))
-
- (else (print-inst inst i 0))))))))
-
-; From SRFI 89 by Marc Feeley (http://srfi.schemers.org/srfi-89/srfi-89.html)
-; Copyright (C) Marc Feeley 2006. All Rights Reserved.
-;
-; "alist" is a list of pairs of the form "(keyword . value)"
-; The result is a perfect hash-table represented as a vector of
-; length 2*N, where N is the hash modulus. If the keyword K is in
-; the hash-table it is at index
-;
-; X = (* 2 ($hash-keyword K N))
-;
-; and the associated value is at index X+1.
-(define (make-perfect-hash-table alist)
- (define ($hash-keyword key n) (mod0 (abs (hash key)) n))
- (let loop1 ((n (length alist)))
- (let ((v (vector-alloc (* 2 n) #f)))
- (let loop2 ((lst alist))
- (if (cons? lst)
- (let ((key (caar lst)))
- (let ((x (* 2 ($hash-keyword key n))))
- (if (aref v x)
- (loop1 (+ n 1))
- (begin
- (aset! v x key)
- (aset! v (+ x 1) (cdar lst))
- (loop2 (cdr lst))))))
- v)))))
--- a/compress.c
+++ /dev/null
@@ -1,76 +1,0 @@
-#include "flisp.h"
-#include "compress.h"
-#include "cvalues.h"
-#include "types.h"
-#include "brieflz.h"
-
-BUILTIN("lz-pack", lz_pack)-{- if(nargs < 1)
- argcount(nargs, 1);
- if(nargs > 2)
- argcount(nargs, 2);
-
- if(!isarray(args[0]))
- type_error("array", args[0]);- uint8_t *in;
- size_t insz;
- to_sized_ptr(args[0], &in, &insz);
- int level = nargs > 1 ? tofixnum(args[1]) : 0;
- if(level < 0)
- level = 0;
- else if(level > 10)
- level = 10;
-
- value_t v = cvalue(cv_class(ptr(args[0])), blz_max_packed_size(insz));
- uint8_t *out = cvalue_data(v);
-
- size_t worksz = level > 0
- ? blz_workmem_size_level(insz, level)
- : blz_workmem_size(insz);
- uint8_t *work = MEM_ALLOC(worksz);
- unsigned long n = level > 0
- ? blz_pack_level(in, out, insz, work, level)
- : blz_pack(in, out, insz, work);
- MEM_FREE(work);
- if(n == BLZ_ERROR)
- lerrorf(FL_ArgError, "blz error");
- cvalue_len(v) = n;
- return v;
-}
-
-BUILTIN("lz-unpack", lz_unpack)-{- argcount(nargs, 3);
-
- uint8_t *in;
- size_t insz;
- to_sized_ptr(args[0], &in, &insz);
- if(!isarray(args[0]))
- type_error("array", args[0]);- size_t outsz;
- uint8_t *out;
- value_t v;
- if(args[1] == FL_sizesym){- outsz = tosize(args[2]);
- v = cvalue(cv_class(ptr(args[0])), outsz);
- out = cvalue_data(v);
- }else if(args[1] == FL_tosym){- v = args[2];
- to_sized_ptr(v, &out, &outsz);
- }else{- lerrorf(FL_ArgError, "either :size or :to must be specified");
- }
- unsigned long n = blz_depack_safe(in, insz, out, outsz);
- if(n == BLZ_ERROR)
- lerrorf(FL_ArgError, "blz error");
- cvalue_len(v) = n;
- return v;
-}
-
-void
-compress_init(void)
-{- FL_sizesym = symbol(":size", false);- FL_tosym = symbol(":to", false);-}
--- a/compress.h
+++ /dev/null
@@ -1,1 +1,0 @@
-void compress_init(void);
--- a/cross/djgpp.txt
+++ b/cross/djgpp.txt
@@ -1,7 +1,5 @@
[constants]
-toolchain = '@DIRNAME@/djgpp-toolchain/'
-path = toolchain + 'bin/'
-prefix = path + 'i586-pc-msdosdjgpp-'
+prefix = 'i586-pc-msdosdjgpp-'
[built-in options]
c_args = ['-D__dos__']
--- a/cross/m68-apple.txt
+++ b/cross/m68-apple.txt
@@ -1,7 +1,5 @@
[constants]
-toolchain = '@DIRNAME@/macos-toolchain/'
-path = toolchain + 'bin/'
-prefix = path + 'm68k-apple-macos-'
+prefix = 'm68k-apple-macos-'
cpuflags = ['-march=68020', '-mtune=68020-40']
[built-in options]
@@ -9,11 +7,6 @@
c_link_args = cpuflags + ['-Wl,--gc-sections,--mac-strip-macsbug']
cpp_args = c_args
cpp_link_args = c_link_args
-
-[properties]
-rincludes = toolchain + 'RIncludes'
-makepef = path + 'MakePEF'
-rez = path + 'Rez'
[binaries]
c = prefix + 'gcc'
--- a/cross/powerpc-apple.txt
+++ b/cross/powerpc-apple.txt
@@ -1,16 +1,9 @@
[constants]
-toolchain = '@DIRNAME@/macos-toolchain/'
-path = toolchain + 'bin/'
-prefix = path + 'powerpc-apple-macos-'
+prefix = 'powerpc-apple-macos-'
[built-in options]
c_args = ['-fdata-sections', '-ffunction-sections', '-D__macos__', '-DNDEBUG']
cpp_link_args = ['-Wl,-gc-sections']
-
-[properties]
-rincludes = toolchain + 'RIncludes'
-makepef = path + 'MakePEF'
-rez = path + 'Rez'
[binaries]
c = prefix + 'gcc'
--- a/cvalues.c
+++ /dev/null
@@ -1,1384 +1,0 @@
-#include "flisp.h"
-#include "operators.h"
-#include "cvalues.h"
-#include "types.h"
-#include "iostream.h"
-#include "equal.h"
-
-static void cvalue_init(fltype_t *type, value_t v, void *dest);
-
-void
-add_finalizer(cvalue_t *cv)
-{- if(FL(nfinalizers) == FL(maxfinalizers)){- size_t nn = FL(maxfinalizers) == 0 ? 256 : FL(maxfinalizers)*2;
- cvalue_t **temp = MEM_REALLOC(FL(finalizers), nn*sizeof(cvalue_t*));
- if(temp == nil)
- lerrorf(FL_MemoryError, "out of memory");
- FL(finalizers) = temp;
- FL(maxfinalizers) = nn;
- }
- FL(finalizers)[FL(nfinalizers)++] = cv;
-}
-
-// remove dead objects from finalization list in-place
-void
-sweep_finalizers(void)
-{- cvalue_t **lst = FL(finalizers);
- size_t n = 0, ndel = 0, l = FL(nfinalizers);
- cvalue_t *tmp;
-#define SWAP_sf(a, b) (tmp = a, a = b, b = tmp, 1)
- if(l == 0)
- return;
- do{- tmp = lst[n];
- if(isforwarded((value_t)tmp)){- // object is alive
- lst[n] = ptr(forwardloc((value_t)tmp));
- n++;
- }else{- fltype_t *t = cv_class(tmp);
- if(t->vtable != nil && t->vtable->finalize != nil)
- t->vtable->finalize(tagptr(tmp, TAG_CVALUE));
- if(!isinlined(tmp) && owned(tmp) && !FL(exiting)){- memset(cv_data(tmp), 0xbb, cv_len(tmp));
- MEM_FREE(cv_data(tmp));
- }
- ndel++;
- }
- }while((n < l-ndel) && SWAP_sf(lst[n], lst[n+ndel]));
-
- FL(nfinalizers) -= ndel;
-#if defined(VERBOSEGC)
- if(ndel > 0)
- printf("GC: finalized %d objects\n", ndel);-#endif
-
- FL(malloc_pressure) = 0;
-}
-
-// compute the size of the metadata object for a cvalue
-static size_t
-cv_nwords(cvalue_t *cv)
-{- if(isinlined(cv)){- size_t n = cv_len(cv);
- if(n == 0 || cv_isstr(cv))
- n++;
- return CVALUE_NWORDS - 1 + NWORDS(n);
- }
- return CVALUE_NWORDS;
-}
-
-static void
-autorelease(cvalue_t *cv)
-{- cv->type = (fltype_t*)(((uintptr_t)cv->type) | CV_OWNED_BIT);
- add_finalizer(cv);
-}
-
-void
-cv_autorelease(cvalue_t *cv)
-{- autorelease(cv);
-}
-
-static value_t
-cprim(fltype_t *type, size_t sz)
-{- assert(!ismanaged((uintptr_t)type));
- assert(sz == type->size);
- cprim_t *pcp = alloc_words(CPRIM_NWORDS-1+NWORDS(sz));
- pcp->type = type;
- return tagptr(pcp, TAG_CPRIM);
-}
-
-value_t
-cvalue_(fltype_t *type, size_t sz, bool nofinalize)
-{- cvalue_t *pcv;
- int str = 0;
-
- assert(type != nil);
- if(valid_numtype(type->numtype) && type->numtype != T_MPINT)
- return cprim(type, sz);
-
- if(type->eltype == FL(bytetype)){- if(sz == 0)
- return FL(the_empty_string);
- sz++;
- str = 1;
- }
- if(sz <= MAX_INL_SIZE){- size_t nw = CVALUE_NWORDS - 1 + NWORDS(sz) + (sz == 0 ? 1 : 0);
- pcv = alloc_words(nw);
- pcv->type = type;
- pcv->data = &pcv->_space[0];
- if(!nofinalize && type->vtable != nil && type->vtable->finalize != nil)
- add_finalizer(pcv);
- }else{- if(FL(malloc_pressure) > ALLOC_LIMIT_TRIGGER)
- fl_gc(0);
- pcv = alloc_words(CVALUE_NWORDS);
- pcv->type = type;
- pcv->data = MEM_ALLOC(sz);
- autorelease(pcv);
- FL(malloc_pressure) += sz;
- }
- if(str)
- ((char*)pcv->data)[--sz] = '\0';
- pcv->len = sz;
- return tagptr(pcv, TAG_CVALUE);
-}
-
-// this effectively dereferences a pointer
-// just like *p in C, it only removes a level of indirection from the type,
-// it doesn't copy any data.
-// this method of creating a cvalue only allocates metadata.
-// ptr is user-managed; we don't autorelease it unless the
-// user explicitly calls (autorelease ) on the result of this function.
-// 'parent' is an optional cvalue that this pointer is known to point
-// into; NIL if none.
-value_t
-cvalue_from_ref(fltype_t *type, void *ptr, size_t sz, value_t parent)
-{- cvalue_t *pcv;
- value_t cv;
-
- assert(type != nil);
- assert(ptr != nil);
- pcv = alloc_words(CVALUE_NWORDS);
- pcv->data = ptr;
- pcv->len = sz;
- pcv->type = type;
- if(parent != FL_nil){- pcv->type = (fltype_t*)(((uintptr_t)pcv->type) | CV_PARENT_BIT);
- pcv->parent = parent;
- }
- cv = tagptr(pcv, TAG_CVALUE);
- return cv;
-}
-
-value_t
-cvalue_string(size_t sz)
-{- if(sz == 0)
- return FL(the_empty_string);
- return cvalue(FL(stringtype), sz);
-}
-
-value_t
-cvalue_static_cstring(const char *str)
-{- if(*str == 0)
- return FL(the_empty_string);
- return cvalue_from_ref(FL(stringtype), (char*)str, strlen(str), FL_nil);
-}
-
-value_t
-string_from_cstrn(char *str, size_t n)
-{- value_t v = cvalue_string(n);
- memcpy(cvalue_data(v), str, n);
- return v;
-}
-
-value_t
-string_from_cstr(char *str)
-{- return string_from_cstrn(str, strlen(str));
-}
-
-int
-fl_isstring(value_t v)
-{- return iscvalue(v) && cv_isstr(ptr(v));
-}
-
-// convert to malloc representation (fixed address)
-void
-cv_pin(cvalue_t *cv)
-{- if(!isinlined(cv))
- return;
- size_t sz = cv_len(cv);
- if(cv_isstr(cv))
- sz++;
- void *data = MEM_ALLOC(sz);
- memcpy(data, cv_data(cv), sz);
- cv->data = data;
- autorelease(cv);
-}
-
-#define num_init(ctype, cnvt, tag) \
- static int \
- cvalue_##ctype##_init(fltype_t *type, value_t arg, void *dest) \
- { \- ctype n; \
- USED(type); \
- if(isfixnum(arg)) \
- n = (ctype)numval(arg); \
- else if(iscprim(arg)){ \- cprim_t *cp = ptr(arg); \
- void *p = cp_data(cp); \
- n = (ctype)conv_to_##cnvt(p, cp_numtype(cp)); \
- }else if(iscvalue(arg) && cp_numtype(ptr(arg)) == T_MPINT){ \- cvalue_t *cv = ptr(arg); \
- void *p = cv_data(cv); \
- n = (ctype)conv_to_##cnvt(p, T_MPINT); \
- }else \
- return 1; \
- *((ctype*)dest) = n; \
- return 0; \
- }
-
-num_init(int8_t, int32, T_INT8)
-num_init(uint8_t, uint32, T_UINT8)
-num_init(int16_t, int32, T_INT16)
-num_init(uint16_t, uint32, T_UINT16)
-num_init(int32_t, int32, T_INT32)
-num_init(uint32_t, uint32, T_UINT32)
-num_init(int64_t, int64, T_INT64)
-num_init(uint64_t, uint64, T_UINT64)
-num_init(float, double, T_FLOAT)
-num_init(double, double, T_DOUBLE)
-
-#define num_ctor_init(typenam, ctype, tag) \
- static \
- BUILTIN(#typenam, typenam) \
- { \- if(nargs == 0){ \- PUSH(fixnum(0)); \
- args = &FL(stack)[FL(sp)-1]; \
- } \
- value_t cp = cprim(FL(typenam##type), sizeof(ctype)); \
- if(cvalue_##ctype##_init(FL(typenam##type), args[0], cp_data(ptr(cp)))) \
- type_error("number", args[0]); \- return cp; \
- }
-
-#define num_ctor_ctor(typenam, ctype, tag) \
- value_t mk_##typenam(ctype n) \
- { \- value_t cp = cprim(FL(typenam##type), sizeof(ctype)); \
- *(ctype*)cp_data(ptr(cp)) = n; \
- return cp; \
- }
-
-#define num_ctor(typenam, ctype, tag) \
- num_ctor_init(typenam, ctype, tag) \
- num_ctor_ctor(typenam, ctype, tag)
-
-num_ctor_init(int8, int8_t, T_INT8)
-num_ctor_init(uint8, uint8_t, T_UINT8)
-num_ctor_init(int16, int16_t, T_INT16)
-num_ctor_init(uint16, uint16_t, T_UINT16)
-num_ctor(int32, int32_t, T_INT32)
-num_ctor(uint32, uint32_t, T_UINT32)
-num_ctor(int64, int64_t, T_INT64)
-num_ctor(uint64, uint64_t, T_UINT64)
-num_ctor_init(byte, uint8_t, T_UINT8)
-num_ctor(float, float, T_FLOAT)
-num_ctor(double, double, T_DOUBLE)
-num_ctor(rune, uint32_t, T_UINT32)
-
-static int
-cvalue_mpint_init(fltype_t *type, value_t arg, void *dest)
-{- mpint *n;
- USED(type);
- if(isfixnum(arg)){- n = vtomp(numval(arg), nil);
- }else if(iscvalue(arg)){- cvalue_t *cv = ptr(arg);
- void *p = cv_data(cv);
- n = conv_to_mpint(p, cp_numtype(cv));
- }else if(iscprim(arg)){- cprim_t *cp = ptr(arg);
- void *p = cp_data(cp);
- n = conv_to_mpint(p, cp_numtype(cp));
- }else{- return 1;
- }
- *((mpint**)dest) = n;
- return 0;
-}
-
-BUILTIN("bignum", bignum)-{- if(nargs == 0){- PUSH(fixnum(0));
- args = &FL(stack)[FL(sp)-1];
- }
- value_t cv = cvalue(FL(mpinttype), sizeof(mpint*));
- if(cvalue_mpint_init(FL(mpinttype), args[0], cvalue_data(cv)))
- type_error("number", args[0]);- return cv;
-}
-
-
-value_t
-mk_mpint(mpint *n)
-{- value_t cv = cvalue(FL(mpinttype), sizeof(mpint*));
- *(mpint**)cvalue_data(cv) = n;
- return cv;
-}
-
-static void
-free_mpint(value_t self)
-{- mpint **s = value2c(mpint**, self);
- if(*s != mpzero && *s != mpone && *s != mptwo)
- mpfree(*s);
-}
-
-static cvtable_t mpint_vtable = { nil, nil, free_mpint, nil };-
-value_t
-size_wrap(size_t sz)
-{- if(sizeof(size_t) == 8)
- return fits_fixnum(sz) ? fixnum(sz): mk_uint64(sz);
- else
- return fits_fixnum(sz) ? fixnum(sz): mk_uint32(sz);
-}
-
-size_t
-tosize(value_t n)
-{- if(isfixnum(n))
- return (size_t)numval(n);
- if(iscprim(n)){- cprim_t *cp = ptr(n);
- if(sizeof(size_t) == 8)
- return conv_to_uint64(cp_data(cp), cp_numtype(cp));
- return conv_to_uint32(cp_data(cp), cp_numtype(cp));
- }
- type_error("number", n);-}
-
-off_t
-tooffset(value_t n)
-{- if(isfixnum(n))
- return numval(n);
- if(iscprim(n)){- cprim_t *cp = ptr(n);
- return conv_to_int64(cp_data(cp), cp_numtype(cp));
- }
- type_error("number", n);-}
-
-int
-isarray(value_t v)
-{- return iscvalue(v) && cv_class(ptr(v))->eltype != nil;
-}
-
-static size_t
-predict_arraylen(value_t arg)
-{- if(isvector(arg))
- return vector_size(arg);
- if(iscons(arg))
- return llength(arg);
- if(arg == FL_nil)
- return 0;
- if(isarray(arg))
- return cvalue_arraylen(arg);
- return 1;
-}
-
-int
-cvalue_array_init(fltype_t *ft, value_t arg, void *dest)
-{- value_t type = ft->type;
- size_t elsize, i, cnt, sz;
- fltype_t *eltype = ft->eltype;
-
- elsize = ft->elsz;
- cnt = predict_arraylen(arg);
-
- if(iscons(cdr_(cdr_(type)))){- size_t tc = tosize(car_(cdr_(cdr_(type))));
- if(tc != cnt)
- lerrorf(FL_ArgError, "size mismatch");
- }
-
- sz = elsize * cnt;
-
- if(isvector(arg)){- assert(cnt <= vector_size(arg));
- for(i = 0; i < cnt; i++){- cvalue_init(eltype, vector_elt(arg, i), dest);
- dest = (char*)dest + elsize;
- }
- return 0;
- }
- if(iscons(arg) || arg == FL_nil){- i = 0;
- while(iscons(arg)){- if(i == cnt){- i++;
- break;
- } // trigger error
- cvalue_init(eltype, car_(arg), dest);
- i++;
- dest = (char*)dest + elsize;
- arg = cdr_(arg);
- }
- if(i != cnt)
- lerrorf(FL_ArgError, "size mismatch");
- return 0;
- }
- if(iscvalue(arg)){- cvalue_t *cv = ptr(arg);
- if(isarray(arg)){- fltype_t *aet = cv_class(cv)->eltype;
- if(aet == eltype){- if(cv_len(cv) == sz)
- memcpy(dest, cv_data(cv), sz);
- else
- lerrorf(FL_ArgError, "size mismatch");
- return 0;
- }else{- // TODO: initialize array from different type elements
- lerrorf(FL_ArgError, "element type mismatch");
- }
- }
- }
- if(cnt == 1)
- cvalue_init(eltype, arg, dest);
- type_error("sequence", arg);-}
-
-BUILTIN("array", array)-{- size_t elsize, cnt, sz;
- value_t arg;
-
- if(nargs < 1)
- argcount(nargs, 1);
-
- cnt = nargs - 1;
- fltype_t *type = get_array_type(args[0]);
- elsize = type->elsz;
- sz = elsize * cnt;
-
- value_t cv = cvalue(type, sz);
- char *dest = cvalue_data(cv);
- uint32_t i;
- FOR_ARGS(i, 1, arg, args){- if(!fl_isnumber(arg))
- type_error("number", arg);- cvalue_init(type->eltype, arg, dest);
- dest += elsize;
- }
- return cv;
-}
-
-BUILTIN("array-alloc", array_alloc)-{- size_t elsize, sz;
- long i, cnt, a;
-
- if(nargs < 3)
- argcount(nargs, 3);
- cnt = tosize(args[1]);
- if(cnt < 0)
- lerrorf(FL_ArgError, "invalid size: %"PRIu64, (uint64_t)cnt);
-
- fltype_t *type = get_array_type(args[0]);
- elsize = type->elsz;
- sz = elsize * cnt;
-
- value_t cv = cvalue(type, sz);
- char *dest = cvalue_data(cv);
- a = 2;
- for(i = 0; i < cnt; i++){- value_t arg = args[a];
- if(!fl_isnumber(arg))
- type_error("number", arg);- cvalue_init(type->eltype, arg, dest);
- dest += elsize;
- if((a = (a + 1) % nargs) < 2)
- a = 2;
- }
- return cv;
-}
-
-// NOTE: v must be an array
-size_t
-cvalue_arraylen(value_t v)
-{- cvalue_t *cv = ptr(v);
- return cv_len(cv)/cv_class(cv)->elsz;
-}
-
-size_t
-ctype_sizeof(value_t type)
-{- symbol_t *s;
-
- if(issymbol(type) && (s = ptr(type)) != nil && valid_numtype(s->numtype))
- return s->size;
-
- if(iscons(type)){- value_t hed = car_(type);
- if(hed == FL_arraysym){- value_t t = car(cdr_(type));
- if(!iscons(cdr_(cdr_(type))))
- lerrorf(FL_ArgError, "incomplete type");
- value_t n = car_(cdr_(cdr_(type)));
- size_t sz = tosize(n);
- return sz * ctype_sizeof(t);
- }
- }
-
- lerrorf(FL_ArgError, "invalid c type");
-}
-
-// get pointer and size for any plain-old-data value
-void
-to_sized_ptr(value_t v, uint8_t **pdata, size_t *psz)
-{- if(iscvalue(v)){- cvalue_t *pcv = ptr(v);
- ios_t *x = value2c(ios_t*, v);
- if(cv_class(pcv) == FL(iostreamtype) && x->bm == bm_mem){- *pdata = x->buf;
- *psz = x->size;
- return;
- }
- if(cv_isPOD(pcv)){- *pdata = cv_data(pcv);
- *psz = cv_len(pcv);
- return;
- }
- }
- if(iscprim(v)){- cprim_t *pcp = ptr(v);
- *pdata = cp_data(pcp);
- *psz = cp_class(pcp)->size;
- return;
- }
- type_error("plain-old-data", v);-}
-
-BUILTIN("sizeof", sizeof)-{- argcount(nargs, 1);
- if(issymbol(args[0]) || iscons(args[0]))
- return size_wrap(ctype_sizeof(args[0]));
- size_t n;
- uint8_t *data;
- to_sized_ptr(args[0], &data, &n);
- return size_wrap(n);
-}
-
-fl_purefn
-BUILTIN("typeof", typeof)-{- argcount(nargs, 1);
- switch(tag(args[0])){- case TAG_CONS: return FL_conssym;
- case TAG_NUM1: case TAG_NUM: return FL_fixnumsym;
- case TAG_SYM: return FL_symbolsym;
- case TAG_VECTOR: return FL_vectorsym;
- case TAG_FUNCTION:
- if(args[0] == FL_t || args[0] == FL_f)
- return FL_booleansym;
- if(args[0] == FL_nil)
- return FL_nullsym;
- if(args[0] == FL_eof)
- return FL_eof;
- if(args[0] == FL_void)
- return FL_void;
- if(isbuiltin(args[0]))
- return FL_builtinsym;
- return FL_function;
- }
- return cv_type(ptr(args[0]));
-}
-
-value_t
-cvalue_relocate(value_t v)
-{- size_t nw;
- cvalue_t *cv = ptr(v);
- cvalue_t *nv;
- value_t ncv;
-
- nw = cv_nwords(cv);
- nv = alloc_words(nw);
- memcpy(nv, cv, nw*sizeof(value_t));
- if(isinlined(cv))
- nv->data = &nv->_space[0];
- ncv = tagptr(nv, TAG_CVALUE);
- fltype_t *t = cv_class(cv);
- if(t->vtable != nil && t->vtable->relocate != nil)
- t->vtable->relocate(v, ncv);
- forward(v, ncv);
- if(FL(exiting))
- cv_autorelease(ptr(ncv));
- return ncv;
-}
-
-value_t
-cvalue_copy(value_t v)
-{- assert(iscvalue(v));
- PUSH(v);
- cvalue_t *cv = ptr(v);
- size_t nw = cv_nwords(cv);
- cvalue_t *ncv = alloc_words(nw);
- v = POP();
- cv = ptr(v);
- memcpy(ncv, cv, nw * sizeof(value_t));
- if(!isinlined(cv)){- size_t len = cv_len(cv);
- if(cv_isstr(cv))
- len++;
- ncv->data = MEM_ALLOC(len);
- memcpy(ncv->data, cv_data(cv), len);
- autorelease(ncv);
- if(hasparent(cv)){- ncv->type = (fltype_t*)(((uintptr_t)ncv->type) & ~CV_PARENT_BIT);
- ncv->parent = FL_nil;
- }
- }else{- ncv->data = &ncv->_space[0];
- }
-
- return tagptr(ncv, TAG_CVALUE);
-}
-
-BUILTIN("copy", copy)-{- argcount(nargs, 1);
- if(iscons(args[0]) || isvector(args[0]))
- lerrorf(FL_ArgError, "argument must be a leaf atom");
- if(!iscvalue(args[0]))
- return args[0];
- if(!cv_isPOD(ptr(args[0])))
- lerrorf(FL_ArgError, "argument must be a plain-old-data type");
- return cvalue_copy(args[0]);
-}
-
-fl_purefn
-BUILTIN("plain-old-data?", plain_old_datap)-{- argcount(nargs, 1);
- return (iscprim(args[0]) ||
- (iscvalue(args[0]) && cv_isPOD(ptr(args[0])))) ?
- FL_t : FL_f;
-}
-
-static void
-cvalue_init(fltype_t *type, value_t v, void *dest)
-{- cvinitfunc_t f = type->init;
- if(f == nil)
- lerrorf(FL_ArgError, "invalid c type");
- f(type, v, dest);
-}
-
-// (new type . args)
-// this provides (1) a way to allocate values with a shared type for
-// efficiency, (2) a uniform interface for allocating cvalues of any
-// type, including user-defined.
-BUILTIN("c-value", c_value)-{- if(nargs < 1 || nargs > 2)
- argcount(nargs, 2);
- value_t type = args[0];
- fltype_t *ft = get_type(type);
- value_t cv;
- if(ft->eltype != nil){- // special case to handle incomplete array types bla[]
- size_t elsz = ft->elsz;
- size_t cnt;
-
- if(iscons(cdr_(cdr_(type))))
- cnt = tosize(car_(cdr_(cdr_(type))));
- else if(nargs == 2)
- cnt = predict_arraylen(args[1]);
- else
- cnt = 0;
- cv = cvalue(ft, elsz * cnt);
- if(nargs == 2)
- cvalue_array_init(ft, args[1], cvalue_data(cv));
- }else{- cv = cvalue(ft, ft->size);
- if(nargs == 2)
- cvalue_init(ft, args[1], cptr(cv));
- }
- return cv;
-}
-
-// NOTE: this only compares lexicographically; it ignores numeric formats
-value_t
-cvalue_compare(value_t a, value_t b)
-{- cvalue_t *ca = ptr(a);
- cvalue_t *cb = ptr(b);
- char *adata = cv_data(ca);
- char *bdata = cv_data(cb);
- size_t asz = cv_len(ca);
- size_t bsz = cv_len(cb);
- size_t minsz = asz < bsz ? asz : bsz;
- int diff = memcmp(adata, bdata, minsz);
- if(diff == 0){- if(asz > bsz)
- return fixnum(1);
- if(asz < bsz)
- return fixnum(-1);
- }
- return fixnum(diff);
-}
-
-static void
-check_addr_args(value_t arr, value_t ind, uint8_t **data, int *index)
-{- int numel;
- cvalue_t *cv = ptr(arr);
- *data = cv_data(cv);
- numel = cv_len(cv)/cv_class(cv)->elsz;
- *index = tosize(ind);
- if(*index < 0 || *index >= numel)
- bounds_error(arr, ind);
-}
-
-value_t
-cvalue_array_aref(value_t *args)
-{- uint8_t *data;
- int index;
- fltype_t *eltype = cv_class(ptr(args[0]))->eltype;
- value_t el = 0;
- numerictype_t nt = eltype->numtype;
- if(nt >= T_INT32)
- el = cvalue(eltype, eltype->size);
- check_addr_args(args[0], args[1], &data, &index);
- if(nt < T_INT32){- if(nt == T_INT8)
- return fixnum((int8_t)data[index]);
- if(nt == T_UINT8)
- return fixnum((uint8_t)data[index]);
- if(nt == T_INT16)
- return fixnum(((int16_t*)data)[index]);
- return fixnum(((uint16_t*)data)[index]);
- }
- uint8_t *dest = cptr(el);
- size_t sz = eltype->size;
- if(sz == 1)
- *dest = data[index];
- else if(sz == 2)
- *(int16_t*)dest = ((int16_t*)data)[index];
- else if(sz == 4)
- *(int32_t*)dest = ((int32_t*)data)[index];
- else if(sz == 8)
- *(int64_t*)dest = ((int64_t*)data)[index];
- else
- memcpy(dest, data + index*sz, sz);
- return el;
-}
-
-value_t
-cvalue_array_aset(value_t *args)
-{- uint8_t *data; int index;
- fltype_t *eltype = cv_class(ptr(args[0]))->eltype;
- check_addr_args(args[0], args[1], &data, &index);
- uint8_t *dest = data + index*eltype->size;
- cvalue_init(eltype, args[2], dest);
- return args[2];
-}
-
-fl_purefn
-BUILTIN("builtin", builtin)-{- argcount(nargs, 1);
- symbol_t *s = tosymbol(args[0]);
- if(!iscbuiltin(s->binding))
- lerrorf(FL_ArgError, "function \"%s\" not found", s->name);
- return s->binding;
-}
-
-value_t
-cbuiltin(const char *name, builtin_t f)
-{- cvalue_t *cv;
- cv = MEM_CALLOC(CVALUE_NWORDS, sizeof(*cv));
- assert(cv != nil);
- cv->type = FL(builtintype);
- cv->data = &cv->_space[0];
- cv->len = sizeof(value_t);
- *(builtin_t*)cv->data = f;
-
- value_t sym = symbol(name, false);
- symbol_t *s = ((symbol_t*)ptr(sym));
- s->binding = tagptr(cv, TAG_CVALUE);
- ptrhash_put(&FL(reverse_dlsym_lookup_table), cv, (void*)sym);
-
- return s->binding;
-}
-
-#define cv_intern(tok) \
- do{ \- FL_##tok##sym = symbol(#tok, false); \
- }while(0)
-
-#define ctor_cv_intern(tok, nt, ctype) \
- do{ \- symbol_t *s; \
- cv_intern(tok); \
- set(FL_##tok##sym, cbuiltin(#tok, fn_builtin_##tok)); \
- if(valid_numtype(nt)){ \- s = ptr(FL_##tok##sym); \
- s->numtype = nt; \
- s->size = sizeof(ctype); \
- } \
- }while(0)
-
-#define mk_primtype(name, ctype) \
- do{ \- FL(name##type) = get_type(FL_##name##sym); \
- FL(name##type)->init = cvalue_##ctype##_init; \
- }while(0)
-
-#define RETURN_NUM_AS(var, type) return(mk_##type(var))
-
-value_t
-return_from_uint64(uint64_t Uaccum)
-{- if(fits_fixnum(Uaccum))
- return fixnum((fixnum_t)Uaccum);
- if(Uaccum > (uint64_t)INT64_MAX)
- RETURN_NUM_AS(Uaccum, uint64);
- if(Uaccum > (uint64_t)UINT32_MAX)
- RETURN_NUM_AS(Uaccum, int64);
- if(Uaccum > (uint64_t)INT32_MAX)
- RETURN_NUM_AS(Uaccum, uint32);
- RETURN_NUM_AS(Uaccum, int32);
-}
-
-value_t
-return_from_int64(int64_t Saccum)
-{- if(fits_fixnum(Saccum))
- return fixnum((fixnum_t)Saccum);
- RETURN_NUM_AS(vtomp(Saccum, nil), mpint);
-}
-
-#define ACCUM_DEFAULT 0
-#define ARITH_OP(a, b) (a)+(b)
-#define MP_OP mpadd
-#define ARITH_OVERFLOW sadd_overflow_64
-value_t
-fl_add_any(value_t *args, uint32_t nargs)
-{-#include "fl_arith_any.inc"
-}
-
-#define ACCUM_DEFAULT 1
-#define ARITH_OP(a, b) (a)*(b)
-#define MP_OP mpmul
-#define ARITH_OVERFLOW smul_overflow_64
-value_t
-fl_mul_any(value_t *args, uint32_t nargs)
-{-#include "fl_arith_any.inc"
-}
-
-value_t
-fl_neg(value_t n)
-{- int64_t i64;
- uint64_t ui64;
- mpint *mp;
- numerictype_t pt;
- fixnum_t pi;
- void *a;
-
- if(isfixnum(n)){- i64 = -(int64_t)numval(n);
-i64neg:
- return fits_fixnum(i64) ? fixnum(i64) : mk_mpint(vtomp(i64, nil));
- }
-
- if(num_to_ptr(n, &pi, &pt, &a)){- switch(pt){- case T_DOUBLE: return mk_double(-*(double*)a);
- case T_FLOAT: return mk_float(-*(float*)a);
- case T_INT8: return fixnum(-(fixnum_t)*(int8_t*)a);
- case T_UINT8: return fixnum(-(fixnum_t)*(uint8_t*)a);
- case T_INT16: return fixnum(-(fixnum_t)*(int16_t*)a);
- case T_UINT16: return fixnum(-(fixnum_t)*(uint16_t*)a);
- case T_UINT32:
- i64 = -(int64_t)*(uint32_t*)a;
- if(0){- case T_INT32:
- i64 = -(int64_t)*(int32_t*)a;
- }
- goto i64neg;
- case T_INT64:
- i64 = *(int64_t*)a;
- if(i64 == INT64_MIN)
- return mk_mpint(uvtomp((uint64_t)INT64_MAX+1, nil));
- i64 = -i64;
- goto i64neg;
- case T_UINT64:
- ui64 = *(uint64_t*)a;
- if(ui64 >= (uint64_t)INT64_MAX+1){- mp = uvtomp(ui64, nil);
- mp->sign = -1;
- return mk_mpint(mp);
- }
- i64 = -(int64_t)ui64;
- goto i64neg;
- case T_MPINT:
- mp = mpcopy(*(mpint**)a);
- mp->sign = -mp->sign;
- return mk_mpint(mp);
- }
- }
-
- type_error("number", n);-}
-
-int
-num_to_ptr(value_t a, fixnum_t *pi, numerictype_t *pt, void **pp)
-{- cprim_t *cp;
- cvalue_t *cv;
- if(isfixnum(a)){- *pi = numval(a);
- *pp = pi;
- *pt = T_FIXNUM;
- return 1;
- }else if(iscprim(a)){- cp = ptr(a);
- *pp = cp_data(cp);
- *pt = cp_numtype(cp);
- return 1;
- }else if(iscvalue(a)){- cv = ptr(a);
- *pp = cv_data(cv);
- *pt = cv_class(cv)->numtype;
- return valid_numtype(*pt);
- }
- return 0;
-}
-
-/*
- returns -1, 0, or 1 based on ordering of a and b
- eq: consider equality only, returning 0 or nonzero
- eqnans: NaNs considered equal to each other
- -0.0 not considered equal to 0.0
- inexact not considered equal to exact
- typeerr: if not 0, throws type errors, else returns 2 for type errors
-*/
-int
-numeric_compare(value_t a, value_t b, bool eq, bool eqnans, bool typeerr)
-{- fixnum_t ai, bi;
- numerictype_t ta, tb;
- void *aptr, *bptr;
-
- if(bothfixnums(a, b)){- if(!eq && numval(a) < numval(b))
- return -1;
- if(a == b)
- return 0;
- return 1;
- }
- if(!num_to_ptr(a, &ai, &ta, &aptr)){- if(typeerr)
- type_error("number", a);- return 2;
- }
- if(!num_to_ptr(b, &bi, &tb, &bptr)){- if(typeerr)
- type_error("number", b);- return 2;
- }
- if(eq && eqnans && ((ta >= T_FLOAT) != (tb >= T_FLOAT)))
- return 1;
- if(cmp_eq(aptr, ta, bptr, tb, eqnans))
- return 0;
- if(eq)
- return 1;
- if(cmp_lt(aptr, ta, bptr, tb))
- return -1;
- return 1;
-}
-
-_Noreturn void
-DivideByZeroError(void)
-{- lerrorf(FL_DivideError, "/: division by zero");
-}
-
-value_t
-fl_div2(value_t a, value_t b)
-{- double da, db;
- fixnum_t ai, bi;
- numerictype_t ta, tb;
- void *aptr, *bptr;
-
- if(!num_to_ptr(a, &ai, &ta, &aptr))
- type_error("number", a);- if(!num_to_ptr(b, &bi, &tb, &bptr))
- type_error("number", b);-
- da = conv_to_double(aptr, ta);
- db = conv_to_double(bptr, tb);
-
- if(db == 0 && tb < T_FLOAT) // exact 0
- DivideByZeroError();
-
- da = da/db;
-
- if(ta < T_FLOAT && tb < T_FLOAT && (double)(int64_t)da == da)
- return return_from_int64((int64_t)da);
- return mk_double(da);
-}
-
-value_t
-fl_idiv2(value_t a, value_t b)
-{- fixnum_t ai, bi;
- numerictype_t ta, tb;
- void *aptr, *bptr;
- int64_t a64, b64;
- mpint *x;
-
- if(!num_to_ptr(a, &ai, &ta, &aptr))
- type_error("number", a);- if(!num_to_ptr(b, &bi, &tb, &bptr))
- type_error("number", b);-
- if(ta == T_MPINT){- if(tb == T_MPINT){- if(mpsignif(*(mpint**)bptr) == 0)
- goto div_error;
- x = mpnew(0);
- mpdiv(*(mpint**)aptr, *(mpint**)bptr, x, nil);
- return mk_mpint(x);
- }else{- b64 = conv_to_int64(bptr, tb);
- if(b64 == 0)
- goto div_error;
- x = tb == T_UINT64 ? uvtomp(b64, nil) : vtomp(b64, nil);
- mpdiv(*(mpint**)aptr, x, x, nil);
- return mk_mpint(x);
- }
- }
- if(ta == T_UINT64){- if(tb == T_UINT64){- if(*(uint64_t*)bptr == 0)
- goto div_error;
- return return_from_uint64(*(uint64_t*)aptr / *(uint64_t*)bptr);
- }
- b64 = conv_to_int64(bptr, tb);
- if(b64 < 0)
- return return_from_int64(-(int64_t)(*(uint64_t*)aptr / (uint64_t)(-b64)));
- if(b64 == 0)
- goto div_error;
- return return_from_uint64(*(uint64_t*)aptr / (uint64_t)b64);
- }
- if(tb == T_UINT64){- if(*(uint64_t*)bptr == 0)
- goto div_error;
- a64 = conv_to_int64(aptr, ta);
- if(a64 < 0)
- return return_from_int64(-((int64_t)((uint64_t)(-a64) / *(uint64_t*)bptr)));
- return return_from_uint64((uint64_t)a64 / *(uint64_t*)bptr);
- }
-
- b64 = conv_to_int64(bptr, tb);
- if(b64 == 0)
- goto div_error;
-
- return return_from_int64(conv_to_int64(aptr, ta) / b64);
- div_error:
- DivideByZeroError();
-}
-
-static value_t
-fl_bitwise_op(value_t a, value_t b, int opcode)
-{- fixnum_t ai, bi;
- numerictype_t ta, tb, itmp;
- void *aptr = nil, *bptr = nil, *ptmp;
- mpint *bmp = nil, *resmp = nil;
- int64_t b64;
-
- if(!num_to_ptr(a, &ai, &ta, &aptr) || ta >= T_FLOAT)
- type_error("integer", a);- if(!num_to_ptr(b, &bi, &tb, &bptr) || tb >= T_FLOAT)
- type_error("integer", b);-
- if(ta < tb){- itmp = ta; ta = tb; tb = itmp;
- ptmp = aptr; aptr = bptr; bptr = ptmp;
- }
- // now a's type is larger than or same as b's
- if(ta == T_MPINT){- if(tb == T_MPINT){- bmp = *(mpint**)bptr;
- resmp = mpnew(0);
- }else{- bmp = conv_to_mpint(bptr, tb);
- resmp = bmp;
- }
- b64 = 0;
- }else
- b64 = conv_to_int64(bptr, tb);
- switch(opcode){- case 0:
- switch(ta){- case T_INT8: return fixnum( *(int8_t *)aptr & (int8_t )b64);
- case T_UINT8: return fixnum( *(uint8_t *)aptr & (uint8_t )b64);
- case T_INT16: return fixnum( *(int16_t*)aptr & (int16_t )b64);
- case T_UINT16: return fixnum( *(uint16_t*)aptr & (uint16_t)b64);
- case T_INT32: return mk_int32( *(int32_t*)aptr & (int32_t )b64);
- case T_UINT32: return mk_uint32(*(uint32_t*)aptr & (uint32_t)b64);
- case T_INT64: return mk_int64( *(int64_t*)aptr & (int64_t )b64);
- case T_UINT64: return mk_uint64(*(uint64_t*)aptr & (uint64_t)b64);
- case T_MPINT: mpand(*(mpint**)aptr, bmp, resmp); return mk_mpint(resmp);
- case T_FLOAT:
- case T_DOUBLE: assert(0);
- }
- break;
- case 1:
- switch(ta){- case T_INT8: return fixnum( *(int8_t *)aptr | (int8_t )b64);
- case T_UINT8: return fixnum( *(uint8_t *)aptr | (uint8_t )b64);
- case T_INT16: return fixnum( *(int16_t*)aptr | (int16_t )b64);
- case T_UINT16: return fixnum( *(uint16_t*)aptr | (uint16_t)b64);
- case T_INT32: return mk_int32( *(int32_t*)aptr | (int32_t )b64);
- case T_UINT32: return mk_uint32(*(uint32_t*)aptr | (uint32_t)b64);
- case T_INT64: return mk_int64( *(int64_t*)aptr | (int64_t )b64);
- case T_UINT64: return mk_uint64(*(uint64_t*)aptr | (uint64_t)b64);
- case T_MPINT: mpor(*(mpint**)aptr, bmp, resmp); return mk_mpint(resmp);
- case T_FLOAT:
- case T_DOUBLE: assert(0);
- }
- break;
- case 2:
- switch(ta){- case T_INT8: return fixnum( *(int8_t *)aptr ^ (int8_t )b64);
- case T_UINT8: return fixnum( *(uint8_t *)aptr ^ (uint8_t )b64);
- case T_INT16: return fixnum( *(int16_t*)aptr ^ (int16_t )b64);
- case T_UINT16: return fixnum( *(uint16_t*)aptr ^ (uint16_t)b64);
- case T_INT32: return mk_int32( *(int32_t*)aptr ^ (int32_t )b64);
- case T_UINT32: return mk_uint32(*(uint32_t*)aptr ^ (uint32_t)b64);
- case T_INT64: return mk_int64( *(int64_t*)aptr ^ (int64_t )b64);
- case T_UINT64: return mk_uint64(*(uint64_t*)aptr ^ (uint64_t)b64);
- case T_MPINT: mpxor(*(mpint**)aptr, bmp, resmp); return mk_mpint(resmp);
- case T_FLOAT:
- case T_DOUBLE: assert(0);
- }
- }
- assert(0);
- return FL_nil;
-}
-
-BUILTIN("logand", logand)-{- value_t v, e;
- if(nargs == 0)
- return fixnum(-1);
- v = args[0];
- uint32_t i;
- FOR_ARGS(i, 1, e, args){- if(bothfixnums(v, e))
- v = v & e;
- else
- v = fl_bitwise_op(v, e, 0);
- }
- return v;
-}
-
-BUILTIN("logior", logior)-{- value_t v, e;
- if(nargs == 0)
- return fixnum(0);
- v = args[0];
- uint32_t i;
- FOR_ARGS(i, 1, e, args){- if(bothfixnums(v, e))
- v = v | e;
- else
- v = fl_bitwise_op(v, e, 1);
- }
- return v;
-}
-
-BUILTIN("logxor", logxor)-{- value_t v, e;
- if(nargs == 0)
- return fixnum(0);
- v = args[0];
- uint32_t i;
- FOR_ARGS(i, 1, e, args){- if(bothfixnums(v, e))
- v = fixnum(numval(v) ^ numval(e));
- else
- v = fl_bitwise_op(v, e, 2);
- }
- return v;
-}
-
-BUILTIN("lognot", lognot)-{- argcount(nargs, 1);
- value_t a = args[0];
- cprim_t *cp;
- int ta;
- void *aptr;
-
- if(isfixnum(a))
- return fixnum(~numval(a));
- if(iscprim(a)){- cp = ptr(a);
- ta = cp_numtype(cp);
- aptr = cp_data(cp);
- switch(ta){- case T_INT8: return fixnum(~*(int8_t *)aptr);
- case T_UINT8: return fixnum(~*(uint8_t *)aptr & 0xff);
- case T_INT16: return fixnum(~*(int16_t *)aptr);
- case T_UINT16: return fixnum(~*(uint16_t*)aptr & 0xffff);
- case T_INT32: return mk_int32(~*(int32_t *)aptr);
- case T_UINT32: return mk_uint32(~*(uint32_t*)aptr);
- case T_INT64: return mk_int64(~*(int64_t *)aptr);
- case T_UINT64: return mk_uint64(~*(uint64_t*)aptr);
- }
- }
- if(iscvalue(a)){- cvalue_t *cv = ptr(a);
- ta = cp_numtype(cv);
- aptr = cv_data(cv);
- if(ta == T_MPINT){- mpint *m = mpnew(0);
- mpnot(*(mpint**)aptr, m);
- return mk_mpint(m);
- }
- }
- type_error("integer", a);-}
-
-BUILTIN("ash", ash)-{- fixnum_t n;
- int64_t accum;
- cprim_t *cp;
- int ta;
- mpint *mp;
- void *aptr;
-
- argcount(nargs, 2);
- value_t a = args[0];
- n = tofixnum(args[1]);
- if(isfixnum(a)){- if(n <= 0)
- return fixnum(numval(a)>>(-n));
- accum = ((int64_t)numval(a))<<n;
- return fits_fixnum(accum) ? fixnum(accum) : return_from_int64(accum);
- }
- if(iscprim(a) || iscvalue(a)){- if(n == 0)
- return a;
- cp = ptr(a);
- ta = cp_numtype(cp);
- aptr = cp_data(cp);
- if(n < 0){- n = -n;
- switch(ta){- case T_INT8: return fixnum((*(int8_t *)aptr) >> n);
- case T_UINT8: return fixnum((*(uint8_t *)aptr) >> n);
- case T_INT16: return fixnum((*(int16_t *)aptr) >> n);
- case T_UINT16: return fixnum((*(uint16_t*)aptr) >> n);
- case T_INT32: return mk_int32((*(int32_t *)aptr) >> n);
- case T_UINT32: return mk_uint32((*(uint32_t*)aptr) >> n);
- case T_INT64: return mk_int64((*(int64_t *)aptr) >> n);
- case T_UINT64: return mk_uint64((*(uint64_t*)aptr) >> n);
- case T_MPINT:
- aptr = cv_data(cp);
- mp = mpnew(0);
- mpright(*(mpint**)aptr, n, mp);
- return mk_mpint(mp);
- }
- }
- if(ta == T_MPINT){- aptr = cv_data(cp);
- mp = mpnew(0);
- mpleft(*(mpint**)aptr, n, mp);
- return mk_mpint(mp);
- }
- if(ta == T_UINT64)
- return return_from_uint64((*(uint64_t*)aptr)<<n);
- if(ta < T_FLOAT)
- return return_from_int64(conv_to_int64(aptr, ta)<<n);
- }
- type_error("integer", a);-}
-
-void
-cvalues_init(void)
-{- htable_new(&FL(TypeTable), 256);
- htable_new(&FL(reverse_dlsym_lookup_table), 256);
-
- FL(builtintype) = define_opaque_type(FL_builtinsym, sizeof(builtin_t), nil, nil);
-
- ctor_cv_intern(int8, T_INT8, int8_t);
- ctor_cv_intern(uint8, T_UINT8, uint8_t);
- ctor_cv_intern(int16, T_INT16, int16_t);
- ctor_cv_intern(uint16, T_UINT16, uint16_t);
- ctor_cv_intern(int32, T_INT32, int32_t);
- ctor_cv_intern(uint32, T_UINT32, uint32_t);
- ctor_cv_intern(int64, T_INT64, int64_t);
- ctor_cv_intern(uint64, T_UINT64, uint64_t);
- ctor_cv_intern(byte, T_UINT8, uint8_t);
- ctor_cv_intern(rune, T_UINT32, uint32_t);
- ctor_cv_intern(float, T_FLOAT, float);
- ctor_cv_intern(double, T_DOUBLE, double);
-
- ctor_cv_intern(array, NONNUMERIC, int);
-
- FL_stringtypesym = symbol("*string-type*", false);- set(FL_stringtypesym, fl_list2(FL_arraysym, FL_bytesym));
-
- FL_runestringtypesym = symbol("*runestring-type*", false);- set(FL_runestringtypesym, fl_list2(FL_arraysym, FL_runesym));
-
- mk_primtype(int8, int8_t);
- mk_primtype(uint8, uint8_t);
- mk_primtype(int16, int16_t);
- mk_primtype(uint16, uint16_t);
- mk_primtype(int32, int32_t);
- mk_primtype(uint32, uint32_t);
- mk_primtype(int64, int64_t);
- mk_primtype(uint64, uint64_t);
- mk_primtype(byte, uint8_t);
- mk_primtype(rune, uint32_t);
- mk_primtype(float, float);
- mk_primtype(double, double);
-
- ctor_cv_intern(bignum, T_MPINT, mpint*);
- FL(mpinttype) = get_type(FL_bignumsym);
- FL(mpinttype)->init = cvalue_mpint_init;
- FL(mpinttype)->vtable = &mpint_vtable;
-
- FL(stringtype) = get_type(symbol_value(FL_stringtypesym));
- FL(the_empty_string) = cvalue_from_ref(FL(stringtype), (char*)"", 0, FL_nil);
- FL(runestringtype) = get_type(symbol_value(FL_runestringtypesym));
-}
--- a/cvalues.h
+++ /dev/null
@@ -1,64 +1,0 @@
-#pragma once
-
-#if defined(BITS64)
-#define NWORDS(sz) (((sz)+7)>>3)
-#else
-#define NWORDS(sz) (((sz)+3)>>2)
-#endif
-#define CVALUE_NWORDS 4
-#define MAX_INL_SIZE 384
-#define CV_OWNED_BIT 0x1
-#define CV_PARENT_BIT 0x2
-#define owned(cv) ((uintptr_t)(cv)->type & CV_OWNED_BIT)
-#define hasparent(cv) ((uintptr_t)(cv)->type & CV_PARENT_BIT)
-#define isinlined(cv) ((cv)->data == &(cv)->_space[0])
-
-void add_finalizer(cvalue_t *cv);
-void sweep_finalizers(void);
-void cv_autorelease(cvalue_t *cv);
-value_t cvalue_(fltype_t *type, size_t sz, bool nofinalizer);
-#define cvalue(type, sz) cvalue_(type, sz, false)
-#define cvalue_nofinalizer(type, sz) cvalue_(type, sz, true)
-value_t cvalue_from_ref(fltype_t *type, void *ptr, size_t sz, value_t parent);
-value_t cvalue_string(size_t sz);
-value_t cvalue_static_cstring(const char *str);
-value_t string_from_cstrn(char *str, size_t n);
-value_t string_from_cstr(char *str);
-int fl_isstring(value_t v) fl_purefn;
-void cv_pin(cvalue_t *cv);
-value_t mk_mpint(mpint *n);
-value_t size_wrap(size_t sz);
-size_t tosize(value_t n);
-off_t tooffset(value_t n);
-int isarray(value_t v) fl_purefn;
-int cvalue_array_init(fltype_t *ft, value_t arg, void *dest);
-size_t cvalue_arraylen(value_t v) fl_purefn;
-size_t ctype_sizeof(value_t type);
-void to_sized_ptr(value_t v, uint8_t **pdata, size_t *psz);
-value_t cvalue_relocate(value_t v);
-value_t cvalue_copy(value_t v);
-value_t cvalue_compare(value_t a, value_t b) fl_purefn;
-value_t cvalue_array_aref(value_t *args);
-value_t cvalue_array_aset(value_t *args);
-value_t cbuiltin(const char *name, builtin_t f);
-value_t return_from_uint64(uint64_t Uaccum);
-value_t return_from_int64(int64_t Saccum);
-value_t fl_add_any(value_t *args, uint32_t nargs);
-value_t fl_neg(value_t n);
-value_t fl_mul_any(value_t *args, uint32_t nargs);
-int num_to_ptr(value_t a, fixnum_t *pi, numerictype_t *pt, void **pp);
-_Noreturn void DivideByZeroError(void);
-value_t fl_div2(value_t a, value_t b);
-value_t fl_idiv2(value_t a, value_t b);
-void cvalues_init(void);
-
-value_t mk_double(double n);
-value_t mk_float(float n);
-value_t mk_int32(int32_t n);
-value_t mk_uint32(uint32_t n);
-value_t mk_int64(int64_t n);
-value_t mk_uint64(uint64_t n);
-value_t mk_rune(Rune n);
-
-/* builtins.c */
-size_t llength(value_t v) fl_purefn;
--- a/disenv.lsp
+++ /dev/null
@@ -1,10 +1,0 @@
-#!/usr/bin/env flisp
-(for-each (lambda (e)
- (let ((v (top-level-value e)))
- (when (and (function? v)
- (not (builtin? v)))
- (print e)
- (newline)
- (disassemble v)
- (newline))))
- (environment))
--- a/docs_extra.lsp
+++ /dev/null
@@ -1,39 +1,0 @@
-(define-macro (doc-for term (doc #f))
- (let* ((sym (or (and (cons? term) (car term)) term))
- (val (top-level-value sym))
- (funvars (and (cons? term) (cdr term))))
- (if (not funvars)
- (when (function? val)
- (error "docs: " sym ": no funvars specified"))
- (unless (function? val)
- (error "docs: " sym ": funvars set but isn't a function")))
- `(symbol-set-doc ',sym ',doc ',funvars)))
-
-(doc-for (= a . rest)
- "Return #t if the arguments are equal.")
-
-(doc-for (nan? x)
- "Return #t if the argument is NaN, regardless of the sign.")
-
-(doc-for (vm-stats)
- "Print various VM-related information, such as the number of GC calls
-so far, heap and stack size, etc.")
-
-(doc-for (lz-pack data (level 0))
- "Return data compressed using Lempel-Ziv.
-The data must be an array, returned value will have the same type.
-The optional level is between 0 and 10. With level 0 a simple LZSS
-using hashing will be performed. Levels between 1 and 9 offer a
-trade-off between time/space and ratio. Level 10 is optimal but very
-slow.")
-
-(doc-for (lz-unpack data :to destination))
-(doc-for (lz-unpack data :size decompressed-bytes)
- "Return decompressed data previously compressed using lz-pack.
-Either destination for the decompressed data or the expected size of
-the decompressed data must be specified. In the latter case a new
-array is allocated.")
-
-(load "docs_ops.lsp")
-
-(del! *syntax-environment* 'doc-for)
--- a/dos/platform.h
+++ /dev/null
@@ -1,56 +1,0 @@
-#pragma once
-
-#define _XOPEN_SOURCE 700
-#include <assert.h>
-#include <ctype.h>
-#include <machine/endian.h>
-#include <errno.h>
-#include <fcntl.h>
-#include <float.h>
-#include <inttypes.h>
-#include <limits.h>
-#include <locale.h>
-#include <math.h>
-#include <setjmp.h>
-#include <stdbool.h>
-#include <stdarg.h>
-#include <stdio.h>
-#include <stddef.h>
-#include <stdint.h>
-#include <stdlib.h>
-#include <string.h>
-#include <strings.h>
-#include <sys/stat.h>
-#include <sys/time.h>
-#include <time.h>
-#include <unistd.h>
-#include <wctype.h>
-#include <wchar.h>
-
-#define __os_name__ "dos"
-
-#define nil NULL
-#define USED(x) ((void)(x))
-#define nelem(x) (int)(sizeof(x)/sizeof((x)[0]))
-
-#define PATHSEP '\\'
-#define PATHSEPSTRING "\\"
-#define PATHLISTSEP ':'
-#define PATHLISTSEPSTRING ":"
-#define ISPATHSEP(c) ((c) == '\\')
-
-#if !defined(INITIAL_HEAP_SIZE)
-#define INITIAL_HEAP_SIZE 4*1024*1024
-#endif
-#if !defined(ALLOC_LIMIT_TRIGGER)
-#define ALLOC_LIMIT_TRIGGER INITIAL_HEAP_SIZE
-#endif
-
-#define MEM_UNALIGNED_ACCESS
-
-#include "cc.h"
-#include "mem.h"
-#include "mp.h"
-#include "utf.h"
-
-int wcwidth(Rune c) fl_constfn;
--- a/equal.c
+++ /dev/null
@@ -1,422 +1,0 @@
-#include "flisp.h"
-#include "operators.h"
-#include "cvalues.h"
-#include "equal.h"
-#include "hashing.h"
-
-#define BOUNDED_COMPARE_BOUND 128
-#define BOUNDED_HASH_BOUND 16384
-
-#if defined(BITS64)
-#define MIX(a, b) inthash((value_t)(a) ^ (value_t)(b));
-#define doublehash(a) inthash(a)
-#else
-#define MIX(a, b) int64to32hash((uint64_t)(a)<<32 | (uint64_t)(b));
-#define doublehash(a) int64to32hash(a)
-#endif
-
-// comparable tag
-#define cmptag(v) (isfixnum(v) ? TAG_NUM : tag(v))
-
-static value_t
-eq_class(htable_t *table, value_t key)
-{- value_t c = (value_t)ptrhash_get(table, (void*)key);
- if(c == (value_t)HT_NOTFOUND)
- return FL_nil;
- if(c == key)
- return c;
- return eq_class(table, c);
-}
-
-static void
-eq_union(htable_t *table, value_t a, value_t b, value_t c, value_t cb)
-{- value_t ca = c == FL_nil ? a : c;
- if(cb != FL_nil)
- ptrhash_put(table, (void*)cb, (void*)ca);
- ptrhash_put(table, (void*)a, (void*)ca);
- ptrhash_put(table, (void*)b, (void*)ca);
-}
-
-static value_t bounded_compare(value_t a, value_t b, int bound, bool eq);
-static value_t cyc_compare(value_t a, value_t b, htable_t *table, bool eq);
-
-static value_t
-bounded_vector_compare(value_t a, value_t b, int bound, bool eq)
-{- size_t la = vector_size(a);
- size_t lb = vector_size(b);
- size_t m, i;
- if(eq && la != lb)
- return fixnum(1);
- m = la < lb ? la : lb;
- for(i = 0; i < m; i++){- value_t d = bounded_compare(vector_elt(a, i), vector_elt(b, i), bound-1, eq);
- if(d == FL_nil || numval(d) != 0)
- return d;
- }
- if(la < lb)
- return fixnum(-1);
- if(la > lb)
- return fixnum(1);
- return fixnum(0);
-}
-
-// strange comparisons are resolved arbitrarily but consistently.
-// ordering: number < cprim < function < vector < cvalue < symbol < cons
-static value_t
-bounded_compare(value_t a, value_t b, int bound, bool eq)
-{- value_t d;
- cvalue_t *cv;
-
-compare_top:
- if(a == b)
- return fixnum(0);
- if(bound <= 0)
- return FL_nil;
- int taga = tag(a);
- int tagb = cmptag(b);
- int c;
- switch(taga){- case TAG_NUM :
- case TAG_NUM1:
- if(isfixnum(b))
- return (fixnum_t)a < (fixnum_t)b ? fixnum(-1) : fixnum(1);
- if(iscprim(b)){- if(cp_class(ptr(b)) == FL(runetype))
- return fixnum(1);
- return fixnum(numeric_compare(a, b, eq, true, false));
- }
- if(iscvalue(b)){- cv = ptr(b);
- if(valid_numtype(cv_class(cv)->numtype))
- return fixnum(numeric_compare(a, b, eq, true, false));
- }
- return fixnum(-1);
- case TAG_SYM:
- if(eq || tagb < TAG_SYM)
- return fixnum(1);
- if(tagb > TAG_SYM)
- return fixnum(-1);
- return fixnum(strcmp(symbol_name(a), symbol_name(b)));
- case TAG_VECTOR:
- if(isvector(b))
- return bounded_vector_compare(a, b, bound, eq);
- break;
- case TAG_CPRIM:
- if(cp_class(ptr(a)) == FL(runetype)){- if(!iscprim(b) || cp_class(ptr(b)) != FL(runetype))
- return fixnum(-1);
- }else if(iscprim(b) && cp_class(ptr(b)) == FL(runetype))
- return fixnum(1);
- c = numeric_compare(a, b, eq, true, false);
- if(c != 2)
- return fixnum(c);
- break;
- case TAG_CVALUE:
- cv = ptr(a);
- if(valid_numtype(cv_class(cv)->numtype)){- if((c = numeric_compare(a, b, eq, true, false)) != 2)
- return fixnum(c);
- }
- if(iscvalue(b)){- if(cv_isPOD(ptr(a)) && cv_isPOD(ptr(b)))
- return cvalue_compare(a, b);
- return fixnum(1);
- }
- break;
- case TAG_FUNCTION:
- if(tagb == TAG_FUNCTION){- if(uintval(a) > N_BUILTINS && uintval(b) > N_BUILTINS){- function_t *fa = ptr(a);
- function_t *fb = ptr(b);
- d = bounded_compare(fa->bcode, fb->bcode, bound-1, eq);
- if(d == FL_nil || numval(d) != 0)
- return d;
- d = bounded_compare(fa->vals, fb->vals, bound-1, eq);
- if(d == FL_nil || numval(d) != 0)
- return d;
- d = bounded_compare(fa->env, fb->env, bound-1, eq);
- if(d == FL_nil || numval(d) != 0)
- return d;
- return fixnum(0);
- }
- return uintval(a) < uintval(b) ? fixnum(-1) : fixnum(1);
- }
- break;
- case TAG_CONS:
- if(tagb < TAG_CONS)
- return fixnum(1);
- d = bounded_compare(car_(a), car_(b), bound-1, eq);
- if(d == FL_nil || numval(d) != 0)
- return d;
- a = cdr_(a); b = cdr_(b);
- bound--;
- goto compare_top;
- }
- return taga < tagb ? fixnum(-1) : fixnum(1);
-}
-
-static value_t
-cyc_vector_compare(value_t a, value_t b, htable_t *table, bool eq)
-{- size_t la = vector_size(a);
- size_t lb = vector_size(b);
- size_t m, i;
- value_t d, xa, xb, ca, cb;
-
- // first try to prove them different with no recursion
- if(eq && la != lb)
- return fixnum(1);
- m = la < lb ? la : lb;
- for(i = 0; i < m; i++){- xa = vector_elt(a, i);
- xb = vector_elt(b, i);
- if(leafp(xa) || leafp(xb)){- d = bounded_compare(xa, xb, 1, eq);
- if(d != FL_nil && numval(d) != 0)
- return d;
- }else if(tag(xa) < tag(xb))
- return fixnum(-1);
- else if(tag(xa) > tag(xb))
- return fixnum(1);
- }
-
- ca = eq_class(table, a);
- cb = eq_class(table, b);
- if(ca != FL_nil && ca == cb)
- return fixnum(0);
-
- eq_union(table, a, b, ca, cb);
-
- for(i = 0; i < m; i++){- xa = vector_elt(a, i);
- xb = vector_elt(b, i);
- if(!leafp(xa) || tag(xa) == TAG_FUNCTION){- d = cyc_compare(xa, xb, table, eq);
- if(numval(d) != 0)
- return d;
- }
- }
-
- if(la < lb)
- return fixnum(-1);
- if(la > lb)
- return fixnum(1);
- return fixnum(0);
-}
-
-static value_t
-cyc_compare(value_t a, value_t b, htable_t *table, bool eq)
-{- value_t d, ca, cb;
-cyc_compare_top:
- if(a == b)
- return fixnum(0);
- if(iscons(a)){- if(iscons(b)){- value_t aa = car_(a);
- value_t da = cdr_(a);
- value_t ab = car_(b);
- value_t db = cdr_(b);
- int tagaa = tag(aa);
- int tagda = tag(da);
- int tagab = tag(ab);
- int tagdb = tag(db);
- if(leafp(aa) || leafp(ab)){- d = bounded_compare(aa, ab, 1, eq);
- if(d != FL_nil && numval(d) != 0)
- return d;
- }
- if(tagaa < tagab)
- return fixnum(-1);
- if(tagaa > tagab)
- return fixnum(1);
- if(leafp(da) || leafp(db)){- d = bounded_compare(da, db, 1, eq);
- if(d != FL_nil && numval(d) != 0)
- return d;
- }
- if(tagda < tagdb)
- return fixnum(-1);
- if(tagda > tagdb)
- return fixnum(1);
-
- ca = eq_class(table, a);
- cb = eq_class(table, b);
- if(ca != FL_nil && ca == cb)
- return fixnum(0);
-
- eq_union(table, a, b, ca, cb);
- d = cyc_compare(aa, ab, table, eq);
- if(numval(d) != 0)
- return d;
- a = da;
- b = db;
- goto cyc_compare_top;
- }else{- return fixnum(1);
- }
- }
- if(isvector(a) && isvector(b))
- return cyc_vector_compare(a, b, table, eq);
- if(isclosure(a) && isclosure(b)){- function_t *fa = (function_t*)ptr(a);
- function_t *fb = (function_t*)ptr(b);
- d = bounded_compare(fa->bcode, fb->bcode, 1, eq);
- if(numval(d) != 0)
- return d;
-
- ca = eq_class(table, a);
- cb = eq_class(table, b);
- if(ca != FL_nil && ca == cb)
- return fixnum(0);
-
- eq_union(table, a, b, ca, cb);
- d = cyc_compare(fa->vals, fb->vals, table, eq);
- if(numval(d) != 0)
- return d;
- a = fa->env;
- b = fb->env;
- goto cyc_compare_top;
- }
- return bounded_compare(a, b, 1, eq);
-}
-
-static htable_t equal_eq_hashtable;
-
-void
-comparehash_init(void)
-{- htable_new(&equal_eq_hashtable, 512);
-}
-
-// 'eq' means unordered comparison is sufficient
-value_t
-fl_compare(value_t a, value_t b, bool eq)
-{- value_t guess = bounded_compare(a, b, BOUNDED_COMPARE_BOUND, eq);
- if(guess == FL_nil){- guess = cyc_compare(a, b, &equal_eq_hashtable, eq);
- htable_reset(&equal_eq_hashtable, 512);
- }
- return guess;
-}
-
-/*
- optimizations:
- - use hash updates instead of calling lookup then insert. i.e. get the
- bp once and use it twice.
- * preallocate hash table and call reset() instead of new/free
- * less redundant tag checking, 3-bit tags
-*/
-
-// *oob: output argument, means we hit the limit specified by 'bound'
-static uintptr_t
-bounded_hash(value_t a, int bound, int *oob)
-{- *oob = 0;
- union {- double d;
- int64_t i64;
- }u;
- numerictype_t nt;
- size_t i, len;
- cvalue_t *cv;
- cprim_t *cp;
- void *data;
- uintptr_t h = 0;
- int oob2, tg = tag(a);
-
- switch(tg){- case TAG_NUM :
- case TAG_NUM1:
- u.d = (double)numval(a);
- return doublehash(u.i64);
- case TAG_FUNCTION:
- if(uintval(a) > N_BUILTINS)
- return bounded_hash(((function_t*)ptr(a))->bcode, bound, oob);
- return inthash(a);
- case TAG_SYM:
- return ((symbol_t*)ptr(a))->hash;
- case TAG_CPRIM:
- cp = ptr(a);
- data = cp_data(cp);
- if(cp_class(cp) == FL(runetype))
- return inthash(*(Rune*)data);
- nt = cp_numtype(cp);
- u.d = conv_to_double(data, nt);
- return doublehash(u.i64);
- case TAG_CVALUE:
- cv = ptr(a);
- data = cv_data(cv);
- if(cv->type == FL(mpinttype)){- len = mptobe(*(mpint**)data, nil, 0, (uint8_t**)&data);
- h = memhash(data, len);
- MEM_FREE(data);
- }else{- h = memhash(data, cv_len(cv));
- }
- return h;
-
- case TAG_VECTOR:
- if(bound <= 0){- *oob = 1;
- return 1;
- }
- len = vector_size(a);
- for(i = 0; i < len; i++){- h = MIX(h, bounded_hash(vector_elt(a, i), bound/2, &oob2)^1);
- if(oob2)
- bound /= 2;
- *oob = *oob || oob2;
- }
- return h;
-
- case TAG_CONS:
- do{- if(bound <= 0){- *oob = 1;
- return h;
- }
- h = MIX(h, bounded_hash(car_(a), bound/2, &oob2));
- // bounds balancing: try to share the bounds efficiently
- // so we can hash better when a list is cdr-deep (a common case)
- if(oob2)
- bound /= 2;
- else
- bound--;
- // recursive OOB propagation. otherwise this case is slow:
- // (hash '#2=((#0=(#1=(#1#) . #0#)) . #2#))
- *oob = *oob || oob2;
- a = cdr_(a);
- }while(iscons(a));
- h = MIX(h, bounded_hash(a, bound-1, &oob2)^2);
- *oob = *oob || oob2;
- return h;
- }
- return 0;
-}
-
-int
-equal_lispvalue(value_t a, value_t b)
-{- if(eq_comparable(a, b))
- return a == b;
- return numval(fl_compare(a, b, true)) == 0;
-}
-
-uintptr_t
-hash_lispvalue(value_t a)
-{- int oob = 0;
- return bounded_hash(a, BOUNDED_HASH_BOUND, &oob);
-}
-
-BUILTIN("hash", hash)-{- argcount(nargs, 1);
- return fixnum(hash_lispvalue(args[0]));
-}
--- a/equal.h
+++ /dev/null
@@ -1,11 +1,0 @@
-#pragma once
-
-// comparable with ==
-#define eq_comparable(a, b) (!(((a)|(b))&1))
-#define eq_comparablep(a) (!((a)&1)) /* mag: UNUSED? */
-
-int equal_lispvalue(value_t a, value_t b);
-uintptr_t hash_lispvalue(value_t a);
-value_t fl_compare(value_t a, value_t b, bool eq);
-int numeric_compare(value_t a, value_t b, bool eq, bool eqnans, bool typeerr);
-void comparehash_init(void);
--- a/equalhash.c
+++ /dev/null
@@ -1,9 +1,0 @@
-#include "flisp.h"
-#include "equalhash.h"
-#include "equal.h"
-
-#define HTNAME(suffix) equalhash##suffix
-#define HFUNC(v) hash_lispvalue((value_t)(v))
-#define EQFUNC(x, y) equal_lispvalue((value_t)(x), (value_t)(y))
-
-#include "htable.inc"
--- a/equalhash.h
+++ /dev/null
@@ -1,2 +1,0 @@
-#include "htableh.inc"
-HTPROT(equalhash)
--- a/fl_arith_any.inc
+++ /dev/null
@@ -1,158 +1,0 @@
-//value_t
-//fl_*_any(value_t *args, uint32_t nargs)
-// input: ACCUM_DEFAULT ARITH_OP(a,b) MP_OP ARITH_OVERFLOW
-// add: 0 a+b mpadd sadd_overflow_64
-// mul: 1 a*b mpmul smul_overflow_64
-
- mpint *Maccum = nil, *m = nil;
- int64_t Saccum = ACCUM_DEFAULT, x;
- uint64_t u64;
- double Faccum = ACCUM_DEFAULT;
- bool inexact = false;
- value_t arg;
- numerictype_t pt;
- void *a;
- cprim_t *cp;
- cvalue_t *cv;
-
- uint32_t i, j;
- FOR_ARGS(i, 0, arg, args){- if(isfixnum(arg))
- x = numval(arg);
- else{- if(iscprim(arg)){- cp = ptr(arg);
- a = cp_data(cp);
- pt = cp_numtype(cp);
- }else if(iscvalue(arg)){- cv = ptr(arg);
- a = cv_data(cv);
- pt = cv_class(cv)->numtype;
- }else{-typeerr:
- mpfree(Maccum);
- mpfree(m);
- type_error("number", arg);- }
- switch(pt){- case T_DOUBLE: Faccum = ARITH_OP(Faccum, *(double*)a); inexact = true; continue;
- case T_FLOAT: Faccum = ARITH_OP(Faccum, *(float*)a); inexact = true; continue;
- case T_INT8: x = *(int8_t*)a; break;
- case T_UINT8: x = *(uint8_t*)a; break;
- case T_INT16: x = *(int16_t*)a; break;
- case T_UINT16: x = *(uint16_t*)a; break;
- case T_INT32: x = *(int32_t*)a; break;
- case T_UINT32: x = *(uint32_t*)a; break;
- case T_INT64: x = *(int64_t*)a; break;
- case T_UINT64:
- u64 = *(uint64_t*)a;
- if(u64 > INT64_MAX){- x = ACCUM_DEFAULT;
- goto overflow;
- }
- x = u64;
- break;
- case T_MPINT:
- x = ACCUM_DEFAULT;
- u64 = ACCUM_DEFAULT;
- m = mpcopy(*(mpint**)a);
- goto overflow;
- default:
- goto typeerr;
- }
- }
-
- int64_t accu;
- if(ARITH_OVERFLOW(Saccum, x, &accu)){- u64 = ACCUM_DEFAULT;
- goto overflow;
- }
- Saccum = accu;
- }
-
- if(inexact)
- return mk_double(ARITH_OP(Faccum, Saccum));
- if(fits_fixnum(Saccum))
- return fixnum((fixnum_t)Saccum);
- u64 = ACCUM_DEFAULT;
- x = ACCUM_DEFAULT;
-
-overflow:
- i++;
- if(Maccum == nil)
- Maccum = vtomp(Saccum, nil);
- if(m == nil)
- m = u64 != ACCUM_DEFAULT ? uvtomp(u64, nil) : vtomp(x, nil);
-
- MP_OP(Maccum, m, Maccum);
-
- FOR_ARGS(j, i, arg, args){- if(isfixnum(arg)){- vtomp(numval(arg), m);
- MP_OP(Maccum, m, Maccum);
- continue;
- }
-
- if(iscprim(arg)){- cp = ptr(arg);
- a = cp_data(cp);
- pt = cp_numtype(cp);
- }else if(iscvalue(arg)){- cv = ptr(arg);
- a = cv_data(cv);
- pt = cv_class(cv)->numtype;
- }else{- goto typeerr;
- }
- switch(pt){- case T_DOUBLE: Faccum = ARITH_OP(Faccum, *(double*)a); inexact = true; continue;
- case T_FLOAT: Faccum = ARITH_OP(Faccum, *(float*)a); inexact = true; continue;
- case T_INT8: x = *(int8_t*)a; break;
- case T_UINT8: x = *(uint8_t*)a; break;
- case T_INT16: x = *(int16_t*)a; break;
- case T_UINT16: x = *(uint16_t*)a; break;
- case T_INT32: x = *(int32_t*)a; break;
- case T_UINT32: x = *(uint32_t*)a; break;
- case T_INT64: x = *(int64_t*)a; break;
- case T_UINT64:
- uvtomp(*(uint64_t*)a, m);
- MP_OP(Maccum, m, Maccum);
- continue;
- case T_MPINT:
- MP_OP(Maccum, *(mpint**)a, Maccum);
- continue;
- default:
- goto typeerr;
- }
- vtomp(x, m);
- MP_OP(Maccum, m, Maccum);
- }
-
- int n = mpsignif(Maccum);
- if(n >= FIXNUM_BITS){- if(inexact){- dtomp(Faccum, m);
- MP_OP(Maccum, m, Maccum);
- n = mpsignif(Maccum);
- if(n < FIXNUM_BITS){- inexact = false;
- goto down;
- }
- }
- mpfree(m);
- return mk_mpint(Maccum);
- }
-
-down:
- mpfree(m);
- Saccum = mptov(Maccum);
- mpfree(Maccum);
- if(inexact)
- return mk_double(ARITH_OP(Faccum, Saccum));
- assert(fits_fixnum(Saccum));
- return fixnum((fixnum_t)Saccum);
-
-#undef ACCUM_DEFAULT
-#undef ARITH_OP
-#undef MP_OP
-#undef ARITH_OVERFLOW
--- a/flisp.boot
+++ /dev/null
@@ -1,448 +1,0 @@
-(*builtins* #(0 0 0 0 0 0 0 0 0 0 0 0 #fn("5000n10<:" #())- #fn("5000n10=:" #()) 0 0 0 0 #fn("5000n10B:" #()) 0 0 0 0 0 #fn("5000n10H:" #()) 0 0- 0 #fn("8000z0700}2:" #(<)) 0 #fn("6000n201N:" #()) 0 #fn("6000n201P:" #())- #fn("6000n201Q:" #()) #fn("5000n10R:" #())- #fn("5000n10S:" #()) #fn("5000n10T:" #()) 0 #fn("5000n10V:" #())- #fn("5000n10W:" #()) #fn("5000n10X:" #())- #fn("5000n10Y:" #()) #fn("5000n10Z:" #())- #fn("5000n10[:" #()) #fn("5000n10\\:" #())- #fn("5000n10]:" #()) 0 #fn("6000n201_:" #()) 0 0 0 #fn("6000n201c:" #())- #fn("6000n201d:" #()) #fn("7000z00:" #())- #fn("8000z0700}2:" #(apply)) #fn("8000z0700}2:" #(+))- #fn("8000z0700}2:" #(-)) #fn("8000z0700}2:" #(*))- #fn("8000z0700}2:" #(/)) #fn("8000z0700}2:" #(div0))- #fn("8000z0700}2:" #(=)) #fn("6000n201m:" #()) 0 #fn("8000z0700}2:" #(vector))- #fn("8000z0700}2:" #(aset!)) 0 0 0 0 0 0 0 0 0 0 0 #fn("9000n3012082>1|:" #(#fn("6000n1A061:" #())))- 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 #fn("8000z0700}2:" #(aref)) 0 #fn("5000n10\x8e:" #())- 0)
- *properties* #table(*funvars* #table(>= ((a . rest)) void? ((x)) length= ((lst n)) help ((term)) lz-unpack ((data
- :to destination)
- (data :size decompressed-bytes)) = ((a . rest)) <= ((a . rest)) car ((lst)) /= ((a . rest)) void (rest) *prompt* (#f) nan? ((x)) lz-pack ((data
- (level 0))) cons? ((value)) vm-stats (nil) * ((number…)) cdr ((lst)) > ((a . rest)) + ((number…))) *doc* #table(+ "Return sum of the numbers or 0 with no arguments." >= "Return #t if the arguments are in non-increasing order (previous\none is greater than or equal to the next one)." void? "Return #t if x is #<void> and #f otherwise." length= "Bounded length test.\nUse this instead of (= (length lst) n), since it avoids unnecessary\nwork and always terminates." help "Display documentation for the specified term, if available." lz-unpack "Return decompressed data previously compressed using lz-pack.\nEither destination for the decompressed data or the expected size of\nthe decompressed data must be specified. In the latter case a new\narray is allocated." = "Return #t if the arguments are equal." <= "Return #t if the arguments are in non-decreasing order (previous\none is less than or equal to the next one)." *builtins* "VM instructions as closures." car "Returns the first element of a list or nil if not available." /= "Return #t if not all arguments are equal. Shorthand for (not (= …))." void "Return the constant #<void> while ignoring any arguments.\n#<void> is mainly used when a function has side effects but does not\nproduce any meaningful value to return, so even though #t or nil could\nbe returned instead, in case of #<void> alone, REPL will not print\nit." arg-counts "VM instructions mapped to their expected arguments count." *prompt* "Function called by REPL to signal the user input is required.\nDefault function prints \"#;> \"." nan? "Return #t if the argument is NaN, regardless of the sign." Instructions "VM instructions mapped to their encoded byte representation." lz-pack "Return data compressed using Lempel-Ziv.\nThe data must be an array, returned value will have the same type.\nThe optional level is between 0 and 10. With level 0 a simple LZSS\nusing hashing will be performed. Levels between 1 and 9 offer a\ntrade-off between time/space and ratio. Level 10 is optimal but very\nslow." vm-stats "Print various VM-related information, such as the number of GC calls\nso far, heap and stack size, etc." cons? "Returns #t if the value is a cons cell." * "Return product of the numbers or 1 with no arguments." > "Return #t if the arguments are in strictly decreasing order (previous\none is greater than the next one)." cdr "Returns the tail of a list or nil if not available." *properties* "All properties of symbols recorded with putprop are recorded in this table."))
- *runestring-type* (array rune) *string-type* (array byte)
- *syntax-environment* #table(bcode:nconst #fn("7000n1200r2e3:" #(aref)) with-input-from #fn("<000z12021e1220e2e1e12315163:" #(#fn(nconc)- with-bindings *input-stream* #fn(copy-list))) unless #fn("<000z1200O211Pe4:" #(if begin)) time #fn(">000n12050218522e1e2e123024252622e185e32728e5e3e3:" #(#fn(gensym)- let time-now prog1 princ "Elapsed time: " - " seconds" *linefeed*)) cond #fn(";000z0\x8d\x8a520852185>1_51485<061:" #(#0=#fn("7000z0\x8d:" #() void)- #fn(">000n10H340O:0<85<20Q;I80485<DQ3C085=J6085<:2185=P:85=J@02285<A<0=51e3:85T23C\x98074758551513c07675855151278685<e2e12886217975855151PA<0=51e4e3:2:50278685<e2e1288675855186e2A<0=51e4e3:2885<2185=PA<0=51e4:" #(else- begin or => 1arg-lambda? caddr caadr let if cddr #fn(gensym)) cond-clauses->if))) do #fn("J000z220501<2172052217305221240522587268927882829e12:1=51522829e12:82512887e18;52e153e4e3e2e12887e18:52e3:" #(#fn(gensym)- #fn(map) car cadr #fn("6000n170051B38071061:0<:" #(cddr caddr)) letrec λ if #fn(nconc) begin #fn(copy-list))) mark-label #fn("8000n22002122e21e4:" #(emit- quote label)) with-bindings #fn("G000z12071052207205220230522425e12076888653e12720288687535129242:e12715152242:e127202;8688535152e3e164:" #(#fn(map)- car cadr #fn("5000n12060:" #(#fn(gensym))) #fn(nconc) let list #fn(copy-list)- #fn("7000n22001e3:" #(set!)) unwind-protect begin #fn("7000n22001e3:" #(set!)))) let #fn(">000z1O0R3B00?641<?041=?1@30O42021e12223052e124151532225052863C0268687e2e186e3@408788P:" #(#fn(nconc)- λ #fn(map) #fn("5000n10B3500<:0:" #()) #fn(copy-list)- #fn("5000n10B3500T:7060:" #(void)) letrec)) bcode:code #fn("7000n1200Ee3:" #(aref)) define-macro #fn("A000z170151863D0710<860=5341=?1@30O42223240<e22526e10=e12715153e3e2:" #(value-get-doc- symbol-set-doc void set-syntax! quote #fn(nconc) λ #fn(copy-list))) make-label #fn("5000n120e1:" #(gensym)) bcode:cenv #fn("7000n1200r3e3:" #(aref)) > #fn("<000z12021e12273151510e163:" #(#fn(nconc)- < #fn(copy-list) reverse!)) quasiquote #fn("7000n1700E62:" #(bq-process)) when #fn(";000z1200211POe4:" #(if- begin)) help #fn(";000n17002152853W072855147350424250>170026q535247350@B0722728051524735047960:" #(getprop- *doc* princ newline #fn(for-each) #fn("7000n17050471A0P61:" #(newline print)) *funvars* "no help for "- #fn(string) void)) bcode:ctable #fn("7000n1200Ke3:" #(aref)) with-output-to #fn("<000z12021e1220e2e1e12315163:" #(#fn(nconc)- with-bindings *output-stream* #fn(copy-list))) catch #fn("@000n220502112286e123242586e2262786e22829e2e3262:86e20e3e42;86e22<86e2e4e3e3:" #(#fn(gensym)- trycatch λ if and cons? eq? car quote thrown-value cadr caddr raise)) let* #fn("@000z10H3E02021e1qe12215153e1:2021e173051e1e1220=B3H02024e10=e12215153e1@301515375051e2:" #(#fn(nconc)- λ #fn(copy-list) caar let* cadar)) letrec #fn(">000z1202021e12273052e122240522515154e1227605262:" #(#fn(nconc)- λ #fn(map) car #fn("8000n12021e12205162:" #(#fn(nconc) set! #fn(copy-list)))- #fn(copy-list) void)) /= #fn("=000z1202122e10e12315153e2:" #(not #fn(nconc) = #fn(copy-list))) bcode:sp #fn("7000n1200r4e3:" #(aref)) bcode:stack #fn(":000n2200r421220e21e3e4:" #(aset!- + bcode:sp)) assert #fn(";000n1200D2122230e2e2e2e4:" #(if raise quote assert-failed)) case #fn("A000z1\x8d\x8a6208621_514225023870e2e12425e126278687>215252e3:" #(#0#- #fn("8000n2120C5020:1J40O:1R3=021072151e3:1H3=023072151e3:1=J>0230721<51e3:74751523=0260271e2e3:280271e2e3:" #(else- eq? quote-value eqv? every symbol? memq quote memv) vals->cond)
- #fn(gensym) let #fn(nconc) cond #fn(map) #fn("7000n1A<F0<520=P:" #()))) receive #fn("?000z22021q1e32221e10e123825153e3:" #(call-with-values- λ #fn(nconc) #fn(copy-list))) unwind-protect #fn("A000n220502050218722q1e3e2e1232402286e12587e12686e2e3e3e387e1e3e3:" #(#fn(gensym)- let λ prog1 trycatch begin raise)) dotimes #fn("A000z10<0T20E2187Ke32223e186e1e12415153e4:" #(for- - #fn(nconc) λ #fn(copy-list))) throw #fn("9000n220212223e201e4e2:" #(raise list quote- thrown-value)))
- 1+ #fn("6000n10KM:" #() 1+) 1-- #fn("6000n10K~:" #() 1-) 1arg-lambda? #fn("7000n10B;3E04700<51;3:04710TK62:" #(is-lambda?- length=) 1arg-lambda?)
- <= #fn(";000z1\x8d\x8a6862086>1_486<^10162:" #(#fn("7000n21V;IL041<0L2;I5040\x8e340O:A<1<1=62:" #())) <=)- > #fn(";000z1\x8d\x8a6862086>1_486<^10162:" #(#fn("7000n21V;IE041<0L2;3;04A<1<1=62:" #())) >)- >= #fn(";000z1\x8d\x8a6862086>1_486<^10162:" #(#fn("7000n21V;IL0401<L2;I5040\x8e340O:A<1<1=62:" #())) >=)- Instructions #table(call.l 81 trycatch 75 largc 79 loadg.l 68 aref2 23 box 90 cadr 36 argc 62 setg 71 load0 21 nan? 94 vector? 45 fixnum? 41 loadc0 17 loada0 0 div0 59 keyargs 89 call 5 loada.l 69 brt.l 50 sub2 78 add2 29 loadc.l 70 loadc 9 builtin? 43 set-car! 47 brt 25 ret 10 loadi8 66 tapply 77 loadvoid 93 loada1 1 shift 46 boolean? 39 atom? 24 cdr 13 brne.l 83 / 58 loadf 31 equal? 52 apply 54 dup 11 loadt 20 jmp.l 48 null? 38 not 35 = 60 set-cdr! 30 eq? 33 * 57 load1 27 bound? 42 brf 3 function? 44 box.l 91 < 28 brnn.l 84 jmp 16 loadv 2 for 76 lvargc 80 dummy_eof 95 + 55 brne 19 compare 61 neg 37 loadv.l 67 number? 40 vargc 74 brn 85 brbound 88 vector 63 loadc1 22 setg.l 72 cons? 18 brf.l 49 aref 92 symbol? 34 aset! 64 car 12 cons 32 tcall.l 82 - 56 brn.l 86 optargs 87 closure 14 pop 4 eqv? 51 list 53 seta 15 seta.l 73 brnn 26 loadnil 65 loadg 7 loada 8 tcall 6)
- __init_globals #fn("7000n07021d37022@402384w4^147025d;350426;I50427w8429w:47;w<47=w>47?w@:" #(*os-name*- "macos" #fn("6000n0702161:" #(princ "\e[0m\e[1m#;> \e[0m"))- #fn("6000n0702161:" #(princ "#;> ")) *prompt* "dos" "\\" "/" *directory-separator* "\n"- *linefeed* *stdout* *output-stream* *stdin* *input-stream* *stderr* *error-stream*) __init_globals)
- __rcscript #fn("=000n0708421c360O@T08422c37023@G08424c3=07526514O@4027^184;390428845185;3=0429857:2;53863B02<86513907=8661:O:" #(*os-name*- "unknown" "plan9" "home" "macos" princ "\e]0;femtolisp v0.999\a" "HOME" #fn(os-getenv)
- #fn(string) *directory-separator* ".flisprc" #fn(path-exists?) load) __rcscript)
- __script #fn("6000n1200>121{:" #(#fn("6000n070A61:" #(load))- #fn("6000n170051421K61:" #(top-level-exception-handler- #fn(exit)))) __script)
- __start #fn("7000n1705040=B3D00=w14Ow24730T51@C00w14Dw24745047550426E61:" #(__init_globals- *argv*
- *interactive*
- __script
- __rcscript
- repl #fn(exit)) __start)
- abs #fn("6000n10EL23500U:0:" #() abs) any- #fn("7000n21B;3D0401<51;I:047001=62:" #(any) any) arg-counts #table(bound? 1 function? 1 symbol? 1 car 1 cons 2 cadr 1 nan? 1 for 3 boolean? 1 fixnum? 1 vector? 1 cdr 1 atom? 1 div0 2 equal? 2 eqv? 2 compare 2 null? 1 not 1 number? 1 set-cdr! 2 builtin? 1 eq? 2 cons? 1 set-car! 2)- argc-error #fn(";000n2702102211Kl237023@402465:" #(error "compile error: " " expects "- " argument." " arguments.") argc-error)
- array? #fn("7000n10];IF042005185B;390485<21Q:" #(#fn(typeof) array) array?) assoc- #fn("7000n21J40O:701510d3501<:7101=62:" #(caar assoc) assoc) assv #fn("7000n21J40O:701510c3501<:7101=62:" #(caar- assv) assv)
- bcode:indexfor #fn(";000n20KG0r2G20861523:02186162:2286187534870r287KMp4:" #(#fn(has?)- #fn(get) #fn(put!)) bcode:indexfor)
- box-vars #fn("9000n2\x8d\x8a68620086>2_486<^1161:" #(#fn("9000n10B3Q00<T3B070A21720<5153@30O4F<0=61:O:" #(emit- box caddr))) box-vars)
- bq-bracket #fn(";000n20H3=070710152e2:0<22CS01El2380700=P:707324710=1K~52e3e2:0<25CT01El2390260Te2:707027710T1K~52e3e2:0<28CP01El23500T:707029710T1K~52e3e2:70710152e2:" #(list- bq-process unquote cons 'unquote unquote-splicing copy-list 'unquote-splicing unquote-nsplicing
- 'unquote-nsplicing) bq-bracket)
- bq-bracket1 #fn(":000n20B3S00<20CL01El23500T:7122730=1K~52e3:730162:" #(unquote cons 'unquote- bq-process) bq-bracket1)
- bq-process #fn("<000n20R380200e2:0]3T0717205115286<73C907486=P:757486e3:0H3400:0<26CB07327710T1KM52e3:0<28CV01El23?0790r2523500T:7:2;710=1K~52e3:7<7=052It07>0512?2@1>105286J807387P:87=JA07:87<7186152e3:2A7B87P7186152e162:\x8d\x8a6862C186>2_486<^10q62:" #(quote- bq-process vector->list list vector apply quasiquote 'quasiquote unquote length= cons 'unquote
- any splice-form? lastcdr #fn(map) #fn("7000n1700A62:" #(bq-bracket1))- #fn(nconc) list* #fn("=000n20J;02071151P:0B3o00<22CX020731AEl23700=@C07425e2760=AK~52e252P:F<0=770<A521P62:2071760A521P51P:" #(nconc- reverse! unquote nreconc list 'unquote bq-process bq-bracket))) bq-process)
- builtin->instruction #fn("8000n120A0O63:" #(#fn(get)) #(#table(#.cadr cadr #.aset! aset! #.nan? nan? #.+ + #.- - #.equal? equal? #.eq? eq? #.builtin? builtin? #.not not #.cons? cons? #.cdr cdr #./ / #.div0 div0 #.set-car! set-car! #.vector vector #.set-cdr! set-cdr! #.< < #.for for #.cons cons #.apply apply #.eqv? eqv? #.vector? vector? #.list list #.aref aref #.car car #.bound? bound? #.function? function? #.null? null? #.symbol? symbol? #.compare compare #.boolean? boolean? #.fixnum? fixnum? #.atom? atom? #.= = #.number? number? #.* *)))- caaaar #fn("5000n10<<<<:" #() caaaar) caaadr- #fn("5000n10T<<:" #() caaadr) caaar #fn("5000n10<<<:" #() caaar) caadar- #fn("5000n10<T<:" #() caadar) caaddr #fn("5000n10=T<:" #() caaddr) caadr- #fn("5000n10T<:" #() caadr) caar #fn("5000n10<<:" #() caar) cadaar- #fn("5000n10<<T:" #() cadaar) cadadr #fn("5000n10TT:" #() cadadr) cadar- #fn("5000n10<T:" #() cadar) caddar #fn("5000n10<=T:" #() caddar) cadddr- #fn("5000n10==T:" #() cadddr) caddr #4=#fn("5000n10=T:" #() caddr) call-with-values- #fn("7000n205086B3@0A86<C90186=}2:18661:" #() #(#3=(*values*))) capture-var! #fn("<000n20r3G70186E5387;IG042186510r322861e152p4:" #(index-of- #fn(length) #fn(nconc)) capture-var!)
- cdaaar #fn("5000n10<<<=:" #() cdaaar) cdaadr- #fn("5000n10T<=:" #() cdaadr) cdaar #fn("5000n10<<=:" #() cdaar) cdadar- #fn("5000n10<T=:" #() cdadar) cdaddr #fn("5000n10=T=:" #() cdaddr) cdadr- #fn("5000n10T=:" #() cdadr) cdar #fn("5000n10<=:" #() cdar) cddaar- #fn("5000n10<<==:" #() cddaar) cddadr #fn("5000n10T==:" #() cddadr) cddar- #fn("5000n10<==:" #() cddar) cdddar #fn("5000n10<===:" #() cdddar) cddddr- #fn("5000n10====:" #() cddddr) cdddr #fn("5000n10===:" #() cdddr) cddr- #fn("5000n10==:" #() cddr) char? #fn("6000n12005121Q:" #(#fn(typeof) rune) char?)- closure? #fn("6000n10\\;36040[S:" #() closure?) compile- #fn("8000n170q7105162:" #(compile-f lower-define) compile) compile-and #fn("<000n570018283D218467:" #(compile-short-circuit- brf) compile-and)
- compile-app #fn("E000n483<88R3U07088152IK088Z3E0218851[3;0218851@40887283=23523q07401O895440r40r4GKMp4750183=530r40r4G8:UMp47608237027@40288:63:89[;3904798951892:Cf07089152I\\0212:517:d3P07;83r2523E07401O83T5447602:62:89B3P07<89<513F07=83513=07>01828364:8:360O@F07401O895440r40r4GKMp4750183=530r40r4G8;UMp48:360O@=00r40r4Gr/Mp48:3C07?018283898:8;67:760823702@@402A8;63:" #(in-env?- #fn(top-level-value) length> 255 compile-in compile-arglist emit tcall.l call.l
- builtin->instruction cadr length= is-lambda? inlineable? compile-let compile-builtin-call tcall
- call) compile-app)
- compile-arglist #fn("8000n3202101>282524228261:" #(#fn(for-each)- #fn("9000n170AFO0544Ar4Ar4GKMp:" #(compile-in))- #fn(length)) compile-arglist)
- compile-aset! #fn("=000n3208251r2~87Kl23?07101O2282P64:K87L23h07101O2374828752P544750176828752530r40r4G88UMp47702262:7822r362:" #(#fn(length)- compile-app aset! aref list-head compile-arglist list-tail emit argc-error) compile-aset!)
- compile-begin #fn("9000n483H3?0700182715064:83=H3>070018283<64:7001O83<5447202352474018283=64:" #(compile-in- void emit pop compile-begin) compile-begin)
- compile-builtin-call #fn(">000n7\x8d202186850>3?;514227385O538<3I07483=8<52I=075858<52@30O4858=26CL086El23:07702862:770858663:8=29C708;60:8=2:C708;60:8=2;C]086El23:07702<62:86r2l23:07702=62:770858663:8=2>Cm086El23:07585K62:86Kl23:07702?62:86r2l23:07702@62:770858663:8=2ACL086El23:07702B62:770858663:8=2CCL086El23:07585K62:770858663:8=2DCN086El23<07702E2F63:770858663:8=2GCX086r2L23;07585r262:770823702H@402G8663:8=2ICb086r2l23:07702J62:r286L23?07708586r3~63:7585r262:7708562:" #(#0#- #fn("8000n0AEl239070FK62:7192FA63:" #(argc-error emit) num-compare)- #fn(get) arg-counts length= argc-error list emit loadnil < = + load0 add2 - neg sub2 * load1 /
- vector loadv #() apply tapply aref aref2) compile-builtin-call)
- compile-f #fn("8000n2702101>22262:" #(call-with-values #fn("7000n070AF62:" #(compile-f-))- #fn("5000n20:" #())) compile-f)- compile-f- #fn("O000n270501T711T517215173741T52711518;J7025@408;87H360E@802687518=268:51~73778:528:\x85\xa208?JL07886298>88J708=@508=U54@r07:867;2<7=2<7>8?527?268?5151535152478862@8>268?5188J708=@508=U5547A8608:898>55@30O42B8=L23I0788688J702C@402D8=53@W088\x85?078862E8=53@E08:J?078862F8=53@30O47G0897H7I1518952537J868@<52486r4268951r4Mp47K868@D7I15154478862L5247M2N7O86EG517P86518<5386r3G62:" #(make-code-emitter- lastcdr lambda:vars filter cons? λ #fn(length) keyword-arg? emit optargs bcode:indexfor
- make-perfect-hash-table #fn(map) cons car iota keyargs emit-optional-arg-inits 255 largc lvargc
- vargc argc extend-env complex-bindings lambda:body box-vars compile-in ret values #fn(function)
- encode-byte-code const-to-idx-vec) compile-f-)
- compile-if #fn("A000n420502050205083T718351728351B3;0738351@30O8;DC=07401828<64:8;OC=07401828=64:7401O8;89554750268953475027885347401828<544823<07502852@;0750298:53475027895347401828=544750278:63:" #(#fn(gensym)- caddr cdddr cadddr compile-in emit brf label ret jmp) compile-if)
- compile-in #fn("B000\x8740005000\x884000I60O?4483R3<0700183D64:83H3\xa6083EC:07102262:83KC:07102362:83DC:07102462:83OC:07102562:83qC:07102662:7783513:07102862:7983513<07102:8363:7102;8363:83<2<C<07=0183=63:83<RS;ID0483<Z;I;047>83<1523=07?01828364:83<892@CS07A83T513>07B018283T64:7102;83T63:892CC=07D01828364:892EC>07F018283=64:892GC;07H018363:892ICD07J2K183>22L01>262:892MC@07N018283=8465:892OC>07P018283=64:892QCE07R0183T2E7S8351P64:892TCE07B01D83T5447102U62:892VC\x93083T7S83517W8;518:R360O@807X2Y5148<3`08;=?;47Z8:8<8;<B;3G047[8;<<51;3:047\\8;<5153@30O47]018:8;<64:892^Cp07B01O2Iq83Te35447_7`835151360O@807X2a5147B01O7`83515447102^62:7?01828364:" #(compile-sym- emit load0 load1 loadt loadf loadnil void? loadvoid fits-i8 loadi8 loadv aset! compile-aset!
- in-env? compile-app quote self-evaluating? compile-in if compile-if begin compile-begin prog1
- compile-prog1 λ call-with-values #fn("7000n070AF62:" #(compile-f-))- #fn("9000n270A2105341\x85K02223AF>2152470A242515163:O:" #(emit loadv #fn(for-each)- #fn("9000n170AF0O64:" #(compile-sym))- closure #fn(length))) and compile-and
- or compile-or while compile-while cddr return ret set! value-get-doc error "set!: name must be a symbol"
- symbol-set-doc is-lambda? lambda:vars compile-set! trycatch 1arg-lambda? caddr "trycatch: second form must be a 1-argument lambda") compile-in)
- compile-let #fn("A000n483<83=0r4G88T70018953718;727388518;528:537408=524258=1<521=P7608>827388515440r40r4G8<UMp4E8<L23A082I<0770288<63:O:" #(compile-arglist- vars-to-env complex-bindings caddr box-vars #fn(nconc) compile-in emit shift) compile-let)
- compile-or #fn("<000n470018283O21O67:" #(compile-short-circuit brt) compile-or)- compile-prog1 #fn(":000n37001O82T544718251B3_00r40r4GKMp47201O718251544730245240r40r4Gr/Mp:O:" #(compile-in- cddr compile-begin emit pop) compile-prog1)
- compile-set! #fn("?000n470821E538821CF07201O83544730248263:88<El288=T893<07588=51@9076082528:3o07308937027@40288;5340r40r4GKMp47201O835440r40r4Gr/Mp47302962:7201O8354489IA07:2;2<825251@30O47302=8;63:" #(lookup-sym- global compile-in emit setg vinfo:index capture-var! loada loadc set-car! error #fn(string)
- "internal error: misallocated var " seta) compile-set!)
- compile-short-circuit #fn("?000n783H3?0700182848665:83=H3@070018283<8665:86;I70421507001O83<865540r40r4GKMp486360O@9072023524720858;5340r40r4Gr/Mp486360O@907202452475018283=84858657486340O:720268;63:" #(compile-in- #fn(gensym) emit dup pop compile-short-circuit label) compile-short-circuit)
- compile-sym #fn(";000n470821E538821C`02282513M073248251513@07502624825163:750278263:88<El23W0750287988=51534833A088=T3:07502:62:O:7502;7<08252534833A088=T3:07502:62:O:" #(lookup-sym- global #fn(constant?) printable? #fn(top-level-value) emit loadv loadg loada vinfo:index car
- loadc capture-var!) compile-sym)
- compile-thunk #fn(":000n170q21q72051e362:" #(compile-f λ lower-define) compile-thunk)- compile-while #fn(";000n4205020507101O72505440r40r4GKMp473024885347101O825447302589534730265240r40r4Gr/Mp47101O835447302788534730248963:" #(#fn(gensym)- compile-in void emit label brf pop jmp) compile-while)
- complex-bindings #fn("=000n2205020507101OO8687564722386>174875162:" #(#fn(table)- complex-bindings-
- filter #fn("7000n120A062:" #(#fn(has?)))- table-keys) complex-bindings)
- complex-bindings- #fn("=000n61J40O:0R3K0833D02001523;021840D63:O:0H;I80472051340O:0<23Co0200T1523Q021850TD534833>021840TD53@30O@30O474750511O83848566:760<513U074770517817905152O82S;I50483848566:740<17:051838485562;2<1838485>40=52P:" #(#fn(memq)- #fn(put!) quoted? set! complex-bindings- caddr is-lambda? lambda:body diff lambda:vars
- inlineable? #fn(map) #fn(";000n1700AOF929366:" #(complex-bindings-))) complex-bindings-)- const-to-idx-vec #fn("9000n1200r2G51212285>10KG52485:" #(#fn(vector-alloc)- #fn(for-each)
- #fn("7000n2A10p:" #())) const-to-idx-vec)- copy-tree #fn("7000n10H3400:700<51700=51P:" #(copy-tree) copy-tree) count- #fn("9000n2\x8d\x8a620862186>1_51486<01E63:" #(#0#- #fn("9000n31J5082:A<01=01<5139082KM@408263:" #() count-)) count)- delete-duplicates #fn(":000n1700rD523O02150\x8d\x8a686228586>2_486<^10q62:0H3400:0<0=73858652390748661:85748651P:" #(length>- #fn(table) #fn("8000n20H38070161:21A0<523:0F<0=162:22A0<D534F<0=0<1P62:" #(reverse! #fn(has?)- #fn(put!))) member
- delete-duplicates) delete-duplicates)
- diff #fn("8000n20J40q:200<1523:0710=162:0<710=152P:" #(#fn(memq) diff) diff)- disassemble #fn("U000\x871000.///\x881000I60O?14z282JG07001E534715047260:@30O482<2305124051\x8d\x8d252687>1?:5142527187>2?;514r4288851\x8a<\x8d8<<8=L23\x9124292:888<>2O7;53r48<<L23907150@30O4E87K~2<|48<8<<KM_48>2=8?2>523[08;8>8<<r45348:897?888<<52G5148<8<<r4M_@\x1f12=8?2@523V08;8>8<<K5348:89888<<GG5148<8<<KM_@\xf012=8?2A523e08;8>8<<K5347B2C888<<G8>2DC70r3@30EM515148<8<<KM_@\xb212=8?2E523\\08;8>8<<r45347B2C7?888<<52515148<8<<r4M_@}12=8?2F523\xb808;8>8<<r88>2GC70r4@30EM5347B2C7?888<<52512H5248<8<<r4M_47B2C7?888<<52515148<8<<r4M_48>2GCY07B2H5147B2C7?888<<52512H5248<8<<r4M_@30O@\xec08?2Ic3^08;8>8<<r45347B2C7?888<<52512H5248<8<<r4M_@\xb802=8?2J523e08;8>8<<r25347B2K7L8<<r,7M888<<52g3515248<8<<r2M_@z02=8?2N523e08;8>8<<r45347B2K7L8<<r,7?888<<52g3515248<8<<r4M_@<08;8>8<<E53^1^1@\xc9-:" #(disassemble- newline void #fn(function:code) #fn(function:vals)
- #1=#fn("7000z0\x8d:" #() void) #fn("9000n10\\3F00[IA070504710OAKM63:72061:" #(newline disassemble- print) print-val)
- #fn(";000n370A3U0FEl23N071A72151523A0A182ML237023@4024751r5~512602765:" #(princ >= 1- " >" " "- hex5 ": " " ") print-inst)
- #fn(length) #fn(table-foldl) #fn("7000n382;I?041AF<GQ;34040:" #()) Instructions #fn("6000n1702161:" #(princ- "\t")) #fn(memq) (loadv.l loadg.l setg.l) ref-int32-LE (loadv loadg setg)
- (loada seta loadc call tcall list + - * / < = vector argc vargc loadi8 apply tapply closure box
- shift aref) princ #fn(number->string) aref (loada.l seta.l loadc.l largc lvargc call.l tcall.l
- box.l) (optargs keyargs) keyargs " " brbound
- (jmp brf brt brne brnn brn) "@" hex5 ref-int16-LE (jmp.l brf.l brt.l brne.l brnn.l brn.l)) disassemble)
- div #fn("7000n201k0EL2;3D041EL2;3404K;I504r/;I404EM:" #() div) emit- #fn("Q000z2\x8d2021?75140EG82Jk0122CB088<23C:08824_@R0125CE08788<513;00E88=p@900E188Pp@\x9a126127523A078082<52e1?2@30O42912:52893D02;82<L23:089T?1@30O^142912<52893D02;82<L23:089T?1@30O^1412=C\\0822>d3=02??14q?2@F0822@d3=02A?14q?2@30O@30O412BC\\0822>d3=02C?14q?2@F0822@d3=02D?14q?2@30O@30O488<12EQ;3\x9b04892FCM088T2GCE00E82<2H7I8851PPp@x0892FCB00E82<2J88=PPp@a0892KCB00E82<2L88=PPp@J0892GCB00E82<2M88=PPp@30O;I]0412JCI0892GCB00E82<2H88=PPp@?00E7N182P8852p^140:" #(#0#- #fn("7000n17002162:" #(member (load0 load1 loadt loadf loadnil loadvoid)) load?) car cdr cadr pop- #fn(memq) (loadv loadg setg) bcode:indexfor #fn(assq)
- ((loadv loadv.l) (loadg loadg.l) (setg setg.l) (loada loada.l) (seta seta.l) (box box.l)) 255 ((loadc
- loadc.l)) loada (0) loada0 (1) loada1 loadc loadc0 loadc1 brf not null? brn cddr brt eq? brne
- brnn nreconc) emit)
- emit-optional-arg-inits #fn("<000n582B3\x91020507102284534710238953474075176838452q53O7782515447102884534710295247102:895347;0182=8384KM65:O:" #(#fn(gensym)- emit brbound brt compile-in extend-env list-head cadar seta pop label emit-optional-arg-inits) emit-optional-arg-inits)
- encode-byte-code #fn("S000n17005171855172238651r3238651r2ki2M2452238651E255025502650OO278<28524\x8d8988L23\xda148689G?=48=29CP02:8:8689KMG2;8<5153489r2M?9@\xa91278<2<2=7>873\x8308=8D2?C702@@p08D2AC702B@d08D2CC702D@X08D2EC702F@L08D2GC702H@@08D2IC702J@408=^1@408=525152489KM?948988L23:08689G@30O?>42K8=2L523`02:8;2;8<518>534278<873707M@407NE5152489KM?9@\xeb08=2OCH0278<2P8>5152489KM?9@\xce08>X3\xc708=2K8?2Q523H0278<2P8>5152489KM?9@\x9f02K8?2R523\x810278<2P8>5152489KM?94278<2P8689G5152489KM?948=2SCK0278<2P8689G5152489KM?9@30O@E0278<2T8>5152489KM?9^1@30O@\x81.42U2V8<878:>38;5242W8<61:" #(reverse!- list->vector >= #fn(length) 65536 #fn(table) #fn(buffer)
- #fn(io-write) #int32(0) label #fn(put!) #fn(sizeof)
- #fn(byte) #fn(get) Instructions jmp jmp.l brt brt.l brf brf.l brne brne.l brnn brnn.l brn brn.l
- #fn(memq) (jmp brf brt brne brnn brn) int32 int16 brbound #fn(int32)
- (loadv.l loadg.l setg.l loada.l seta.l largc lvargc call.l tcall.l loadc.l box.l) (optargs
- keyargs)
- keyargs #fn(uint8) #fn(for-each) #fn(";000n220A052421AF37072@407324921520~5162:" #(#fn(io-seek)- #fn(io-write)
- int32 int16 #fn(get)))
- #fn(iostream->string)) encode-byte-code)
- error #fn("9000z020210P61:" #(#fn(raise) error) error) eval- #fn("7000n170710515160:" #(compile-thunk expand) eval) even? #fn("7000n1200K52El2:" #(#fn(logand)) even?)- every #fn("7000n21H;ID0401<51;3:047001=62:" #(every) every) expand- #fn("G000n1\x8d\x8d\x8d\x8d\x8d\x8d\x8d\x8d\x8d\x8d\x8d\x8a5\x8a6\x8a7\x8a8\x8a9\x8a:\x8a;\x8a<\x8a=\x8a>\x8a?208521_51420862286>1_514208723e1_51420882485868?87>4_5142089258?89>2_514208:268:>1_514208;278:8988>3_514208<288?8:8988>4_514208=29888?>2_514208>2:_514208?2;8?8>8;8<8=>5_5148?<0q62:" #(#0#- #fn("7000n20Z;I904200152S:" #(#fn(assq)) top?) #fn("8000n10H3400:020d3400:0<B3P07105122CF023A<7405151A<0=5162:0<A<0=51P:" #(((begin))- caar begin #fn(append) cdar) splice-begin) *expanded* #fn("A000n20H3400:A<201523:0F<051@300A<21152873;0728651@30q2324758852152\x8a987IA024269289>28662:\x8d\x8a:8:278:928993>4_48:<^186518:\x8d8;B3c0493<788;51QIC08;92<8;<89<52_@;08;798;51_48;=?;@\xfb/48::" #(begin- define get-defined-vars #fn(nconc) #fn(map) list #fn("7000n1A<0F<62:" #())- #fn(";000n10H3400:0<B3F02071051C<00<A<0=51P:F<0<92<52922223747585515292<52_493<85PA<0=51P:" #(define- caar #fn(nconc) #fn(map) list get-defined-vars)) caar cdar) expand-body)
- #fn("9000n20H3400:0<B3M00<=B3F070051A<71051152e2@400<F<0=152P:" #(caar cadar) expand-lambda-list)- #fn("7000n10H3600e1:0<B3?070051A<0=51P:0<A<0=51P:" #(caar) l-vars)- #fn("?000n20T7005171051A<0T5122237489521522225e1F<868:52e192<888:528764:" #(lastcdr cddr #fn(nconc)- #fn(map) list λ) expand-lambda)
- #fn("D000n20=V;I6040TH3o070051J400:0T717005151873B00=?0472868752@30O42386A<74051152e3:750517605170051718851F<86512728798:52152893E088=?847287898653@30O42723e18792<868;52Pe193<888;5263:" #(cddr- value-get-doc symbol-set-doc define caddr cdadr caadr #fn(nconc)
- #fn(map) list) expand-define) #fn("=000n20T20A<71051222324F1>2865215252P:" #(begin cddr #fn(nconc)- #fn(map)
- #fn("9000n10<70A<0TF525150Fe3:" #(compile-thunk))) expand-let-syntax)- #fn("5000n20:" #() local-expansion-env) #fn("<000n20H3400:0<208615221A10>3873P087=B3I0A<87T0=f2F<72875115262:73051893>0A<890=f2162:87;I?0486RS;I60486Z3708860:8624C400:8625C:092<0162:8625C:092<0162:8626C:093<0162:8627C:094<0162:8860:" #(#fn(assq)- #fn(":000n0\x8d\x8a48420AF84>3_484<^19261:" #(#fn("8000n10H3400:0<H3700<@90A<0<F5292<0=51P:" #())))- caddr macrocall? quote λ define let-syntax) expand-in)) expand)
- expand-define #fn("@000n10T70051B3:070051@H085R37021@=07223740515285R3@021258586<e3e2:212585<2627e185=e128865185<54e3e2:" #(cddr- #1# error "compile error: invalid syntax " print-to-string set! #fn(nconc) λ #fn(copy-list)) expand-define)
- extend-env #fn("8000n370182E530P:" #(vars-to-env) extend-env) filter- #fn("9000n2\x8d20210>1?65148601qe163:" #(#0#- #fn("8000n382\x8d1B3Q04A1<513?0821<qPN=?2@30O41=?1@\x0e/4=:" #() filter-)) filter)- fits-i8 #fn("8000n10Y;3<0470r\xaf0r\xb063:" #(>=) fits-i8) foldl- #fn("9000n382J401:700082<15282=63:" #(foldl) foldl) foldr #fn(":000n382J401:082<700182=5362:" #(foldr) foldr)- get-defined-vars #fn("7000n170A<05161:" #(delete-duplicates) #(#2=(#fn("8000n10H340q:0<20Cj00=B3d00TR;37040Te1;IS040TB;3E0471051R;3:0471051e1;I404q:0<22C?07324A<0=52}2:q:" #(define- caadr begin nconc #fn(map)) #(#2#)))))
- getprop #fn(":000\x8720003000\x882000I60O?2420711O5387;3<04208708253;I50482:" #(#fn(get)- *properties*) getprop)
- hex5 #fn("8000n170210r@52r52263:" #(string-lpad #fn(number->string) #\0) hex5) identity- #fn("5000n10:" #() identity) in-env? #fn("7000n21B;3F042001<52;I:047101=62:" #(#fn(assq)- in-env?) in-env?)
- index-of #fn("9000n31J40O:01<C5082:7001=82KM63:" #(index-of) index-of) inlineable?- #fn("9000n10<85B;3u047085<51;3i047185T51;3]04727385T52;3O047485T2552S;3@047685T270=5162:" #(is-lambda?- list? every symbol? length> 255 length= #fn(length)) inlineable?)
- io-readall #fn("8000n1205021850524228561:" #(#fn(buffer)- #fn(io-copy)
- #fn(iostream->string)) io-readall)
- io-readline #fn("7000n12002162:" #(#fn(io-readuntil) #\newline) io-readline)- io-readlines #fn("7000n17071062:" #(read-all-of io-readline) io-readlines) iota- #fn("7000n17071062:" #(map-int identity) iota) is-lambda? #fn("6000n1020Q;I704020Q:" #(λ) is-lambda?)- keyword->symbol #fn(";000n1200513K021220512386K24865153^161:0:" #(#fn(keyword?)- #fn(symbol)
- #fn(string)
- #fn(string-sub)
- #fn(string-length)) keyword->symbol)
- keyword-arg? #fn("6000n10B;3904200<61:" #(#fn(keyword?)) keyword-arg?) lambda-vars- #fn(":000n1\x8d\x8a520852185>1_51485<00OO54422237405162:" #(#0#- #fn(":000n40V;I5040R340D:0B3Z00<R3T082;I504833<0702112263:A<0=1828364:0B3\x8d00<B3\x870730<r2523?074051R360O@=070250<2615442774051513=0A<0=182D64:833<0702112863:A<0=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 " " in list " #fn(keyword?)
- ": keyword arguments must come last." "compile error: invalid formal argument ") check-formals)
- #fn(map)
- #fn("6000n10B390700<61:0:" #(keyword->symbol))- to-proper) lambda-vars)
- lambda:body #fn("6000n170061:" #(caddr) lambda:body) lambda:vars- #fn("6000n1700T61:" #(lambda-vars) lambda:vars) last-pair #fn("6000n10=H3400:700=61:" #(last-pair) last-pair)- lastcdr #fn("6000n10H3400:70051=:" #(last-pair) lastcdr) length=- #fn("8000n21EL2340O:1El23500H:0H3701El2:700=1K~62:" #(length=) length=) length> #fn("8000n21EL23400:1El23;00B;34040:0H3701EL2:700=1K~62:" #(length>) length>)- list->vector #fn("6000n1700}2:" #(vector) list->vector) list-head- #fn("9000n2701E52340q:0<710=1K~52P:" #(<= list-head) list-head) list-ref #fn("7000n2700152<:" #(list-tail) list-ref)- list-tail #fn("8000n2701E523400:710=1K~62:" #(<= list-tail) list-tail) list?- #fn("6000n10V;I@040B;3904700=61:" #(list?) list?) load #fn("9000n120021522285>123850>2{:" #(#fn(file)- :read #fn("9000n0\x8d\x8a48420A84>2_484<^1\x8d\x8d\x8d63:" #(#fn("9000n320A51IG0F<21A510721514735063:24A514737215161:" #(#fn(io-eof?)- #fn(read) load-process void #fn(io-close))))) #fn("8000n120A5142122F0e361:" #(#fn(io-close)- #fn(raise)
- load-error))) load)
- load-process #fn("6000n170061:" #(eval) load-process) lookup-sym- #fn(";000n31J5020:1<2108752883808288P:7201=82KM63:" #(global #fn(assq) lookup-sym) lookup-sym)- lower-define #fn(";000n1\x8d2021?55140H;I804720513400:0<23C<0747505161:760<513K02728e10Te185051e17905164:2:74062:" #(#1#- #fn("=000n170051B3N071051B3=02270051P@7073051@60745075855176855186J5087:278687e328748652P:" #(cddr- cdddr begin caddr void get-defined-vars lower-define λ #fn(map)) λ-body) quoted? define
- lower-define expand-define is-lambda? #fn(nconc) λ lastcdr #fn(map)) lower-define)
- macrocall? #fn("6000n10<R;3904700<61:" #(symbol-syntax) macrocall?) macroexpand-1- #fn("7000n10H3400:7005185390850=}2:0:" #(macrocall?) macroexpand-1) make-code-emitter- #fn("9000n0q2050EqEo5:" #(#fn(table)) make-code-emitter)- make-perfect-hash-table #fn(";000n1\x8d\x8a5208521_514\x8d\x8a6862285860>3_486<^12305161:" #(#1#- #fn("8000n270712205151162:" #(mod0 abs #fn(hash)) $hash-keyword)- #fn("=000n120r20i2O52\x8d\x8a68621A085F86>5_486<^19261:" #(#fn(vector-alloc)- #fn(":000n10B3p070051r2A<85F52i29286G3;093<FKM61:928685p49286KM71051p494<0=61:92:" #(caar- cdar)))) #fn(length)) make-perfect-hash-table)
- make-system-image #fn("@000n120021222354202402552212223542650277879Dw84Dw942:898:>22;88878586>42<8;>1{8;504:" #(#fn(file)- :write :create :truncate #fn(string) ".builtin" #fn(buffer)
- (*linefeed* *directory-separator* *argv* that *print-pretty* *print-width* *print-readably*
- *print-level* *print-length* *os-name* *interactive* *prompt* *os-version*)
- *print-pretty* *print-readably* #fn("5000n0Aw04Fw1:" #(*print-pretty* *print-readably*))- #fn("?000n07021A>17223505152742576842577845253f22885F52428859252429927:52^1^142;F512<2=F51r:522>2?E2@2A84522B84r(522B84r 522B84r\x18525629938652429938552^1^1^142C925142C9361:" #(filter- #fn("8000n10Z;3u0420051S;3j0421051[S;IC0422051222105151dS;3I04230A52S;3=04242105151S:" #(#fn(constant?)- #fn(top-level-value) #fn(string) #fn(memq) #fn(iostream?))) simple-sort #fn(environment) nconc #fn(map)
- list top-level-value #fn(write) #fn(io-write) *linefeed* #fn(sizeof)
- #fn(lz-pack) #fn(iostream->string) #fn(array) byte #fn(logand) 255 #fn(ash)
- #fn(io-close))) #fn("6000n1A50420061:" #(#fn(raise)))) make-system-image)- map! #fn("8000n21\x8d1B3B04101<51_41=?1@\x1d/4:" #() map!) map-int- #fn(";000n2701E52340q:0E51qPq\x8a78786_4K7115122870>2|486:" #(<= 1- #fn("7000n1A<F051qPN4AA<=_:" #())) map-int)- max #fn(";000z11J400:70210163:" #(foldl #fn("6000n201L23401:0:" #())) max) member- #fn("7000n21J40O:1<0d3401:7001=62:" #(member) member) memv #fn("7000n21J40O:1<0c3401:7001=62:" #(memv) memv)- min #fn(";000z11J400:70210163:" #(foldl #fn("6000n201L23400:1:" #())) min) mod- #fn("8000n207001521i2~:" #(div) mod) mod0 #fn("7000n2001k1i2~:" #() mod0) negative?- #fn("6000n10EL2:" #() negative?) nestlist #fn(":000n37082E52340q:1710015182K~53P:" #(<=- nestlist) nestlist)
- newline #fn("8000\x8700001000\x880000I7070?04210725247360:" #(*output-stream* #fn(io-write)- *linefeed* void) newline)
- nreconc #fn("7000n2701062:" #(reverse!-) nreconc) odd?- #fn("6000n170051S:" #(even?) odd?) partition #fn(":000n2\x8d2021?65148601qe1qe164:" #(#0#- #fn("9000n48283P\x8d1B3Z0401<513?0821<qPN=?2@<0831<qPN=?341=?1@\x05/47088<=88==62:" #(values) partition-)) partition)- positive? #fn("6000n1E0L2:" #() positive?) princ- #fn(";000z070Ow042185>1220>12386>1{86504:" #(*print-readably* #fn("5000n0Aw0:" #(*print-readably*))- #fn("7000n02071A62:" #(#fn(for-each) write))- #fn("6000n1A50420061:" #(#fn(raise)))) princ)- print #fn("9000z02071062:" #(#fn(for-each) write) print) print-exception- #fn("=000n10B3e00<20C^0710r3523T072230T2425760515127554787605151@\x0e00B3Z00<29CS0710r3523I0722:760512;534780T51@\xe100B3P00<2<CI0710r2523?0722=0T2>53@\xbe00B3I00<2?CB0722@514720=f2@\xa200B3N00<2ACG07B76051514722C0T52@\x8107D0513m0710r2523c0780<51472275140T2E8551;I60485R37072@40788551^1@>0722F514780514727G61:" #(type-error- length= princ "type error: expected " ", got " #fn(typeof) caddr ": " print bounds-error "index "
- " out of bounds for " unbound-error "eval: variable " " has no value" error "error: " load-error
- print-exception "in file " list? #fn(string?) "*** Unhandled exception: " *linefeed*) print-exception)
- print-stack-trace #fn("@000n1\x8d\x8d\x8a5\x8a620852185>1_51420862285>1_51473740r3523F075076370r5@40r452@300517778292:2;505252E\x8a92<2=868889>38762:" #(#0#- #fn("=000n32005182P2105121151C?022232487e361:25051E76278851512888A187>4|:" #(#fn(function:name)- #fn(function:code)
- #fn(raise)
- thrown-value ffound
- #fn(function:vals)
- 1- #fn(length)
- #fn("8000n170A0G513>0F<A0G929363:O:" #(closure?))) find-in-f)- #fn(":000n220A01>321{863E0722374758651522662:27:" #(#fn("8000n02021AF>292524O:" #(#fn(for-each)- #fn("8000n1A<0Fq63:" #())))- #fn("6000n10B3F00<20C?00T21C8072061:23061:" #(thrown-value- ffound caddr #fn(raise))) string-join #fn(map) string reverse! "/" "λ") fn-name) reverse! length>
- list-tail *interactive* filter closure? #fn(map) #fn("6000n10Z;380420061:" #(#fn(top-level-value)))- #fn(environment) #fn(for-each) #fn("9000n17021A<0KGF52524222374051==52470257652492<El23?0770KG0EG52@30O49292<KM_:" #(princ- "(" #fn(for-each) #fn("6000n1702151472061:" #(princ " " print)) vector->list ")" *linefeed*- disassemble))) print-stack-trace)
- print-to-string #fn("8000n1205021085524228561:" #(#fn(buffer)- #fn(write)
- #fn(iostream->string)) print-to-string)
- printable? #fn("6000n120051;IB0471051;I80422051S:" #(#fn(iostream?) void? #fn(eof-object?)) printable?)- procedure? #.function? putprop
- #fn(";000n320711O5387360O@F02250237118853488?7^14238708253482:" #(#fn(get) *properties*- #fn(table)
- #fn(put!)) putprop)
- quote-value #fn("6000n1700513400:210e2:" #(self-evaluating? quote) quote-value) quoted?- #fn("6000n10<20Q:" #(quote) quoted?) random #fn("7000n1200513<0712250062:23500i2:" #(#fn(integer?)- mod #fn(rand) #fn(rand-double)) random)
- read-all #fn("7000n17071062:" #(read-all-of read) read-all) read-all-of- #fn(":000n2\x8d\x8a686201860>3_486<^1q015162:" #(#fn("8000n220A5138071061:F<10P92A5162:" #(#fn(io-eof?)- reverse!))) read-all-of)
- ref-int16-LE #fn(":000n2202101EMGE522101KMGr852M61:" #(#fn(int16)- #fn(ash)) ref-int16-LE)
- ref-int32-LE #fn("<000n2202101EMGE522101KMGr8522101r2MGr@522101r3MGrH52g461:" #(#fn(int32)- #fn(ash)) ref-int32-LE)
- remprop #fn("8000n220711O5386;3F042286052;3:042386062:" #(#fn(get) *properties* #fn(has?)- #fn(del!)) remprop)
- repl #fn(";000n0\x8d\x8d\x8a4\x8a5208421_5142085228485>2_51485<5047360:" #(#0#- #fn("9000n07050421725142324{257651S;3Z04778451788551360O@=079855147:5047;85w<61:" #(*prompt*- #fn(io-flush) *output-stream* #fn("5000n02060:" #(#fn(read)))- #fn("6000n1207151422061:" #(#fn(io-discardbuffer) *input-stream* #fn(raise)))- #fn(io-eof?) *input-stream* load-process void? print newline void that) prompt)
- #fn("6000n020A>121{370F<60:O:" #(#fn("5000n0A<60:" #())- #fn("6000n1700514D:" #(top-level-exception-handler))) reploop) newline) repl)- revappend #fn("7000n2701062:" #(reverse-) revappend) reverse- #fn("7000n170q062:" #(reverse-) reverse) reverse! #fn("7000n170q062:" #(reverse!-) reverse!)- reverse!- #fn("8000n2\x8d1B3B041=101?04N4?1@\x1d/40:" #() reverse!-) reverse-- #fn("7000n21J400:701<0P1=62:" #(reverse-) reverse-) self-evaluating? #fn("7000n10H;36040RS;IK0420051;3A040R;3:04021051Q:" #(#fn(constant?)- #fn(top-level-value)) self-evaluating?)
- set-syntax! #fn("8000n220710163:" #(#fn(put!)- *syntax-environment*) set-syntax!)
- simple-sort #fn("9000n10V;I6040=V3400:0<7021850>22285>162:" #(call-with-values #fn("7000n07021A>1F=62:" #(partition- #fn("6000n10AL2:" #()))) #fn("9000n22071051Ae17115163:" #(#fn(nconc) simple-sort))) simple-sort)- splice-form? #fn("7000n10B;3X040<20Q;IN040<21Q;ID040<22Q;3:04730r252;I704022Q:" #(unquote-splicing- unquote-nsplicing unquote length>) splice-form?)
- string-join #fn("9000n20J5020:215022860<5242324861>20=524258661:" #("" #fn(buffer)- #fn(io-write)
- #fn(for-each)
- #fn("7000n120AF52420A062:" #(#fn(io-write)))- #fn(iostream->string)) string-join)
- string-lpad #fn(":000n3207182122051~52062:" #(#fn(string) string-rep #fn(string-length)) string-lpad)- string-map #fn("=000n2205021151E\x8d8887L23O0422860231885251524748851?8@\x0c/^14258661:" #(#fn(buffer)- #fn(string-length) #fn(io-putc) #fn(string-char) 1+ #fn(iostream->string)) string-map)
- string-rep #fn(":000n21r4L23b0701E5235021:1Kl238022061:1r2l2390220062:2200063:731513@02207401K~5262:742200521r2j262:" #(<=- "" #fn(string) odd? string-rep) string-rep)
- string-rpad #fn(";000n32007182122051~5262:" #(#fn(string) string-rep #fn(string-length)) string-rpad)- string-tail #fn("7000n2200162:" #(#fn(string-sub)) string-tail) string-trim- #fn(">000n3\x8d\x8d\x8a7\x8a820872187>1_51420882288>1_5142305124087<01E895488<082895363:" #(#0#- #fn("9000n48283L23P02012108252523A0A<017282518364:82:" #(#fn(string-find)- #fn(string-char) 1+) trim-start)
- #fn(":000n3E82L23R020121072825152523?0A<0172825163:82:" #(#fn(string-find)- #fn(string-char) 1-) trim-end)
- #fn(string-length) #fn(string-sub)) string-trim)
- symbol-set-doc #fn("A000z213=070021153@30O482B3H0700222374022q53825263:O:" #(putprop- *doc* *funvars* #fn(append) getprop) symbol-set-doc)
- symbol-syntax #fn("8000n120710O63:" #(#fn(get)- *syntax-environment*) symbol-syntax)
- table-clone #fn("9000n12050212285>1q053485:" #(#fn(table)- #fn(table-foldl)
- #fn("8000n320A0163:" #(#fn(put!)))) table-clone)- table-invert #fn("9000n12050212285>1q053485:" #(#fn(table)- #fn(table-foldl)
- #fn("8000n320A1063:" #(#fn(put!)))) table-invert)- table-keys #fn("8000n12021q063:" #(#fn(table-foldl)- #fn("6000n3082P:" #())) table-keys)- table-pairs #fn("8000n12021q063:" #(#fn(table-foldl)- #fn("6000n301P82P:" #())) table-pairs)- table-values #fn("8000n12021q063:" #(#fn(table-foldl)- #fn("6000n3182P:" #())) table-values)- to-proper #fn("7000n10J400:0H3600e1:0<700=51P:" #(to-proper) to-proper)- top-level-bound? #.bound? top-level-exception-handler
- #fn("9000n17071w042285>1230>12486>1{86504:" #(*output-stream* *stderr* #fn("5000n0Aw0:" #(*output-stream*))- #fn("6000n070A51471225061:" #(print-exception- print-stack-trace
- #fn(stacktrace)))
- #fn("6000n1A50420061:" #(#fn(raise)))) top-level-exception-handler)- trace #fn("A000n1200512150728551Ig0230742586262728290e286e3e22:e12;2985e286e3e4e35152@30O^1^147<60:" #(#fn(top-level-value)- #fn(gensym) traced? #fn(set-top-level-value!) eval λ begin write cons quote newline apply void) trace)
- traced? #fn("7000n170051;3?042105121A<51d:" #(closure? #fn(function:code)) #((#fn("9000z020210P51472504230}2:" #(#fn(write)- x newline #.apply)))))
- untrace #fn("9000n1200517185513C0220238551r3G52@30O^147460:" #(#fn(top-level-value)- traced? #fn(set-top-level-value!)
- #fn(function:vals) void) untrace)
- value-get-doc #fn("8000n10<0=208551;3=0486B;350485:" #(#fn(string?)) value-get-doc)- values #fn("8000z00B3:00=J500<:A0P:" #() #(#3#)) vars-to-env- #fn(":000n32021182>2072230515163:" #(#fn(map)- #fn("9000n2700210A52SS1FM63:" #(vinfo #fn(memq)))- iota #fn(length)) vars-to-env)
- vector->list #fn("<000n120051q\x8a6K852186085>3|486<:" #(#fn(length)- #fn("8000n1AF920~GA<P_:" #())) vector->list)- vector-map #fn("<000n220151218651E86K~228701>3|487:" #(#fn(length)- #fn(vector-alloc)
- #fn("9000n1A0F920G51p:" #())) vector-map)- vinfo #fn("7000n30182e3:" #() vinfo) vinfo:heap? #.cadr vinfo:index- #4# vinfo:sym #.car void
- #1# void? #fn("6000n10\x8dQ:" #() void?) zero?- #fn("6000n10El2:" #() zero?))binary files a/flisp.boot.builtin /dev/null differ
--- a/flisp.c
+++ /dev/null
@@ -1,1448 +1,0 @@
-/*
- femtoLisp
-
- by Jeff Bezanson (C) 2009
- Distributed under the BSD License
-*/
-
-#include "flisp.h"
-#include "operators.h"
-#include "cvalues.h"
-#include "types.h"
-#include "print.h"
-#include "read.h"
-#include "timefuncs.h"
-#include "equal.h"
-#include "hashing.h"
-#include "table.h"
-#include "iostream.h"
-#include "compress.h"
-
-value_t FL_builtins_table_sym, FL_quote, FL_lambda, FL_function, FL_comma, FL_commaat;
-value_t FL_commadot, FL_trycatch, FL_backquote;
-value_t FL_conssym, FL_symbolsym, FL_fixnumsym, FL_vectorsym, FL_builtinsym, FL_vu8sym;
-value_t FL_definesym, FL_defmacrosym, FL_forsym, FL_setqsym;
-value_t FL_tsym, FL_Tsym, FL_fsym, FL_Fsym, FL_booleansym, FL_nullsym, FL_evalsym, FL_fnsym;
-value_t FL_nulsym, FL_alarmsym, FL_backspacesym, FL_tabsym, FL_linefeedsym, FL_newlinesym;
-value_t FL_vtabsym, FL_pagesym, FL_returnsym, FL_escsym, FL_spacesym, FL_deletesym;
-value_t FL_IOError, FL_ParseError, FL_TypeError, FL_ArgError, FL_MemoryError;
-value_t FL_DivideError, FL_BoundsError, FL_Error, FL_KeyError, FL_EnumerationError;
-value_t FL_UnboundError;
-value_t FL_sizesym, FL_tosym;
-
-value_t FL_printwidthsym, FL_printreadablysym, FL_printprettysym, FL_printlengthsym;
-value_t FL_printlevelsym;
-value_t FL_tablesym, FL_arraysym;
-value_t FL_iostreamsym, FL_rdsym, FL_wrsym, FL_apsym, FL_crsym, FL_truncsym;
-value_t FL_instrsym, FL_outstrsym;
-value_t FL_int8sym, FL_uint8sym, FL_int16sym, FL_uint16sym, FL_int32sym, FL_uint32sym;
-value_t FL_int64sym, FL_uint64sym, FL_bignumsym;
-value_t FL_bytesym, FL_runesym, FL_floatsym, FL_doublesym;
-value_t FL_stringtypesym, FL_runestringtypesym;
-
-fl_thread(Fl *fl);
-
-typedef struct {- const char *name;
- builtin_t fptr;
-}builtinspec_t;
-
-bool
-isbuiltin(value_t x)
-{- uint32_t i;
- return tag(x) == TAG_FUNCTION && (i = uintval(x)) < nelem(builtins) && builtins[i].name != nil;
-}
-
-static value_t apply_cl(uint32_t nargs) fl_hotfn;
-
-// error utilities ------------------------------------------------------------
-
-void
-free_readstate(fl_readstate_t *rs)
-{- htable_free(&rs->backrefs);
- htable_free(&rs->gensyms);
-}
-
-_Noreturn void
-fl_exit(int status)
-{- FL(exiting) = true;
- fl_gc(0);
- exit(status);
-}
-
-#define FL_TRY \
- fl_exception_context_t _ctx; int l__tr, l__ca; \
- _ctx.sp = FL(sp); _ctx.frame = FL(curr_frame); _ctx.rdst = FL(readstate); _ctx.prev = FL(exctx); \
- _ctx.ngchnd = FL(ngchandles); FL(exctx) = &_ctx; \
- if(!setjmp(_ctx.buf)) \
- for(l__tr = 1; l__tr; l__tr = 0, (void)(FL(exctx) = FL(exctx)->prev))
-
-#define FL_CATCH_INC \
- l__ca = 0, FL(lasterror) = FL_nil, FL(throwing_frame) = 0, FL(sp) = _ctx.sp, FL(curr_frame) = _ctx.frame
-
-#define FL_CATCH \
- else \
- for(l__ca = 1; l__ca; FL_CATCH_INC)
-
-#define FL_CATCH_NO_INC \
- else \
- for(l__ca = 1; l__ca;)
-
-void
-fl_savestate(fl_exception_context_t *_ctx)
-{- _ctx->sp = FL(sp);
- _ctx->frame = FL(curr_frame);
- _ctx->rdst = FL(readstate);
- _ctx->prev = FL(exctx);
- _ctx->ngchnd = FL(ngchandles);
-}
-
-void
-fl_restorestate(fl_exception_context_t *_ctx)
-{- FL(lasterror) = FL_nil;
- FL(throwing_frame) = 0;
- FL(sp) = _ctx->sp;
- FL(curr_frame) = _ctx->frame;
-}
-
-_Noreturn void
-fl_raise(value_t e)
-{- ios_flush(ios_stdout);
- ios_flush(ios_stderr);
-
- FL(lasterror) = e;
- // unwind read state
- while(FL(readstate) != FL(exctx)->rdst){- free_readstate(FL(readstate));
- FL(readstate) = FL(readstate)->prev;
- }
- if(FL(throwing_frame) == 0)
- FL(throwing_frame) = FL(curr_frame);
- FL(ngchandles) = FL(exctx)->ngchnd;
- fl_exception_context_t *thisctx = FL(exctx);
- if(FL(exctx)->prev) // don't throw past toplevel
- FL(exctx) = FL(exctx)->prev;
- longjmp(thisctx->buf, 1);
-}
-
-_Noreturn void
-lerrorf(value_t e, const char *format, ...)
-{- char msgbuf[256];
- va_list args;
-
- PUSH(e);
- va_start(args, format);
- vsnprintf(msgbuf, sizeof(msgbuf), format, args);
- value_t msg = string_from_cstr(msgbuf);
- va_end(args);
-
- e = POP();
- fl_raise(fl_list2(e, msg));
-}
-
-_Noreturn void
-type_error(const char *expected, value_t got)
-{- fl_raise(fl_listn(3, FL_TypeError, symbol(expected, false), got));
-}
-
-_Noreturn void
-bounds_error(value_t arr, value_t ind)
-{- fl_raise(fl_listn(3, FL_BoundsError, arr, ind));
-}
-
-_Noreturn void
-unbound_error(value_t sym)
-{- fl_raise(fl_listn(2, FL_UnboundError, sym));
-}
-
-// safe cast operators --------------------------------------------------------
-
-#define isstring fl_isstring
-#define SAFECAST_OP(type, ctype, cnvt) \
- ctype to##type(value_t v) \
- { \- if(fl_likely(is##type(v))) \
- return (ctype)cnvt(v); \
- type_error(#type, v); \
- }
-SAFECAST_OP(cons, cons_t*, ptr)
-SAFECAST_OP(symbol, symbol_t*, ptr)
-SAFECAST_OP(fixnum, fixnum_t, numval)
-//SAFECAST_OP(cvalue, cvalue_t*, ptr)
-SAFECAST_OP(string, char*, cvalue_data)
-#undef isstring
-
-// symbol table ---------------------------------------------------------------
-
-static symbol_t *
-mk_symbol(const char *str, int len, bool copy)
-{- symbol_t *sym = MEM_ALLOC(sizeof(*sym) + (copy ? len+1 : 0));
- sym->numtype = NONNUMERIC;
- if(str[0] == ':' && str[1] != 0){- value_t s = tagptr(sym, TAG_SYM);
- sym->flags = FLAG_KEYWORD;
- setc(s, s);
- }else{- sym->binding = UNBOUND;
- sym->flags = 0;
- }
- sym->type = nil;
- sym->hash = memhash32(str, len)^0xAAAAAAAA;
- if(copy){- memcpy((char*)(sym+1), str, len+1);
- sym->name = (const char*)(sym+1);
- }else{- sym->name = str;
- }
- sym->size = 0;
- return sym;
-}
-
-value_t
-symbol(const char *str, bool copy)
-{- int len = strlen(str);
- symbol_t *v;
- const char *k;
- if(!Tgetkv(FL(symtab), str, len, &k, (void**)&v)){- v = mk_symbol(str, len, copy);
- FL(symtab) = Tsetl(FL(symtab), v->name, len, v);
- }
- return tagptr(v, TAG_SYM);
-}
-
-BUILTIN("gensym", gensym)-{- argcount(nargs, 0);
- USED(args);
- gensym_t *gs = alloc_words(sizeof(gensym_t)/sizeof(value_t));
- gs->id = FL(gensym_ctr)++;
- gs->binding = UNBOUND;
- gs->type = nil;
- return tagptr(gs, TAG_SYM);
-}
-
-value_t
-gensym(void)
-{- return fn_builtin_gensym(nil, 0);
-}
-
-fl_purefn
-BUILTIN("gensym?", gensymp)-{- argcount(nargs, 1);
- return isgensym(args[0]) ? FL_t : FL_f;
-}
-
-char *
-uint2str(char *dest, size_t len, uint64_t num, uint32_t base)
-{- int i = len-1;
- uint64_t b = (uint64_t)base;
- char ch;
- dest[i--] = '\0';
- while(i >= 0){- ch = (char)(num % b);
- if(ch < 10)
- ch += '0';
- else
- ch = ch-10+'a';
- dest[i--] = ch;
- num /= b;
- if(num == 0)
- break;
- }
- return &dest[i+1];
-}
-
-const char *
-symbol_name(value_t v)
-{- if(ismanaged(v)){- gensym_t *gs = (gensym_t*)ptr(v);
- FL(gsnameno) = 1-FL(gsnameno);
- char *n = uint2str(FL(gsname)[FL(gsnameno)]+1, sizeof(FL(gsname)[0])-1, gs->id, 10);
- *(--n) = 'g';
- return n;
- }
- return ((symbol_t*)ptr(v))->name;
-}
-
-// conses ---------------------------------------------------------------------
-
-value_t
-mk_cons(void)
-{- cons_t *c;
-
- if(fl_unlikely(FL(curheap) > FL(lim)))
- fl_gc(0);
- c = (cons_t*)FL(curheap);
- FL(curheap) += sizeof(cons_t);
- return tagptr(c, TAG_CONS);
-}
-
-void *
-alloc_words(uint32_t n)
-{- value_t *first;
-
- assert(n > 0);
- n = ALIGNED(n, 2); // only allocate multiples of 2 words
- if(fl_unlikely((value_t*)FL(curheap) > (value_t*)FL(lim)+2-n)){- fl_gc(0);
- while((value_t*)FL(curheap) > ((value_t*)FL(lim))+2-n)
- fl_gc(1);
- }
- first = (value_t*)FL(curheap);
- FL(curheap) += n*sizeof(value_t);
- return first;
-}
-
-value_t
-alloc_vector(size_t n, int init)
-{- if(n == 0)
- return FL(the_empty_vector);
- value_t *c = alloc_words(n+1);
- value_t v = tagptr(c, TAG_VECTOR);
- vector_setsize(v, n);
- if(init){- unsigned int i;
- for(i = 0; i < n; i++)
- vector_elt(v, i) = FL_void;
- }
- return v;
-}
-
-// collector ------------------------------------------------------------------
-
-void
-fl_gc_handle(value_t *pv)
-{- if(fl_unlikely(FL(ngchandles) >= N_GC_HANDLES))
- lerrorf(FL_MemoryError, "out of gc handles");
- FL(gchandles)[FL(ngchandles)++] = pv;
-}
-
-void
-fl_free_gc_handles(uint32_t n)
-{- assert(FL(ngchandles) >= n);
- FL(ngchandles) -= n;
-}
-
-value_t
-relocate(value_t v)
-{- value_t a, d, nc, first, *pcdr;
-
- if(isfixnum(v))
- return v;
-
- uintptr_t t = tag(v);
- if(t == TAG_CONS){- // iterative implementation allows arbitrarily long cons chains
- pcdr = &first;
- do{- if((a = car_(v)) == TAG_FWD){- *pcdr = cdr_(v);
- return first;
- }
- car_(v) = TAG_FWD;
- d = cdr_(v);
- *pcdr = nc = tagptr((cons_t*)FL(curheap), TAG_CONS);
- FL(curheap) += sizeof(cons_t);
- cdr_(v) = nc;
- car_(nc) = relocate(a);
- pcdr = &cdr_(nc);
- v = d;
- }while(iscons(v));
- *pcdr = d == FL_nil ? FL_nil : relocate(d);
- return first;
- }
-
- if(!ismanaged(v))
- return v;
- if(isforwarded(v))
- return forwardloc(v);
-
- if(t == TAG_CVALUE)
- return cvalue_relocate(v);
- if(t == TAG_CPRIM){- cprim_t *pcp = ptr(v);
- size_t nw = CPRIM_NWORDS-1+NWORDS(cp_class(pcp)->size);
- cprim_t *ncp = alloc_words(nw);
- while(nw--)
- ((value_t*)ncp)[nw] = ((value_t*)pcp)[nw];
- nc = tagptr(ncp, TAG_CPRIM);
- forward(v, nc);
- return nc;
- }
- if(t == TAG_FUNCTION){- function_t *fn = ptr(v);
- function_t *nfn = alloc_words(4);
- nfn->bcode = fn->bcode;
- nfn->vals = fn->vals;
- nc = tagptr(nfn, TAG_FUNCTION);
- forward(v, nc);
- nfn->env = relocate(fn->env);
- nfn->vals = relocate(nfn->vals);
- nfn->bcode = relocate(nfn->bcode);
- assert(!ismanaged(fn->name));
- nfn->name = fn->name;
- return nc;
- }
- if(t == TAG_VECTOR){- // N.B.: 0-length vectors secretly have space for a first element
- size_t i, sz = vector_size(v);
- if(vector_elt(v, -1) & 0x1){- // grown vector
- nc = relocate(vector_elt(v, 0));
- forward(v, nc);
- }else{- nc = tagptr(alloc_words(sz+1), TAG_VECTOR);
- vector_setsize(nc, sz);
- a = vector_elt(v, 0);
- forward(v, nc);
- if(sz > 0){- vector_elt(nc, 0) = relocate(a);
- for(i = 1; i < sz; i++)
- vector_elt(nc, i) = relocate(vector_elt(v, i));
- }
- }
- return nc;
- }
- if(t == TAG_SYM){- gensym_t *gs = ptr(v);
- gensym_t *ng = alloc_words(sizeof(gensym_t)/sizeof(value_t));
- ng->id = gs->id;
- ng->binding = gs->binding;
- nc = tagptr(ng, TAG_SYM);
- forward(v, nc);
- if(fl_likely(ng->binding != UNBOUND))
- ng->binding = relocate(ng->binding);
- return nc;
- }
- return v;
-}
-
-static void
-trace_globals(void)
-{- const char *k = nil;
- symbol_t *v;
- while(Tnext(FL(symtab), &k, (void**)&v)){- if(v->binding != UNBOUND)
- v->binding = relocate(v->binding);
- }
-}
-
-void
-fl_gc(int mustgrow)
-{- void *temp;
- uint32_t i, f, top;
- fl_readstate_t *rs;
-
- FL(gccalls)++;
- FL(curheap) = FL(tospace);
- if(FL(grew))
- FL(lim) = FL(curheap)+FL(heapsize)*2-sizeof(cons_t);
- else
- FL(lim) = FL(curheap)+FL(heapsize)-sizeof(cons_t);
-
- if(FL(throwing_frame) > FL(curr_frame)){- top = FL(throwing_frame) - 3;
- f = FL(stack)[FL(throwing_frame)-3];
- }else{- top = FL(sp);
- f = FL(curr_frame);
- }
- while(1){- for(i = f; i < top; i++)
- FL(stack)[i] = relocate(FL(stack)[i]);
- if(f == 0)
- break;
- top = f - 3;
- f = FL(stack)[f-3];
- }
- for(i = 0; i < FL(ngchandles); i++)
- *FL(gchandles)[i] = relocate(*FL(gchandles)[i]);
- trace_globals();
- relocate_typetable();
- rs = FL(readstate);
- while(rs){- value_t ent;
- for(i = 0; i < rs->backrefs.size; i++){- ent = (value_t)rs->backrefs.table[i];
- if(ent != (value_t)HT_NOTFOUND)
- rs->backrefs.table[i] = (void*)relocate(ent);
- }
- for(i = 0; i < rs->gensyms.size; i++){- ent = (value_t)rs->gensyms.table[i];
- if(ent != (value_t)HT_NOTFOUND)
- rs->gensyms.table[i] = (void*)relocate(ent);
- }
- rs->source = relocate(rs->source);
- rs = rs->prev;
- }
- FL(lasterror) = relocate(FL(lasterror));
- FL(memory_exception_value) = relocate(FL(memory_exception_value));
- FL(the_empty_vector) = relocate(FL(the_empty_vector));
- FL(the_empty_string) = relocate(FL(the_empty_string));
-
- sweep_finalizers();
-
-#if defined(VERBOSEGC)
- printf("GC: found %d/%d live conses\n",- (FL(curheap)-FL(tospace))/sizeof(cons_t), FL(heapsize)/sizeof(cons_t));
-#endif
- temp = FL(tospace);
- FL(tospace) = FL(fromspace);
- FL(fromspace) = temp;
-
- // if we're using > 80% of the space, resize tospace so we have
- // more space to fill next time. if we grew tospace last time,
- // grow the other half of the heap this time to catch up.
- if(FL(grew) || ((intptr_t)(FL(lim)-FL(curheap)) < (intptr_t)FL(heapsize)/5) || mustgrow){- temp = MEM_REALLOC(FL(tospace), FL(heapsize)*2);
- if(fl_unlikely(temp == nil))
- fl_raise(FL(memory_exception_value));
- FL(tospace) = temp;
- if(FL(grew)){- FL(heapsize) *= 2;
- temp = bitvector_resize(FL(consflags), 0, FL(heapsize)/sizeof(cons_t), 1);
- if(fl_unlikely(temp == nil))
- fl_raise(FL(memory_exception_value));
- FL(consflags) = (uint32_t*)temp;
- }
- FL(grew) = !FL(grew);
- }
- if(fl_unlikely((value_t*)FL(curheap) > (value_t*)FL(lim)-2)){- // all data was live; gc again and grow heap.
- // but also always leave at least 4 words available, so a closure
- // can be allocated without an extra check.
- fl_gc(0);
- }
-}
-
-void
-fl_grow_stack(void)
-{- size_t newsz = FL(nstack) * 2;
- value_t *ns = MEM_REALLOC(FL(stack), newsz*sizeof(value_t));
- if(fl_unlikely(ns == nil))
- lerrorf(FL_MemoryError, "stack overflow");
- FL(stack) = ns;
- FL(nstack) = newsz;
-}
-
-// utils ----------------------------------------------------------------------
-
-// apply function with n args on the stack
-fl_hotfn
-static value_t
-_applyn(uint32_t n)
-{- value_t f = FL(stack)[FL(sp)-n-1];
- uint32_t saveSP = FL(sp);
- value_t v;
- if(iscbuiltin(f))
- v = ((builtin_t*)ptr(f))[3](&FL(stack)[FL(sp)-n], n);
- else if(isfunction(f))
- v = apply_cl(n);
- else if(fl_likely(isbuiltin(f))){- value_t tab = symbol_value(FL_builtins_table_sym);
- if(fl_unlikely(ptr(tab) == nil))
- unbound_error(tab);
- FL(stack)[FL(sp)-n-1] = vector_elt(tab, uintval(f));
- v = apply_cl(n);
- }else{- type_error("function", f);- }
- FL(sp) = saveSP;
- return v;
-}
-
-value_t
-fl_apply(value_t f, value_t l)
-{- value_t v = l;
- uint32_t n = FL(sp);
-
- PUSH(f);
- while(iscons(v)){- PUSHSAFE(car_(v));
- v = cdr_(v);
- }
- if(v != FL_nil)
- lerrorf(FL_ArgError, "apply: last argument: not a list");
- n = FL(sp) - n - 1;
- v = _applyn(n);
- POPN(n+1);
- return v;
-}
-
-value_t
-fl_applyn(uint32_t n, value_t f, ...)
-{- va_list ap;
- va_start(ap, f);
- size_t i;
-
- PUSH(f);
- while(FL(sp)+n >= FL(nstack))
- fl_grow_stack();
- for(i = 0; i < n; i++){- value_t a = va_arg(ap, value_t);
- PUSH(a);
- }
- value_t v = _applyn(n);
- POPN(n+1);
- va_end(ap);
- return v;
-}
-
-value_t
-fl_listn(size_t n, ...)
-{- va_list ap;
- va_start(ap, n);
- uint32_t si = FL(sp);
- size_t i;
-
- while(FL(sp)+n >= FL(nstack))
- fl_grow_stack();
- for(i = 0; i < n; i++){- value_t a = va_arg(ap, value_t);
- PUSH(a);
- }
- cons_t *c = alloc_words(n*2);
- cons_t *l = c;
- for(i = 0; i < n; i++){- c->car = FL(stack)[si++];
- c->cdr = tagptr(c+1, TAG_CONS);
- c++;
- }
- c[-1].cdr = FL_nil;
-
- POPN(n);
- va_end(ap);
- return tagptr(l, TAG_CONS);
-}
-
-value_t
-fl_list2(value_t a, value_t b)
-{- PUSH(a);
- PUSH(b);
- cons_t *c = alloc_words(4);
- b = POP();
- a = POP();
- c[0].car = a;
- c[0].cdr = tagptr(c+1, TAG_CONS);
- c[1].car = b;
- c[1].cdr = FL_nil;
- return tagptr(c, TAG_CONS);
-}
-
-value_t
-fl_cons(value_t a, value_t b)
-{- PUSH(a);
- PUSH(b);
- value_t c = mk_cons();
- cdr_(c) = POP();
- car_(c) = POP();
- return c;
-}
-
-bool
-fl_isnumber(value_t v)
-{- if(isfixnum(v))
- return true;
- if(iscprim(v)){- cprim_t *c = ptr(v);
- return c->type != FL(runetype) && valid_numtype(c->type->numtype);
- }
- if(iscvalue(v)){- cvalue_t *c = ptr(v);
- return valid_numtype(cp_numtype(c));
- }
- return false;
-}
-
-// eval -----------------------------------------------------------------------
-
-fl_hotfn
-static value_t
-list(value_t *args, uint32_t nargs, int star)
-{- cons_t *c;
- uint32_t i;
- value_t v;
- v = cons_reserve(nargs);
- c = ptr(v);
- for(i = 0; i < nargs; i++){- c->car = args[i];
- c->cdr = tagptr(c+1, TAG_CONS);
- c++;
- }
- if(star)
- c[-2].cdr = c[-1].car;
- else
- c[-1].cdr = FL_nil;
- return v;
-}
-
-static value_t
-copy_list(value_t L)
-{- if(!iscons(L))
- return FL_nil;
- PUSH(FL_nil);
- PUSH(L);
- value_t *plcons = &FL(stack)[FL(sp)-2];
- value_t *pL = &FL(stack)[FL(sp)-1];
- value_t c;
- c = mk_cons(); PUSH(c); // save first cons
- car_(c) = car_(*pL);
- cdr_(c) = FL_nil;
- *plcons = c;
- *pL = cdr_(*pL);
- while(iscons(*pL)){- c = mk_cons();
- car_(c) = car_(*pL);
- cdr_(c) = FL_nil;
- cdr_(*plcons) = c;
- *plcons = c;
- *pL = cdr_(*pL);
- }
- c = POP(); // first cons
- POPN(2);
- return c;
-}
-
-static value_t
-do_trycatch(void)
-{- uint32_t saveSP = FL(sp);
- value_t v = FL_nil;
- value_t thunk = FL(stack)[FL(sp)-2];
- FL(stack)[FL(sp)-2] = FL(stack)[FL(sp)-1];
- FL(stack)[FL(sp)-1] = thunk;
-
- FL_TRY{- v = apply_cl(0);
- }
- FL_CATCH{- v = FL(stack)[saveSP-2];
- PUSH(v);
- PUSH(FL(lasterror));
- v = apply_cl(1);
- }
- FL(sp) = saveSP;
- return v;
-}
-
-/*
- argument layout on stack is
- |--required args--|--opt args--|--kw args--|--rest args...
-*/
-static uint32_t
-process_keys(value_t kwtable, uint32_t nreq, uint32_t nkw, uint32_t nopt, uint32_t bp, uint32_t nargs, int va)
-{- uint32_t extr = nopt+nkw;
- uint32_t ntot = nreq+extr;
- value_t args[64], v = FL_nil;
- uint32_t i, a = 0, nrestargs;
- value_t s1 = FL(stack)[FL(sp)-1];
- value_t s3 = FL(stack)[FL(sp)-3];
- value_t s4 = FL(stack)[FL(sp)-4];
- if(fl_unlikely(nargs < nreq))
- lerrorf(FL_ArgError, "too few arguments");
- if(fl_unlikely(extr > nelem(args)))
- lerrorf(FL_ArgError, "too many arguments");
- for(i = 0; i < extr; i++)
- args[i] = UNBOUND;
- for(i = nreq; i < nargs; i++){- v = FL(stack)[bp+i];
- if(issymbol(v) && iskeyword((symbol_t*)ptr(v)))
- break;
- if(a >= nopt)
- goto no_kw;
- args[a++] = v;
- }
- if(i >= nargs)
- goto no_kw;
- // now process keywords
- uintptr_t n = vector_size(kwtable)/2;
- do{- i++;
- if(fl_unlikely(i >= nargs))
- lerrorf(FL_ArgError, "keyword %s requires an argument", symbol_name(v));
- value_t hv = fixnum(((symbol_t*)ptr(v))->hash);
- fixnum_t lx = numval(hv);
- uintptr_t x = 2*((lx < 0 ? -lx : lx) % n);
- if(fl_likely(vector_elt(kwtable, x) == v)){- uintptr_t idx = numval(vector_elt(kwtable, x+1));
- assert(idx < nkw);
- idx += nopt;
- if(args[idx] == UNBOUND){- // if duplicate key, keep first value
- args[idx] = FL(stack)[bp+i];
- }
- }else{- lerrorf(FL_ArgError, "unsupported keyword %s", symbol_name(v));
- }
- i++;
- if(i >= nargs)
- break;
- v = FL(stack)[bp+i];
- }while(issymbol(v) && iskeyword((symbol_t*)ptr(v)));
-no_kw:
- nrestargs = nargs - i;
- if(fl_unlikely(!va && nrestargs > 0))
- lerrorf(FL_ArgError, "too many arguments");
- nargs = ntot + nrestargs;
- if(nrestargs)
- memmove(&FL(stack)[bp+ntot], &FL(stack)[bp+i], nrestargs*sizeof(value_t));
- memmove(&FL(stack)[bp+nreq], args, extr*sizeof(value_t));
- FL(sp) = bp + nargs;
- assert(FL(sp) < FL(nstack)-4);
- PUSH(s4);
- PUSH(s3);
- PUSH(nargs);
- PUSH(s1);
- FL(curr_frame) = FL(sp);
- return nargs;
-}
-
-#if BYTE_ORDER == LITTLE_ENDIAN && defined(MEM_UNALIGNED_ACCESS)
-#define GET_INT32(a) *(const int32_t*)(a)
-#define GET_INT16(a) *(const int16_t*)(a)
-#define PUT_INT32(a, i) \
- do{ \- *(uint32_t*)(a) = (uint32_t)(i); \
- }while(0)
-#else
-#define GET_INT32(a) (int32_t)((a)[0]<<0 | (a)[1]<<8 | (a)[2]<<16 | (uint32_t)(a)[3]<<24)
-#define GET_INT16(a) (int16_t)((a)[0]<<0 | (a)[1]<<8)
-#define PUT_INT32(a, i) \
- do{ \- ((uint8_t*)(a))[0] = (uint32_t)(i)>>0; \
- ((uint8_t*)(a))[1] = (uint32_t)(i)>>8; \
- ((uint8_t*)(a))[2] = (uint32_t)(i)>>16; \
- ((uint8_t*)(a))[3] = (uint32_t)(i)>>24; \
- }while(0)
-#endif
-
-/*
- stack on entry: <func> <nargs args...>
- caller's responsibility:
- - put the stack in this state
- - provide arg count
- - respect tail position
- - restore SP
-
- callee's responsibility:
- - check arg counts
- - allocate vararg array
- - push closed env, set up new environment
-*/
-static value_t
-apply_cl(uint32_t nargs)
-{- uint32_t top_frame = FL(curr_frame);
- uint32_t n, bp;
- const uint8_t *ip;
- fixnum_t s, hi;
- bool tail;
-
- // temporary variables (not necessary to preserve across calls)
- size_t isz;
- uint32_t i, ipd;
- symbol_t *sym;
- cons_t *c;
- value_t *pv;
- value_t func, v, e;
- int x;
-
- n = 0;
- v = 0;
- USED(n);
- USED(v);
-apply_cl_top:
- bp = FL(sp)-nargs;
- func = FL(stack)[bp-1];
- ip = cvalue_data(fn_bcode(func));
- assert(!ismanaged((uintptr_t)ip));
- i = FL(sp)+GET_INT32(ip);
- while(i >= FL(nstack))
- fl_grow_stack();
- ip += 4;
-
- PUSH(fn_env(func));
- PUSH(FL(curr_frame));
- PUSH(nargs);
- ipd = FL(sp);
- FL(sp)++; // ip
- FL(curr_frame) = FL(sp);
-
-#if defined(COMPUTED_GOTO)
-#pragma GCC diagnostic push
-#pragma GCC diagnostic ignored "-Wpedantic"
- static const void * const ops[] = {-#define GOTO_OP_OFFSET(op) [op] = &&op_##op
-#include "vm_goto.inc"
-#undef GOTO_OP_OFFSET
- };
-#define NEXT_OP goto *ops[*ip++]
-#define LABEL(x) x
-#define OP(x) op_##x:
- NEXT_OP;
-#include "vm.inc"
-#undef OP
-#undef LABEL
-#undef NEXT_OP
-#pragma GCC diagnostic pop
-#else /* just a usual (portable) switch/case */
- uint8_t op = *ip++;
- while(1){- switch(op){-#define NEXT_OP break
-#define LABEL(x) x
-#define OP(x) case x:
-#include "vm.inc"
-#undef OP
-#undef LABEL
-#undef NEXT_OP
- }
- op = *ip++;
- }
-#endif
-}
-
-#define SWAP_INT32(a)
-#define SWAP_INT16(a)
-#include "maxstack.inc"
-
-#if BYTE_ORDER == BIG_ENDIAN
-#undef SWAP_INT32
-#undef SWAP_INT16
-#define SWAP_INT32(a) \
- do{ \- uint8_t *x = (void*)a, y; \
- y = x[0]; x[0] = x[3]; x[3] = y; \
- y = x[1]; x[1] = x[2]; x[2] = y; \
- }while(0)
-#define SWAP_INT16(a) \
- do{ \- uint8_t *x = (void*)a, y; \
- y = x[0]; x[0] = x[1]; x[1] = y; \
- }while(0)
-#define compute_maxstack compute_maxstack_swap
-#include "maxstack.inc"
-#undef compute_maxstack
-#else
-#endif
-
-// top = top frame pointer to start at
-static value_t
-_stacktrace(uint32_t top)
-{- value_t lst = FL_nil;
-
- fl_gc_handle(&lst);
- while(top > 0){- const uint8_t *ip1 = (void*)FL(stack)[top-1];
- uint32_t sz = FL(stack)[top-2]+1;
- uint32_t bp = top-4-sz;
- value_t func = FL(stack)[bp];
- const uint8_t *ip0 = cvalue_data(fn_bcode(func));
- intptr_t ip = ip1 - ip0 - 1; /* -1: ip1 is *after* the one that was being executed */
- value_t v = alloc_vector(sz+1, 0);
- vector_elt(v, 0) = fixnum(ip);
- vector_elt(v, 1) = func;
- for(uint32_t i = 1; i < sz; i++){- value_t si = FL(stack)[bp+i];
- // if there's an error evaluating argument defaults some slots
- // might be left set to UNBOUND
- vector_elt(v, i+1) = si == UNBOUND ? FL_void : si;
- }
- lst = fl_cons(v, lst);
- top = FL(stack)[top-3];
- }
- fl_free_gc_handles(1);
- return lst;
-}
-
-// builtins -------------------------------------------------------------------
-
-BUILTIN("gc", gc)-{- USED(args);
- argcount(nargs, 0);
- fl_gc(0);
- return FL_void;
-}
-
-BUILTIN("function", function)-{- if(nargs == 1 && issymbol(args[0]))
- return fn_builtin_builtin(args, nargs);
- if(nargs < 2 || nargs > 4)
- argcount(nargs, 2);
- if(fl_unlikely(!fl_isstring(args[0])))
- type_error("string", args[0]);- if(fl_unlikely(!isvector(args[1])))
- type_error("vector", args[1]);- cvalue_t *arr = ptr(args[0]);
- cv_pin(arr);
- char *data = cv_data(arr);
- int ms;
- if((uint8_t)data[4] >= N_OPCODES){- // read syntax, shifted 48 for compact text representation
- size_t i, sz = cv_len(arr);
- for(i = 0; i < sz; i++)
- data[i] -= 48;
-#if BYTE_ORDER == BIG_ENDIAN
- ms = compute_maxstack((uint8_t*)data, cv_len(arr));
- }else{- ms = compute_maxstack_swap((uint8_t*)data, cv_len(arr));
- }
-#else
- }
- ms = compute_maxstack((uint8_t*)data, cv_len(arr));
-#endif
- if(ms < 0)
- lerrorf(FL_ArgError, "invalid bytecode");
- PUT_INT32(data, ms);
- function_t *fn = alloc_words(4);
- value_t fv = tagptr(fn, TAG_FUNCTION);
- fn->bcode = args[0];
- fn->vals = args[1];
- fn->env = FL_nil;
- fn->name = FL_lambda;
- if(nargs > 2){- if(issymbol(args[2])){- fn->name = args[2];
- if(nargs > 3)
- fn->env = args[3];
- }else{- fn->env = args[2];
- if(nargs > 3){- if(fl_unlikely(!issymbol(args[3])))
- type_error("symbol", args[3]);- fn->name = args[3];
- }
- }
- if(fl_unlikely(isgensym(fn->name)))
- lerrorf(FL_ArgError, "name should not be a gensym");
- }
- return fv;
-}
-
-fl_purefn
-BUILTIN("function:code", function_code)-{- argcount(nargs, 1);
- value_t v = args[0];
- if(fl_unlikely(!isclosure(v)))
- type_error("function", v);- return fn_bcode(v);
-}
-
-fl_purefn
-BUILTIN("function:vals", function_vals)-{- argcount(nargs, 1);
- value_t v = args[0];
- if(fl_unlikely(!isclosure(v)))
- type_error("function", v);- return fn_vals(v);
-}
-
-fl_purefn
-BUILTIN("function:env", function_env)-{- argcount(nargs, 1);
- value_t v = args[0];
- if(fl_unlikely(!isclosure(v)))
- type_error("function", v);- return fn_env(v);
-}
-
-BUILTIN("function:name", function_name)-{- argcount(nargs, 1);
- value_t v = args[0];
- if(isclosure(v))
- return fn_name(v);
- if(isbuiltin(v))
- return symbol(builtins[uintval(v)].name, false);
- if(iscbuiltin(v)){- v = (value_t)ptrhash_get(&FL(reverse_dlsym_lookup_table), ptr(v));
- if(v == (value_t)HT_NOTFOUND)
- return FL_f;
- return v;
- }
- type_error("function", v);-}
-
-BUILTIN("copy-list", copy_list)-{- argcount(nargs, 1);
- return copy_list(args[0]);
-}
-
-BUILTIN("append", append)-{- value_t first = FL_nil, lst, lastcons = FL_nil;
- uint32_t i;
- if(nargs == 0)
- return FL_nil;
- fl_gc_handle(&first);
- fl_gc_handle(&lastcons);
- for(i = 0; i < nargs; i++){- lst = args[i];
- if(iscons(lst)){- lst = copy_list(lst);
- if(first == FL_nil)
- first = lst;
- else
- cdr_(lastcons) = lst;
- lastcons = tagptr((((cons_t*)FL(curheap))-1), TAG_CONS);
- }else if(lst != FL_nil){- type_error("cons", lst);- }
- }
- fl_free_gc_handles(2);
- return first;
-}
-
-BUILTIN("list*", liststar)-{- if(nargs == 1)
- return args[0];
- if(nargs == 0)
- argcount(nargs, 1);
- return list(args, nargs, 1);
-}
-
-BUILTIN("stacktrace", stacktrace)-{- USED(args);
- argcount(nargs, 0);
- return _stacktrace(FL(throwing_frame) ? FL(throwing_frame) : FL(curr_frame));
-}
-
-BUILTIN("map", map)-{- if(fl_unlikely(nargs < 2))
- lerrorf(FL_ArgError, "too few arguments");
- intptr_t argSP = args-FL(stack);
- assert(argSP >= 0 && argSP < (intptr_t)FL(nstack));
- while(FL(sp)+2+1+nargs >= FL(nstack))
- fl_grow_stack();
- uint32_t k = FL(sp);
- PUSH(FL_nil);
- PUSH(FL_nil);
- for(bool first = true;;){- PUSH(FL(stack)[argSP]);
- for(uint32_t i = 1; i < nargs; i++){- if(!iscons(FL(stack)[argSP+i])){- POPN(2+i);
- return FL(stack)[k+1];
- }
- PUSH(car(FL(stack)[argSP+i]));
- FL(stack)[argSP+i] = cdr_(FL(stack)[argSP+i]);
- }
- value_t v = _applyn(nargs-1);
- POPN(nargs);
- PUSH(v);
- value_t c = mk_cons();
- car_(c) = POP(); cdr_(c) = FL_nil;
- if(first)
- FL(stack)[k+1] = c;
- else
- cdr_(FL(stack)[k]) = c;
- FL(stack)[k] = c;
- first = false;
- }
-}
-
-BUILTIN("for-each", for_each)-{- if(fl_unlikely(nargs < 2))
- lerrorf(FL_ArgError, "too few arguments");
- intptr_t argSP = args-FL(stack);
- assert(argSP >= 0 && argSP < (intptr_t)FL(nstack));
- if(FL(sp)+1+2*nargs >= FL(nstack))
- fl_grow_stack();
- for(size_t n = 0;; n++){- PUSH(FL(stack)[argSP]);
- uint32_t pargs = 0;
- for(uint32_t i = 1; i < nargs; i++, pargs++){- value_t v = FL(stack)[argSP+i];
- if(iscons(v)){- PUSH(car_(v));
- FL(stack)[argSP+i] = cdr_(v);
- continue;
- }
- if(isvector(v)){- size_t sz = vector_size(v);
- if(n < sz){- PUSH(vector_elt(v, n));
- continue;
- }
- }
- if(isarray(v)){- size_t sz = cvalue_arraylen(v);
- if(n < sz){- value_t a[2];
- a[0] = v;
- a[1] = fixnum(n);
- PUSH(cvalue_array_aref(a));
- continue;
- }
- }
- if(ishashtable(v)){- htable_t *h = totable(v);
- assert(n != 0 || h->i == 0);
- void **table = h->table;
- for(; h->i < h->size; h->i += 2){- if(table[h->i+1] != HT_NOTFOUND)
- break;
- }
- if(h->i < h->size){- PUSH((value_t)table[h->i]);
- pargs++;
- PUSH((value_t)table[h->i+1]);
- h->i += 2;
- continue;
- }
- h->i = 0;
- }
- POPN(pargs+1);
- return FL_void;
- }
- _applyn(pargs);
- POPN(pargs+1);
- }
-}
-
-BUILTIN("sleep", fl_sleep)-{- if(nargs > 1)
- argcount(nargs, 1);
- double s = nargs > 0 ? todouble(args[0]) : 0;
- sleep_ms(s * 1000.0);
- return FL_void;
-}
-
-BUILTIN("vm-stats", vm_stats)-{- USED(args);
- argcount(nargs, 0);
- ios_printf(ios_stderr, "heap total %10"PRIuPTR"\n", FL(heapsize));
- ios_printf(ios_stderr, "heap free %10"PRIuPTR"\n", (uintptr_t)(FL(lim)-FL(curheap)));
- ios_printf(ios_stderr, "heap used %10"PRIuPTR"\n", (uintptr_t)(FL(curheap)-FL(fromspace)));
- ios_printf(ios_stderr, "stack %10"PRIu64"\n", (uint64_t)FL(nstack)*sizeof(value_t));
- ios_printf(ios_stderr, "gc calls %10"PRIu64"\n", (uint64_t)FL(gccalls));
- ios_printf(ios_stderr, "max finalizers %10"PRIu32"\n", (uint32_t)FL(maxfinalizers));
- ios_printf(ios_stderr, "opcodes %10d\n", N_OPCODES);
- return FL_void;
-}
-
-static const builtinspec_t builtin_fns[] = {-#define BUILTIN_FN(l, c, attr){l, (builtin_t)fn_builtin_##c},-#include "builtin_fns.h"
-#undef BUILTIN_FN
-};
-
-// initialization -------------------------------------------------------------
-
-int
-fl_init(size_t initial_heapsize)
-{- int i;
-
- if((fl = MEM_CALLOC(1, sizeof(*fl))) == nil)
- return -1;
- FL(scr_width) = 100;
-
- FL(heapsize) = initial_heapsize;
-
- if((FL(fromspace) = MEM_ALLOC(FL(heapsize))) == nil){-failed:
- MEM_FREE(FL(fromspace));
- MEM_FREE(FL(tospace));
- MEM_FREE(FL(consflags));
- MEM_FREE(FL(stack));
- htable_free(&FL(printconses));
- MEM_FREE(fl);
- return -1;
- }
- if((FL(tospace) = MEM_ALLOC(FL(heapsize))) == nil)
- goto failed;
- if((FL(consflags) = bitvector_new(FL(heapsize)/sizeof(cons_t), 1)) == nil)
- goto failed;
- if((htable_new(&FL(printconses), 32)) == nil)
- goto failed;
- FL(curheap) = FL(fromspace);
- FL(lim) = FL(curheap)+FL(heapsize)-sizeof(cons_t);
- FL(nstack) = 4096;
- if((FL(stack) = MEM_ALLOC(FL(nstack)*sizeof(value_t))) == nil)
- goto failed;
- comparehash_init();
-
- FL_lambda = symbol("λ", false);- FL_function = symbol("function", false);- FL_quote = symbol("quote", false);- FL_trycatch = symbol("trycatch", false);- FL_backquote = symbol("quasiquote", false);- FL_comma = symbol("unquote", false);- FL_commaat = symbol("unquote-splicing", false);- FL_commadot = symbol("unquote-nsplicing", false);- FL_IOError = symbol("io-error", false);- FL_ParseError = symbol("parse-error", false);- FL_TypeError = symbol("type-error", false);- FL_ArgError = symbol("arg-error", false);- FL_UnboundError = symbol("unbound-error", false);- FL_KeyError = symbol("key-error", false);- FL_MemoryError = symbol("memory-error", false);- FL_BoundsError = symbol("bounds-error", false);- FL_DivideError = symbol("divide-error", false);- FL_EnumerationError = symbol("enumeration-error", false);- FL_Error = symbol("error", false);- FL_conssym = symbol("cons", false);- FL_symbolsym = symbol("symbol", false);- FL_fixnumsym = symbol("fixnum", false);- FL_vectorsym = symbol("vector", false);- FL_builtinsym = symbol("builtin", false);- FL_booleansym = symbol("boolean", false);- FL_nullsym = symbol("null", false);- FL_definesym = symbol("define", false);- FL_defmacrosym = symbol("define-macro", false);- FL_forsym = symbol("for", false);- FL_setqsym = symbol("set!", false);- FL_evalsym = symbol("eval", false);- FL_vu8sym = symbol("vu8", false);- FL_fnsym = symbol("fn", false);- FL_nulsym = symbol("nul", false);- FL_alarmsym = symbol("alarm", false);- FL_backspacesym = symbol("backspace", false);- FL_tabsym = symbol("tab", false);- FL_linefeedsym = symbol("linefeed", false);- FL_vtabsym = symbol("vtab", false);- FL_pagesym = symbol("page", false);- FL_returnsym = symbol("return", false);- FL_escsym = symbol("esc", false);- FL_spacesym = symbol("space", false);- FL_deletesym = symbol("delete", false);- FL_newlinesym = symbol("newline", false);- FL_tsym = symbol("t", false);- FL_Tsym = symbol("T", false);- FL_fsym = symbol("f", false);- FL_Fsym = symbol("F", false);- FL_builtins_table_sym = symbol("*builtins*", false);-
- set(FL_printprettysym = symbol("*print-pretty*", false), FL_t);- set(FL_printreadablysym = symbol("*print-readably*", false), FL_t);- set(FL_printwidthsym = symbol("*print-width*", false), fixnum(FL(scr_width)));- set(FL_printlengthsym = symbol("*print-length*", false), FL_f);- set(FL_printlevelsym = symbol("*print-level*", false), FL_f);- FL(lasterror) = FL_nil;
-
- for(i = 0; i < nelem(builtins); i++){- if(builtins[i].name)
- set(symbol(builtins[i].name, false), builtin(i));
- }
- set(symbol("procedure?", false), builtin(OP_FUNCTIONP));- set(symbol("top-level-bound?", false), builtin(OP_BOUNDP));-
- FL(the_empty_vector) = tagptr(alloc_words(1), TAG_VECTOR);
- vector_setsize(FL(the_empty_vector), 0);
-
- cvalues_init();
-
- set(symbol("*os-name*", false), cvalue_static_cstring(__os_name__));-#if defined(__os_version__)
- set(symbol("*os-version*", false), cvalue_static_cstring(__os_version__));-#endif
- FL(memory_exception_value) = fl_list2(FL_MemoryError, cvalue_static_cstring("out of memory"));-
- const builtinspec_t *b;
- for(i = 0, b = builtin_fns; i < nelem(builtin_fns); i++, b++)
- set(symbol(b->name, false), cbuiltin(b->name, b->fptr));
- table_init();
- iostream_init();
- compress_init();
- return 0;
-}
-
-// top level ------------------------------------------------------------------
-
-value_t
-fl_toplevel_eval(value_t expr)
-{- return fl_applyn(1, symbol_value(FL_evalsym), expr);
-}
-
-int
-fl_load_system_image(value_t sys_image_iostream)
-{- value_t e;
- uint32_t saveSP;
- symbol_t *sym;
-
- PUSH(sys_image_iostream);
- saveSP = FL(sp);
- FL_TRY{- while(1){- e = fl_read_sexpr(FL(stack)[FL(sp)-1]);
- if(ios_eof(value2c(ios_t*, FL(stack)[FL(sp)-1])))
- break;
- if(isfunction(e)){- // stage 0 format: series of thunks
- PUSH(e);
- (void)_applyn(0);
- FL(sp) = saveSP;
- }else{- // stage 1 format: list alternating symbol/value
- while(iscons(e)){- sym = tosymbol(car_(e));
- e = cdr_(e);
- (void)tocons(e);
- sym->binding = car_(e);
- e = cdr_(e);
- }
- break;
- }
- }
- }
- FL_CATCH_NO_INC{- ios_puts(ios_stderr, "fatal error during bootstrap: ");
- fl_print(ios_stderr, FL(lasterror));
- ios_putc(ios_stderr, '\n');
- return 1;
- }
- ios_close(value2c(ios_t*, FL(stack)[FL(sp)-1]));
- POPN(1);
- return 0;
-}
--- a/flisp.h
+++ /dev/null
@@ -1,452 +1,0 @@
-#pragma once
-
-#include "platform.h"
-#include "utf8.h"
-#include "ios.h"
-#include "tbl.h"
-#include "bitvector.h"
-#include "htableh.inc"
-HTPROT(ptrhash)
-
-typedef struct fltype_t fltype_t;
-
-enum {- TAG_NUM,
- TAG_CPRIM,
- TAG_FUNCTION,
- TAG_VECTOR,
- TAG_NUM1,
- TAG_CVALUE,
- TAG_SYM,
- TAG_CONS,
-
- /* those were set to 7 and 3 strategically on purpose */
- TAG_NONLEAF_MASK = TAG_CONS & TAG_VECTOR,
-};
-
-enum {- FLAG_CONST = 1<<0,
- FLAG_KEYWORD = 1<<1,
-};
-
-typedef enum {- T_INT8, T_UINT8,
- T_INT16, T_UINT16,
- T_INT32, T_UINT32,
- T_INT64, T_UINT64,
- T_MPINT,
- T_FLOAT,
- T_DOUBLE,
-}numerictype_t;
-
-typedef uintptr_t value_t;
-
-#ifdef BITS64
-typedef int64_t fixnum_t;
-#define FIXNUM_BITS 62
-#define TOP_BIT (1ULL<<63)
-#define T_FIXNUM T_INT64
-#define PRIdFIXNUM PRId64
-#else
-typedef int32_t fixnum_t;
-#define FIXNUM_BITS 30
-#define TOP_BIT (1U<<31)
-#define T_FIXNUM T_INT32
-#define PRIdFIXNUM PRId32
-#endif
-
-#define ALIGNED(x, sz) (((x) + (sz-1)) & (-sz))
-
-typedef struct {- value_t car;
- value_t cdr;
-}fl_aligned(8) cons_t;
-
-// NOTE: symbol_t MUST have the same fields as gensym_t first
-// there are places where gensyms are treated as normal symbols
-typedef struct {- fltype_t *type;
- value_t binding; // global value binding
- uint32_t hash;
- uint8_t numtype;
- uint8_t size;
- uint8_t flags;
- uint8_t _dummy;
- const char *name;
-}fl_aligned(8) symbol_t;
-
-typedef struct {- fltype_t *type;
- value_t binding;
- uint32_t id;
-}fl_aligned(8) gensym_t;
-
-typedef struct Builtin Builtin;
-
-struct Builtin {- const char *name;
- int nargs;
-};
-
-typedef value_t (*builtin_t)(value_t*, uint32_t);
-
-#define fits_bits(x, b) (((x)>>(b-1)) == 0 || (~((x)>>(b-1))) == 0)
-#define fits_fixnum(x) fits_bits(x, FIXNUM_BITS)
-
-#define ANYARGS -10000
-#define NONNUMERIC (0xff)
-#define valid_numtype(v) ((v) <= T_DOUBLE)
-#define UNBOUND ((value_t)1) // an invalid value
-#define TAG_FWD UNBOUND
-#define tag(x) ((x) & 7)
-#define ptr(x) ((void*)((uintptr_t)(x) & (~(uintptr_t)7)))
-#define tagptr(p, t) ((value_t)(p) | (t))
-#define fixnum(x) ((value_t)(x)<<2)
-#define numval(x) ((fixnum_t)(x)>>2)
-#define uintval(x) (((unsigned int)(x))>>3)
-#define builtin(n) tagptr(((value_t)n<<3), TAG_FUNCTION)
-#define iscons(x) (tag(x) == TAG_CONS)
-#define issymbol(x) (tag(x) == TAG_SYM)
-#define isfixnum(x) (((x)&3) == TAG_NUM)
-#define bothfixnums(x, y) ((((x)|(y)) & 3) == TAG_NUM)
-#define isvector(x) (tag(x) == TAG_VECTOR)
-#define iscvalue(x) (tag(x) == TAG_CVALUE)
-#define iscprim(x) (tag(x) == TAG_CPRIM)
-// doesn't lead to other values
-#define leafp(a) (((a)&TAG_NONLEAF_MASK) != TAG_NONLEAF_MASK)
-
-// allocate n consecutive conses
-#define cons_reserve(n) tagptr(alloc_words((n)*2), TAG_CONS)
-#define cons_index(c) (((cons_t*)ptr(c))-((cons_t*)FL(fromspace)))
-#define ismarked(c) bitvector_get(FL(consflags), cons_index(c))
-#define mark_cons(c) bitvector_set(FL(consflags), cons_index(c))
-#define unmark_cons(c) bitvector_reset(FL(consflags), cons_index(c))
-
-#define isforwarded(v) (((value_t*)ptr(v))[0] == TAG_FWD)
-#define forwardloc(v) (((value_t*)ptr(v))[1])
-#define forward(v, to) \
- do{ \- (((value_t*)ptr(v))[0] = TAG_FWD); \
- (((value_t*)ptr(v))[1] = to); \
- }while (0)
-
-#define vector_size(v) (((size_t*)ptr(v))[0]>>2)
-#define vector_setsize(v, n) (((size_t*)ptr(v))[0] = ((n)<<2))
-#define vector_elt(v, i) (((value_t*)ptr(v))[1+(i)])
-#define vector_grow_amt(x) ((x)<8 ? 5 : 6*((x)>>3))
-// functions ending in _ are unsafe, faster versions
-#define car_(v) (((cons_t*)ptr(v))->car)
-#define cdr_(v) (((cons_t*)ptr(v))->cdr)
-#define car(v) (tocons((v))->car)
-#define cdr(v) (tocons((v))->cdr)
-#define fn_bcode(f) (((value_t*)ptr(f))[0])
-#define fn_vals(f) (((value_t*)ptr(f))[1])
-#define fn_env(f) (((value_t*)ptr(f))[2])
-#define fn_name(f) (((value_t*)ptr(f))[3])
-#define set(s, v) (((symbol_t*)ptr(s))->binding = (v))
-#define setc(s, v) \
- do{ \- ((symbol_t*)ptr(s))->flags |= FLAG_CONST; \
- ((symbol_t*)ptr(s))->binding = (v); \
- }while (0)
-#define isconstant(s) ((s)->flags & FLAG_CONST)
-#define iskeyword(s) ((s)->flags & FLAG_KEYWORD)
-#define symbol_value(s) (((symbol_t*)ptr(s))->binding)
-#define sym_to_numtype(s) (((symbol_t*)ptr(s))->numtype)
-#define ismanaged(v) ((((uint8_t*)ptr(v)) >= FL(fromspace)) && (((uint8_t*)ptr(v)) < FL(fromspace)+FL(heapsize)))
-#define isgensym(x) (issymbol(x) && ismanaged(x))
-#define isfunction(x) (tag(x) == TAG_FUNCTION && (x) > (N_BUILTINS<<3))
-#define isclosure(x) isfunction(x)
-#define iscbuiltin(x) (iscvalue(x) && cv_class(ptr(x)) == FL(builtintype))
-// utility for iterating over all arguments in a builtin
-// i=index, i0=start index, arg = var for each arg, args = arg array
-// assumes "nargs" is the argument count
-#define FOR_ARGS(i, i0, arg, args) for(i=i0; i<nargs && ((arg=args[i]) || 1); i++)
-#define N_BUILTINS ((int)N_OPCODES)
-
-#define PUSH(v) \
- do{ \- FL(stack)[FL(sp)++] = (v); \
- }while(0)
-#define PUSHSAFE(v) \
- do{ \- if(FL(sp) >= FL(nstack)) \
- fl_grow_stack(); \
- PUSH(v); \
- }while(0)
-#define POPN(n) \
- do{ \- FL(sp) -= (n); \
- }while(0)
-#define POP() (FL(stack)[--FL(sp)])
-
-bool isbuiltin(value_t x) fl_constfn fl_hotfn;
-int fl_init(size_t initial_heapsize);
-int fl_load_system_image(value_t ios);
-
-_Noreturn void fl_exit(int status);
-
-/* collector */
-value_t relocate(value_t v) fl_hotfn;
-void fl_gc(int mustgrow);
-void fl_grow_stack(void);
-void fl_gc_handle(value_t *pv);
-void fl_free_gc_handles(uint32_t n);
-
-/* symbol table */
-value_t gensym(void);
-value_t symbol(const char *str, bool copy) fl_hotfn;
-const char *symbol_name(value_t v);
-
-/* read, eval, print main entry points */
-value_t fl_toplevel_eval(value_t expr);
-value_t fl_apply(value_t f, value_t l);
-value_t fl_applyn(uint32_t n, value_t f, ...);
-
-/* object model manipulation */
-value_t fl_cons(value_t a, value_t b);
-value_t fl_list2(value_t a, value_t b);
-value_t fl_listn(size_t n, ...);
-bool fl_isnumber(value_t v) fl_purefn;
-value_t alloc_vector(size_t n, int init);
-
-/* safe casts */
-cons_t *tocons(value_t v) fl_purefn;
-symbol_t *tosymbol(value_t v) fl_purefn;
-fixnum_t tofixnum(value_t v) fl_purefn;
-char *tostring(value_t v) fl_purefn;
-double todouble(value_t a) fl_purefn;
-
-/* conses */
-value_t mk_cons(void) fl_hotfn;
-void *alloc_words(uint32_t n) fl_hotfn;
-
-char *uint2str(char *dest, size_t len, uint64_t num, uint32_t base);
-
-/* error handling */
-typedef struct _fl_readstate_t {- htable_t backrefs;
- htable_t gensyms;
- value_t source;
- struct _fl_readstate_t *prev;
-}fl_readstate_t;
-
-typedef struct _ectx_t {- fl_readstate_t *rdst;
- struct _ectx_t *prev;
- jmp_buf buf;
- uint32_t sp;
- uint32_t frame;
- uint32_t ngchnd;
-}fl_exception_context_t;
-
-void free_readstate(fl_readstate_t *rs);
-
-#define FL_TRY_EXTERN \
- fl_exception_context_t _ctx; int l__tr, l__ca; \
- fl_savestate(&_ctx); FL(exctx) = &_ctx; \
- if(!setjmp(_ctx.buf)) \
- for(l__tr=1; l__tr; l__tr=0, (void)(FL(exctx) = FL(exctx)->prev))
-
-#define FL_CATCH_EXTERN_NO_RESTORE \
- else \
- for(l__ca=1; l__ca;)
-
-#define FL_CATCH_EXTERN \
- else \
- for(l__ca=1; l__ca; l__ca=0, fl_restorestate(&_ctx))
-
-_Noreturn void lerrorf(value_t e, const char *format, ...) fl_printfmt(2, 3);
-void fl_savestate(fl_exception_context_t *_ctx);
-void fl_restorestate(fl_exception_context_t *_ctx);
-_Noreturn void fl_raise(value_t e);
-_Noreturn void type_error(const char *expected, value_t got);
-_Noreturn void bounds_error(value_t arr, value_t ind);
-_Noreturn void unbound_error(value_t sym);
-
-#define argcount(nargs, c) \
- do{ \- if(fl_unlikely(nargs != c)) \
- lerrorf(FL_ArgError, "arity mismatch: wanted %"PRIu32", got %"PRIu32, (uint32_t)c, nargs); \
- }while(0)
-
-typedef struct {- void (*print)(value_t self, ios_t *f);
- void (*relocate)(value_t oldv, value_t newv);
- void (*finalize)(value_t self);
- void (*print_traverse)(value_t self);
-} cvtable_t;
-
-typedef int (*cvinitfunc_t)(fltype_t*, value_t, void*);
-
-struct fltype_t {- value_t type;
- cvtable_t *vtable;
- fltype_t *eltype; // for arrays
- fltype_t *artype; // (array this)
- cvinitfunc_t init;
- size_t size;
- size_t elsz;
- numerictype_t numtype;
-};
-
-typedef struct {- fltype_t *type;
- void *data;
- size_t len; // length of *data in bytes
- union {- value_t parent; // optional
- uint8_t _space[1]; // variable size
- };
-}fl_aligned(8) cvalue_t;
-
-typedef struct {- fltype_t *type;
- uint8_t _space[];
-}fl_aligned(8) cprim_t;
-
-typedef struct {- value_t bcode;
- value_t vals;
- value_t env;
- value_t name;
-}fl_aligned(8) function_t;
-
-#define CPRIM_NWORDS 2
-#define cv_class(cv) ((fltype_t*)(((uintptr_t)((cvalue_t*)cv)->type)&~(uintptr_t)3))
-#define cv_len(cv) (((cvalue_t*)(cv))->len)
-#define cv_type(cv) (cv_class(cv)->type)
-#define cv_data(cv) (((cvalue_t*)(cv))->data)
-#define cv_isstr(cv) (cv_class(cv)->eltype == FL(bytetype))
-#define cv_isPOD(cv) (cv_class(cv)->init != nil)
-#define cvalue_data(v) cv_data((cvalue_t*)ptr(v))
-#define cvalue_len(v) cv_len((cvalue_t*)ptr(v))
-#define value2c(type, v) ((type)cvalue_data(v))
-#define cp_class(cp) (((cprim_t*)(cp))->type)
-#define cp_type(cp) (cp_class(cp)->type)
-#define cp_numtype(cp) (cp_class(cp)->numtype)
-#define cp_data(cp) (&((cprim_t*)(cp))->_space[0])
-// WARNING: multiple evaluation!
-#define cptr(v) (iscprim(v) ? cp_data(ptr(v)) : cvalue_data(v))
-
-#define BUILTIN(lname, cname) \
- value_t fn_builtin_##cname(value_t *args, uint32_t nargs)
-
-#define BUILTIN_FN(l, c, attr) attr BUILTIN(l, c);
-#include "builtin_fns.h"
-#undef BUILTIN_FN
-
-#include "opcodes.h"
-
-enum {- FL_nil = builtin(OP_LOADNIL),
- FL_t = builtin(OP_LOADT),
- FL_f = builtin(OP_LOADF),
- FL_void = builtin(OP_LOADVOID),
- FL_eof = builtin(OP_EOF_OBJECT),
-};
-
-#define N_GC_HANDLES 1024
-
-typedef struct Fl Fl;
-
-struct Fl {- value_t *stack;
- uint32_t sp;
- uint32_t nstack;
- uintptr_t heapsize;//bytes
- uint8_t *fromspace;
- uint32_t curr_frame;
-
- uint8_t *tospace;
- uint8_t *curheap;
- uint8_t *lim;
-
- size_t malloc_pressure;
-
- cvalue_t **finalizers;
- size_t nfinalizers;
- size_t maxfinalizers;
-
- fl_readstate_t *readstate;
- Tbl *symtab;
-
- // saved execution state for an unwind target
- fl_exception_context_t *exctx;
- uint32_t throwing_frame; // active frame when exception was thrown
- value_t lasterror;
-
- fltype_t *tabletype;
-
- fltype_t *iostreamtype;
-
- value_t the_empty_vector;
- value_t the_empty_string;
- value_t memory_exception_value;
-
- fltype_t *mpinttype;
- fltype_t *int8type, *uint8type;
- fltype_t *int16type, *uint16type;
- fltype_t *int32type, *uint32type;
- fltype_t *int64type, *uint64type;
- fltype_t *longtype, *ulongtype;
- fltype_t *floattype, *doubletype;
- fltype_t *bytetype, *runetype;
- fltype_t *stringtype, *runestringtype;
- fltype_t *builtintype;
-
- uint32_t gensym_ctr;
- // two static buffers for gensym printing so there can be two
- // gensym names available at a time, mostly for compare()
- char gsname[2][16];
- int gsnameno;
-
- bool exiting;
- bool grew;
-
- uint32_t *consflags;
- size_t gccalls;
-
- htable_t printconses;
- uint32_t printlabel;
- int print_pretty;
- int print_princ;
- fixnum_t print_length;
- fixnum_t print_level;
- fixnum_t p_level;
- int scr_width;
- int hpos, vpos;
-
- htable_t reverse_dlsym_lookup_table;
- htable_t TypeTable;
- uint32_t ngchandles;
- value_t *gchandles[N_GC_HANDLES];
-};
-
-extern fl_thread(Fl *fl);
-#define FL(f) fl->f
-
-extern value_t FL_builtins_table_sym, FL_quote, FL_lambda, FL_function, FL_comma, FL_commaat;
-extern value_t FL_commadot, FL_trycatch, FL_backquote;
-extern value_t FL_conssym, FL_symbolsym, FL_fixnumsym, FL_vectorsym, FL_builtinsym, FL_vu8sym;
-extern value_t FL_definesym, FL_defmacrosym, FL_forsym, FL_setqsym;
-extern value_t FL_tsym, FL_Tsym, FL_fsym, FL_Fsym, FL_booleansym, FL_nullsym, FL_evalsym, FL_fnsym;
-extern value_t FL_nulsym, FL_alarmsym, FL_backspacesym, FL_tabsym, FL_linefeedsym, FL_newlinesym;
-extern value_t FL_vtabsym, FL_pagesym, FL_returnsym, FL_escsym, FL_spacesym, FL_deletesym;
-extern value_t FL_IOError, FL_ParseError, FL_TypeError, FL_ArgError, FL_MemoryError;
-extern value_t FL_DivideError, FL_BoundsError, FL_Error, FL_KeyError, FL_EnumerationError;
-extern value_t FL_UnboundError;
-extern value_t FL_sizesym, FL_tosym;
-extern value_t FL_fsosym;
-
-extern value_t FL_printwidthsym, FL_printreadablysym, FL_printprettysym, FL_printlengthsym;
-extern value_t FL_printlevelsym;
-extern value_t FL_tablesym, FL_arraysym;
-extern value_t FL_iostreamsym, FL_rdsym, FL_wrsym, FL_apsym, FL_crsym, FL_truncsym;
-extern value_t FL_instrsym, FL_outstrsym;
-extern value_t FL_int8sym, FL_uint8sym, FL_int16sym, FL_uint16sym, FL_int32sym, FL_uint32sym;
-extern value_t FL_int64sym, FL_uint64sym, FL_bignumsym;
-extern value_t FL_bytesym, FL_runesym, FL_floatsym, FL_doublesym;
-extern value_t FL_stringtypesym, FL_runestringtypesym;
-
-_Noreturn void flmain(const uint8_t *boot, int bootsz, int argc, char **argv);
--- a/flmain.c
+++ /dev/null
@@ -1,71 +1,0 @@
-#include "flisp.h"
-#include "cvalues.h"
-#include "print.h"
-#include "iostream.h"
-#include "random.h"
-#include "brieflz.h"
-#include "nan.h"
-
-static value_t
-argv_list(int argc, char *argv[])
-{- int i;
- value_t lst = FL_nil, temp;
- fl_gc_handle(&lst);
- fl_gc_handle(&temp);
- for(i = argc-1; i >= 0; i--){- temp = cvalue_static_cstring(argv[i]);
- lst = fl_cons(temp, lst);
- }
- fl_free_gc_handles(2);
- return lst;
-}
-
-_Noreturn void
-flmain(const uint8_t *boot, int bootsz, int argc, char **argv)
-{- nan_init();
- randomize();
- ios_init_stdstreams();
- mpsetminbits(sizeof(fixnum_t)*8);
-
- if(fl_init(INITIAL_HEAP_SIZE) != 0)
- exit(1);
-
- value_t f = cvalue(FL(iostreamtype), (int)sizeof(ios_t));
- ios_t *s = value2c(ios_t*, f);
- uint8_t *unpacked = nil;
- if(boot[0] == 0){- uint32_t unpackedsz =
- boot[1]<<0 |
- boot[2]<<8 |
- boot[3]<<16|
- boot[4]<<24;
- unpacked = MEM_ALLOC(unpackedsz);
- unsigned long n = blz_depack_safe(boot+5, bootsz-5, unpacked, unpackedsz);
- if(n == BLZ_ERROR){- ios_puts(ios_stderr, "failed to unpack boot image\n");
- fl_exit(1);
- }
- boot = unpacked;
- bootsz = n;
- }
- ios_static_buffer(s, boot, bootsz);
-
- int r = 1;
- FL_TRY_EXTERN{- if(fl_load_system_image(f) == 0){- MEM_FREE(unpacked);
- ios_close(s);
- fl_applyn(1, symbol_value(symbol("__start", false)), argv_list(argc, argv));- r = 0;
- }
- }
- FL_CATCH_EXTERN_NO_RESTORE{- ios_puts(ios_stderr, "fatal error:\n");
- fl_print(ios_stderr, FL(lasterror));
- ios_putc(ios_stderr, '\n');
- break;
- }
- fl_exit(r);
-}
--- a/gen.lsp
+++ /dev/null
@@ -1,179 +1,0 @@
-(define opcodes '(
- ; C opcode, lisp compiler opcode, arg count, builtin lambda, DOC (NEW)
- OP_LOADA0 loada0 #f 0 ()
- OP_LOADA1 loada1 #f 0 ()
- OP_LOADV loadv #f 0 ()
- OP_BRF brf #f 0 ()
- OP_POP pop #f 0 ()
- OP_CALL call #f 0 ()
- OP_TCALL tcall #f 0 ()
- OP_LOADG loadg #f 0 ()
- OP_LOADA loada #f 0 ()
- OP_LOADC loadc #f 0 ()
- OP_RET ret #f 0 ()
- OP_DUP dup #f 0 ()
- OP_CAR car 1 (λ (x) (car x)) (
- ((lst) "Returns the first element of a list or nil if not available."))
- OP_CDR cdr 1 (λ (x) (cdr x)) (
- ((lst) "Returns the tail of a list or nil if not available."))
- OP_CLOSURE closure #f 0 ()
- OP_SETA seta #f 0 ()
- OP_JMP jmp #f 0 ()
- OP_LOADC0 loadc0 #f 0 ()
- OP_CONSP cons? 1 (λ (x) (cons? x)) (
- ((value) "Returns #t if the value is a cons cell."))
- OP_BRNE brne #f 0 ()
- OP_LOADT loadt #f 0 ()
- OP_LOAD0 load0 #f 0 ()
- OP_LOADC1 loadc1 #f 0 ()
- OP_AREF2 aref2 #f 0 ()
- OP_ATOMP atom? 1 (λ (x) (atom? x)) ()
- OP_BRT brt #f 0 ()
- OP_BRNN brnn #f 0 ()
- OP_LOAD1 load1 #f 0 ()
- OP_LT < -1 (λ rest (apply < rest)) ()
- OP_ADD2 add2 #f 0 ()
- OP_SETCDR set-cdr! 2 (λ (x y) (set-cdr! x y)) ()
- OP_LOADF loadf #f 0 ()
- OP_CONS cons 2 (λ (x y) (cons x y)) ()
- OP_EQ eq? 2 (λ (x y) (eq? x y)) ()
- OP_SYMBOLP symbol? 1 (λ (x) (symbol? x)) ()
- OP_NOT not 1 (λ (x) (not x)) ()
- OP_CADR cadr 1 (λ (x) (cadr x)) ()
- OP_NEG neg #f 0 ()
- OP_NULLP null? 1 (λ (x) (null? x)) ()
- OP_BOOLEANP boolean? 1 (λ (x) (boolean? x)) ()
- OP_NUMBERP number? 1 (λ (x) (number? x)) ()
- OP_FIXNUMP fixnum? 1 (λ (x) (fixnum? x)) ()
- OP_BOUNDP bound? 1 (λ (x) (bound? x)) ()
- OP_BUILTINP builtin? 1 (λ (x) (builtin? x)) ()
- OP_FUNCTIONP function? 1 (λ (x) (function? x)) ()
- OP_VECTORP vector? 1 (λ (x) (vector? x)) ()
- OP_SHIFT shift #f 0 ()
- OP_SETCAR set-car! 2 (λ (x y) (set-car! x y)) ()
- OP_JMPL jmp.l #f 0 ()
- OP_BRFL brf.l #f 0 ()
- OP_BRTL brt.l #f 0 ()
- OP_EQV eqv? 2 (λ (x y) (eqv? x y)) ()
- OP_EQUAL equal? 2 (λ (x y) (equal? x y)) ()
- OP_LIST list ANYARGS (λ rest rest) ()
- OP_APPLY apply -2 (λ rest (apply apply rest)) ()
- OP_ADD + ANYARGS (λ rest (apply + rest)) (
- ((number…) "Return sum of the numbers or 0 with no arguments."))
- OP_SUB - -1 (λ rest (apply - rest)) ()
- OP_MUL * ANYARGS (λ rest (apply * rest)) (
- ((number…) "Return product of the numbers or 1 with no arguments."))
- OP_DIV / -1 (λ rest (apply / rest)) ()
- OP_IDIV div0 2 (λ rest (apply div0 rest)) ()
- OP_NUMEQ = -1 (λ rest (apply = rest)) ()
- OP_COMPARE compare 2 (λ (x y) (compare x y)) ()
- OP_ARGC argc #f 0 ()
- OP_VECTOR vector ANYARGS (λ rest (apply vector rest)) ()
- OP_ASET aset! -3 (λ rest (apply aset! rest)) ()
- OP_LOADNIL loadnil #f 0 ()
- OP_LOADI8 loadi8 #f 0 ()
- OP_LOADVL loadv.l #f 0 ()
- OP_LOADGL loadg.l #f 0 ()
- OP_LOADAL loada.l #f 0 ()
- OP_LOADCL loadc.l #f 0 ()
- OP_SETG setg #f 0 ()
- OP_SETGL setg.l #f 0 ()
- OP_SETAL seta.l #f 0 ()
- OP_VARGC vargc #f 0 ()
- OP_TRYCATCH trycatch #f 0 ()
- OP_FOR for 3 (λ (a b f) (for a b (λ (x) (f x)))) ()
- OP_TAPPLY tapply #f 0 ()
- OP_SUB2 sub2 #f 0 ()
- OP_LARGC largc #f 0 ()
- OP_LVARGC lvargc #f 0 ()
- OP_CALLL call.l #f 0 ()
- OP_TCALLL tcall.l #f 0 ()
- OP_BRNEL brne.l #f 0 ()
- OP_BRNNL brnn.l #f 0 ()
- OP_BRN brn #f 0 ()
- OP_BRNL brn.l #f 0 ()
- OP_OPTARGS optargs #f 0 ()
- OP_BRBOUND brbound #f 0 ()
- OP_KEYARGS keyargs #f 0 ()
- OP_BOX box #f 0 ()
- OP_BOXL box.l #f 0 ()
- OP_AREF aref -2 (λ rest (apply aref rest)) ()
- OP_LOADVOID loadvoid #f 0 ()
- OP_NANP nan? 1 (λ (x) (nan? x)) ()
- OP_EOF_OBJECT dummy_eof #f 0 ()
-))
-
-(define (for-each-n f lst n)
- (when (and (> n 0) (cons? lst))
- (apply f (list-head lst n))
- (for-each-n f (list-tail lst n) n)))
-
-(let ((c-header (file "opcodes.h" :write :create :truncate))
- (c-code (file "opcodes.c" :write :create :truncate))
- (instructions (file "instructions.lsp" :write :create :truncate))
- (builtins (file "builtins.lsp" :write :create :truncate))
- (builtins-doc (file "docs_ops.lsp" :write :create :truncate))
- (e (table))
- (cl (table))
- (ac (table))
- (lms ())
- (i 0))
- (begin
- (io-write c-header "typedef enum {\n")- (for-each-n
- (λ (cop lop argc f docs)
- (begin
- (io-write c-header "\t")
- (write cop c-header)
- (io-write c-header ",\n")
- (for-each (λ (doc)
- (let ((docform (append `(,lop) (car doc))))
- (write (append `(doc-for ,docform)
- (list (cadr doc)))
- builtins-doc)
- (io-write builtins-doc "\n")))
- docs)
- (put! e lop i)
- (when argc
- (put! cl cop (list lop argc))
- (when (and (number? argc) (>= argc 0))
- (put! ac lop argc)))
- (set! lms (cons f lms))
- (set! i (1+ i))))
- opcodes 5)
- (io-close builtins-doc)
- (io-write c-header "\tN_OPCODES\n}opcode_t;\n\n")
- (io-write c-header "extern const Builtin builtins[N_OPCODES];\n")
- (io-close c-header)
- (io-write c-code "#include \"flisp.h\"\n\n")
- (io-write c-code "const Builtin builtins[N_OPCODES] = {\n")- (for-each
- (λ (c la) (begin (io-write c-code "\t[")
- (write c c-code)
- (io-write c-code "] = {\"")- (write (car la) c-code)
- (io-write c-code "\", ")
- (write (cadr la) c-code)
- (io-write c-code "},\n")))
- cl)
- (io-write c-code "};\n")
- (io-close c-code)
-
- (write `(define Instructions
- "VM instructions mapped to their encoded byte representation."
- ,e)
- instructions)
- (io-write instructions "\n\n")
- (write `(define arg-counts
- "VM instructions mapped to their expected arguments count."
- ,ac)
- instructions)
- (io-write instructions "\n")
- (io-close instructions)
- (set! lms (cons vector (reverse! lms)))
- (write `(define *builtins*
- "VM instructions as closures."
- ,lms)
- builtins)
- (io-write builtins "\n")
- (io-close builtins)))
--- a/hashing.c
+++ /dev/null
@@ -1,68 +1,0 @@
-#include "flisp.h"
-#include "hashing.h"
-#include "spooky.h"
-
-value_t
-nextipow2(value_t i)
-{- if(i == 0)
- return 1;
- i |= i >> 1;
- i |= i >> 2;
- i |= i >> 4;
- i |= i >> 8;
- i |= i >> 16;
-#if defined(BITS64)
- i |= i >> 32;
-#endif
- i++;
- return i ? i : TOP_BIT;
-}
-
-value_t
-inthash(value_t a)
-{-#if defined(BITS64)
- a = (~a) + (a << 21); // a = (a << 21) - a - 1;
- a = a ^ (a >> 24);
- a = (a + (a << 3)) + (a << 8); // a * 265
- a = a ^ (a >> 14);
- a = (a + (a << 2)) + (a << 4); // a * 21
- a = a ^ (a >> 28);
- a = a + (a << 31);
- return a;
-}
-#else
- a = (a+0x7ed55d16) + (a<<12);
- a = (a^0xc761c23c) ^ (a>>19);
- a = (a+0x165667b1) + (a<<5);
- a = (a+0xd3a2646c) ^ (a<<9);
- a = (a+0xfd7046c5) + (a<<3);
- a = (a^0xb55a4f09) ^ (a>>16);
- return a;
-}
-
-uint32_t
-int64to32hash(uint64_t key)
-{- key = (~key) + (key << 18); // key = (key << 18) - key - 1;
- key = key ^ (key >> 31);
- key = key * 21; // key = (key + (key << 2)) + (key << 4);
- key = key ^ (key >> 11);
- key = key + (key << 6);
- key = key ^ (key >> 22);
- return (uint32_t)key;
-}
-#endif
-
-uint64_t
-memhash(const char *buf, size_t n)
-{- return spooky_hash64(buf, n, 0xcafe8881);
-}
-
-uint32_t
-memhash32(const char *buf, size_t n)
-{- return spooky_hash32(buf, n, 0xcafe8881);
-}
--- a/hashing.h
+++ /dev/null
@@ -1,7 +1,0 @@
-#pragma once
-
-value_t nextipow2(value_t i) fl_constfn;
-value_t inthash(value_t a) fl_constfn;
-uint32_t int64to32hash(uint64_t key) fl_constfn;
-uint64_t memhash(const char* buf, size_t n);
-uint32_t memhash32(const char* buf, size_t n);
--- a/htable.c
+++ /dev/null
@@ -1,48 +1,0 @@
-/*
- functions common to all hash table instantiations
-*/
-
-#include "flisp.h"
-#include "htable.h"
-#include "hashing.h"
-
-htable_t *
-htable_new(htable_t *h, size_t size)
-{- if(size <= HT_N_INLINE/2){- size = HT_N_INLINE;
- h->table = &h->_space[0];
- }else{- size = nextipow2(size);
- size *= 2; // 2 pointers per key/value pair
- size *= 2; // aim for 50% occupancy
- if((h->table = MEM_ALLOC(size * sizeof(*h->table))) == nil)
- return nil;
- }
- h->size = size;
- h->i = 0;
- for(size_t i = 0; i < size; i++)
- h->table[i] = HT_NOTFOUND;
- return h;
-}
-
-void
-htable_free(htable_t *h)
-{- if(h->table != &h->_space[0])
- MEM_FREE(h->table);
-}
-
-// empty and reduce size
-void
-htable_reset(htable_t *h, size_t sz)
-{- sz = nextipow2(sz);
- if(h->size > sz*4 && h->table != &h->_space[0]){- MEM_FREE(h->table);
- htable_new(h, sz);
- }else{- for(size_t i = 0, hsz = h->size; i < hsz; i++)
- h->table[i] = HT_NOTFOUND;
- }
-}
--- a/htable.h
+++ /dev/null
@@ -1,22 +1,0 @@
-#pragma once
-
-#define HT_N_INLINE 32
-
-typedef struct {- void **table;
- uint32_t size;
- // this is to skip over non-items in for-each
- // FIXME(sigrid): in a multithreaded environment this isn't enough
- uint32_t i;
- void *_space[HT_N_INLINE];
-}fl_aligned(8) htable_t;
-
-// define this to be an invalid key/value
-#define HT_NOTFOUND ((void*)1)
-
-// initialize and free
-htable_t *htable_new(htable_t *h, size_t size);
-void htable_free(htable_t *h);
-
-// clear and (possibly) change size
-void htable_reset(htable_t *h, size_t sz);
--- a/htable.inc
+++ /dev/null
@@ -1,136 +1,0 @@
-//-*- mode:c -*-
-
-// define HTNAME, HFUNC and EQFUNC, then include this header
-
-#define hash_size(h) ((h)->size/2)
-
-// compute empirical max-probe for a given size
-#define max_probe(size) ((size) <= (HT_N_INLINE*2) ? (HT_N_INLINE/2) : (size)>>3)
-
-static void **
-HTNAME(_lookup_bp)(htable_t *h, void *key)
-{- value_t hv;
- size_t i, orig, index, iter;
- size_t newsz, sz = hash_size(h);
- size_t maxprobe = max_probe(sz);
- void **tab = h->table;
- void **ol;
-
- hv = HFUNC(key);
-retry_bp:
- iter = 0;
- index = (hv & (sz-1)) * 2;
- sz *= 2;
- orig = index;
-
- do{- if(tab[index+1] == HT_NOTFOUND){- tab[index] = key;
- return &tab[index+1];
- }
- if(EQFUNC(key, tab[index]))
- return &tab[index+1];
- index = (index+2) & (sz-1);
- iter++;
- if(iter > maxprobe)
- break;
- }while(index != orig);
-
- /* table full */
- /* quadruple size, rehash, retry the insert */
- /* it's important to grow the table really fast; otherwise we waste */
- /* lots of time rehashing all the keys over and over. */
- sz = h->size;
- ol = h->table;
- if(sz >= (1<<19) || (sz <= (1<<8)))
- newsz = sz<<1;
- else if(sz <= HT_N_INLINE)
- newsz = HT_N_INLINE;
- else
- newsz = sz<<2;
- tab = (void**)MEM_ALLOC(newsz*sizeof(void*));
- if(tab == nil)
- return nil;
- for(i = 0; i < newsz; i++)
- tab[i] = HT_NOTFOUND;
- h->table = tab;
- h->size = newsz;
- for(i = 0; i < sz; i += 2) {- if(ol[i+1] != HT_NOTFOUND)
- (*HTNAME(_lookup_bp)(h, ol[i])) = ol[i+1];
- }
- if(ol != &h->_space[0])
- MEM_FREE(ol);
- sz = hash_size(h);
- maxprobe = max_probe(sz);
- tab = h->table;
- goto retry_bp;
-}
-
-void
-HTNAME(_put)(htable_t *h, void *key, void *val)
-{- void **bp = HTNAME(_lookup_bp)(h, key);
- *bp = val;
-}
-
-void **
-HTNAME(_bp)(htable_t *h, void *key)
-{- return HTNAME(_lookup_bp)(h, key);
-}
-
-/* returns bp if key is in hash, otherwise nil */
-/* if return is non-nil and *bp == HT_NOTFOUND then key was deleted */
-static void **
-HTNAME(_peek_bp)(htable_t *h, void *key)
-{- size_t sz = hash_size(h);
- size_t maxprobe = max_probe(sz);
- void **tab = h->table;
- size_t index = (HFUNC(key) & (sz-1)) * 2;
- sz *= 2;
- size_t orig = index;
- size_t iter = 0;
-
- do {- if(tab[index] == HT_NOTFOUND)
- return nil;
- if(EQFUNC(key, tab[index]))
- return &tab[index+1];
-
- index = (index+2) & (sz-1);
- iter++;
- if(iter > maxprobe)
- break;
- }while(index != orig);
-
- return nil;
-}
-
-void *
-HTNAME(_get)(htable_t *h, void *key)
-{- void **bp = HTNAME(_peek_bp)(h, key);
- if(bp == nil)
- return HT_NOTFOUND;
- return *bp;
-}
-
-int
-HTNAME(_has)(htable_t *h, void *key)
-{- return HTNAME(_get)(h, key) != HT_NOTFOUND;
-}
-
-int
-HTNAME(_remove)(htable_t *h, void *key)
-{- void **bp = HTNAME(_peek_bp)(h, key);
- if(bp != nil){- *bp = HT_NOTFOUND;
- return 1;
- }
- return 0;
-}
--- a/htableh.inc
+++ /dev/null
@@ -1,29 +1,0 @@
-//-*- mode:c -*-
-
-#include "htable.h"
-
-#define HTPROT(HTNAME) \
-void *HTNAME##_get(htable_t *h, void *key) fl_purefn; \
-void HTNAME##_put(htable_t *h, void *key, void *val); \
-int HTNAME##_has(htable_t *h, void *key) fl_purefn; \
-int HTNAME##_remove(htable_t *h, void *key); \
-void **HTNAME##_bp(htable_t *h, void *key);
-
-// return value, or HT_NOTFOUND if key not found
-
-// add key/value binding
-
-// add binding iff key is unbound
-
-// does key exist?
-
-// logically remove key
-
-// get a pointer to the location of the value for the given key.
-// creates the location if it doesn't exist. only returns nil
-// if memory allocation fails.
-// this should be used for updates, for example:
-// void **bp = ptrhash_bp(h, key);
-// *bp = f(*bp);
-// do not reuse bp if there might be intervening calls to ptrhash_put,
-// ptrhash_bp, ptrhash_reset, or ptrhash_free.
--- a/ieee754.h
+++ /dev/null
@@ -1,21 +1,0 @@
-#pragma once
-
-union ieee754_double {- double d;
-
- struct {-#if BYTE_ORDER == BIG_ENDIAN
- unsigned int negative:1;
- unsigned int exponent:11;
- unsigned int mantissa0:20;
- unsigned int mantissa1:32;
-#else
- unsigned int mantissa1:32;
- unsigned int mantissa0:20;
- unsigned int exponent:11;
- unsigned int negative:1;
-#endif
- }ieee;
-};
-
-#define IEEE754_DOUBLE_BIAS 0x3ff
--- a/ios.c
+++ /dev/null
@@ -1,1002 +1,0 @@
-#include "flisp.h"
-#include "timefuncs.h"
-
-#define MOST_OF(x) ((x) - ((x)>>4))
-
-static char emptystr[] = "";
-
-ios_t *ios_stdin = nil;
-ios_t *ios_stdout = nil;
-ios_t *ios_stderr = nil;
-
-/* OS-level primitive wrappers */
-
-void *
-llt_memrchr(const void *s, int c, size_t n)
-{- const uint8_t *src = (const uint8_t*)s + n;
- uint8_t uc = c;
- while(--src >= (const uint8_t*)s)
- if(*src == uc)
- return (void *)src;
- return nil;
-}
-
-#if !defined(__plan9__) && !defined(__macos__) && !defined(__dos__)
-static int
-_enonfatal(int err)
-{- return err == 0 || err == EAGAIN || err == EINPROGRESS || err == EINTR || err == EWOULDBLOCK;
-}
-#define SLEEP_TIME 5//ms
-#endif
-
-// return error code, #bytes read in *nread
-// these wrappers retry operations until success or a fatal error
-static int
-_os_read(int fd, uint8_t *buf, size_t n, size_t *nread)
-{- ssize_t r;
-
- while(1){-#if !defined(__plan9__) && !defined(__macos__) && !defined(__dos__)
- errno = 0;
-#endif
- r = read(fd, buf, n);
- if(r > -1){- *nread = (size_t)r;
- break;
- }
-#if defined(__plan9__) || defined(__macos__) || defined(__dos__)
- return r;
-#else
- if(!_enonfatal(errno)){- *nread = 0;
- return errno;
- }
- sleep_ms(SLEEP_TIME);
-#endif
- }
- return 0;
-}
-
-static int
-_os_read_all(int fd, uint8_t *buf, size_t n, size_t *nread)
-{- size_t got;
-
- *nread = 0;
-
- while(n > 0){- int err = _os_read(fd, buf, n, &got);
- n -= got;
- *nread += got;
- buf += got;
- if(err || got == 0)
- return err;
- }
- return 0;
-}
-
-static int
-_os_write(int fd, const void *buf, size_t n, size_t *nwritten)
-{- ssize_t r;
-
- while(1){-#if !defined(__plan9__) && !defined(__macos__) && !defined(__dos__)
- errno = 0;
-#endif
- r = write(fd, buf, n);
- if(r > -1){- *nwritten = (size_t)r;
- break;
- }
-#if defined(__plan9__) || defined(__macos__) || defined(__dos__)
- return r;
-#else
- if(!_enonfatal(errno)){- *nwritten = 0;
- return errno;
- }
- sleep_ms(SLEEP_TIME);
-#endif
- }
- return 0;
-}
-
-static int
-_os_write_all(int fd, const uint8_t *buf, size_t n, size_t *nwritten)
-{- size_t wrote;
-
- *nwritten = 0;
- while(n > 0){- wrote = 0;
- int err = _os_write(fd, buf, n, &wrote);
- n -= wrote;
- *nwritten += wrote;
- buf += wrote;
- if(err)
- return err;
- }
- return 0;
-}
-
-
-/* internal utility functions */
-
-static uint8_t *
-_buf_realloc(ios_t *s, size_t sz)
-{- uint8_t *temp;
-
- if((s->buf == nil || s->buf == &s->local[0]) && sz <= IOS_INLSIZE){- /* TODO: if we want to allow shrinking, see if the buffer shrank
- down to this size, in which case we need to copy. */
- s->buf = &s->local[0];
- s->maxsize = IOS_INLSIZE;
- s->ownbuf = 1;
- return s->buf;
- }
-
- if(sz <= s->maxsize)
- return s->buf;
-
- if(s->ownbuf && s->buf != &s->local[0]){- // if we own the buffer we're free to resize it
- // always allocate 1 bigger in case user wants to add a NUL
- // terminator after taking over the buffer
- temp = MEM_REALLOC(s->buf, sz);
- if(temp == nil)
- return nil;
- }else{- temp = MEM_ALLOC(sz);
- if(temp == nil)
- return nil;
- s->ownbuf = 1;
- if(s->buf != nil)
- memcpy(temp, s->buf, s->size);
- }
-
- s->buf = temp;
- s->maxsize = sz;
- return s->buf;
-}
-
-// write a block of data into the buffer at the current position, resizing
-// if necessary. returns # written.
-static size_t
-_write_grow(ios_t *s, const void *data, size_t n)
-{- size_t amt;
- size_t newsize;
-
- if(n == 0)
- return 0;
-
- if(s->bpos + n > s->size){- if(s->bpos + n > s->maxsize){- /* TODO: here you might want to add a mechanism for limiting
- the growth of the stream. */
- newsize = s->maxsize ? s->maxsize * 2 : 8;
- while(s->bpos + n > newsize)
- newsize *= 2;
- if(_buf_realloc(s, newsize) == nil){- /* no more space; write as much as we can */
- amt = s->maxsize - s->bpos;
- if(amt > 0)
- memcpy(&s->buf[s->bpos], data, amt);
- s->bpos += amt;
- s->size = s->maxsize;
- return amt;
- }
- }
- s->size = s->bpos + n;
- }
- memcpy(s->buf + s->bpos, data, n);
- s->bpos += n;
-
- return n;
-}
-
-
-/* interface functions, low level */
-
-static size_t
-_ios_read(ios_t *s, uint8_t *dest, size_t n, int all)
-{- size_t tot = 0;
- size_t got, avail;
-
- if(s->state == bst_closed)
- return 0;
-
- while(n > 0){- avail = s->size - s->bpos;
-
- if(avail > 0){- size_t ncopy = avail >= n ? n : avail;
- memcpy(dest, s->buf + s->bpos, ncopy);
- s->bpos += ncopy;
- if(ncopy >= n){- s->state = bst_rd;
- return tot+ncopy;
- }
- }
- if(s->bm == bm_mem || s->fd == -1){- // can't get any more data
- s->state = bst_rd;
- if(avail == 0)
- s->_eof = 1;
- return avail;
- }
-
- dest += avail;
- n -= avail;
- tot += avail;
-
- ios_flush(s);
- s->bpos = s->size = 0;
- s->state = bst_rd;
-
- s->fpos = -1;
- got = 0;
- if(n > MOST_OF(s->maxsize)){- // doesn't fit comfortably in buffer; go direct
- if(all)
- _os_read_all(s->fd, dest, n, &got);
- else
- _os_read(s->fd, dest, n, &got);
- tot += got;
- if(got == 0)
- s->_eof = 1;
- return tot;
- }else{- // refill buffer
- if(_os_read(s->fd, s->buf, s->maxsize, &got)){- s->_eof = 1;
- return tot;
- }
- if(got == 0){- s->_eof = 1;
- return tot;
- }
- s->size = got;
- }
- }
-
- return tot;
-}
-
-size_t
-ios_read(ios_t *s, void *dest, size_t n)
-{- return _ios_read(s, dest, n, 0);
-}
-
-// ensure at least n bytes are buffered if possible. returns # available.
-static size_t
-ios_readprep(ios_t *s, size_t n)
-{- if(s->state == bst_wr && s->bm != bm_mem){- ios_flush(s);
- s->bpos = s->size = 0;
- }
- size_t space = s->size - s->bpos;
- s->state = bst_rd;
- if(space >= n || s->bm == bm_mem || s->fd == -1)
- return space;
- if(s->maxsize < s->bpos+n){- // it won't fit. grow buffer or move data back.
- if(n <= s->maxsize && space <= ((s->maxsize)>>2)){- if(space)
- memmove(s->buf, s->buf+s->bpos, space);
- s->size -= s->bpos;
- s->bpos = 0;
- }
- else {- if(_buf_realloc(s, s->bpos + n) == nil)
- return space;
- }
- }
- size_t got;
- int result = _os_read(s->fd, s->buf+s->size, s->maxsize - s->size, &got);
- if(result)
- return space;
- s->size += got;
- return s->size - s->bpos;
-}
-
-static void
-_write_update_pos(ios_t *s)
-{- if(s->bpos > s->ndirty)
- s->ndirty = s->bpos;
- if(s->bpos > s->size)
- s->size = s->bpos;
-}
-
-size_t
-ios_write(ios_t *s, const void *data, size_t n)
-{- if(s->readonly || s->state == bst_closed || n == 0)
- return 0;
- size_t space;
- size_t wrote = 0;
-
- if(s->state == bst_none)
- s->state = bst_wr;
- if(s->state == bst_rd){- if(!s->rereadable){- s->size = 0;
- s->bpos = 0;
- }
- space = s->size - s->bpos;
- }else{- space = s->maxsize - s->bpos;
- }
-
- if(s->bm == bm_mem){- wrote = _write_grow(s, data, n);
- }else if(s->bm == bm_none){- s->fpos = -1;
- _os_write_all(s->fd, data, n, &wrote);
- return wrote;
- }else if(n <= space){- if(s->bm == bm_line){- const char *nl;
- if((nl = llt_memrchr(data, '\n', n)) != nil){- size_t linesz = nl-(const char*)data+1;
- s->bm = bm_block;
- wrote += ios_write(s, data, linesz);
- ios_flush(s);
- s->bm = bm_line;
- n -= linesz;
- data = (const char*)data + linesz;
- }
- }
- memcpy(s->buf + s->bpos, data, n);
- s->bpos += n;
- wrote += n;
- }else{- s->state = bst_wr;
- ios_flush(s);
- if(n > MOST_OF(s->maxsize)){- _os_write_all(s->fd, data, n, &wrote);
- return wrote;
- }
- return ios_write(s, data, n);
- }
- _write_update_pos(s);
- return wrote;
-}
-
-off_t
-ios_seek(ios_t *s, off_t pos)
-{- if(s->state == bst_closed)
- return 0;
- s->_eof = 0;
- if(s->bm == bm_mem){- if((size_t)pos > s->size)
- return -1;
- s->bpos = pos;
- }else{- ios_flush(s);
- off_t fdpos = lseek(s->fd, pos, SEEK_SET);
- if(fdpos == (off_t)-1)
- return fdpos;
- s->bpos = s->size = 0;
- }
- return 0;
-}
-
-off_t
-ios_seek_end(ios_t *s)
-{- if(s->state == bst_closed)
- return 0;
- s->_eof = 1;
- if(s->bm == bm_mem){- s->bpos = s->size;
- }else{- ios_flush(s);
- off_t fdpos = lseek(s->fd, 0, SEEK_END);
- if(fdpos == (off_t)-1)
- return fdpos;
- s->bpos = s->size = 0;
- }
- return 0;
-}
-
-off_t
-ios_skip(ios_t *s, off_t offs)
-{- if(s->state == bst_closed)
- return 0;
- if(offs != 0){- if(offs > 0){- if(offs <= (off_t)(s->size-s->bpos)){- s->bpos += offs;
- return 0;
- }else if(s->bm == bm_mem){- // TODO: maybe grow buffer
- return -1;
- }
- }else if(offs < 0){- if(-offs <= (off_t)s->bpos){- s->bpos += offs;
- s->_eof = 0;
- return 0;
- }else if(s->bm == bm_mem){- return -1;
- }
- }
- ios_flush(s);
- if(s->state == bst_wr)
- offs += s->bpos;
- else if(s->state == bst_rd)
- offs -= s->size - s->bpos;
- off_t fdpos = lseek(s->fd, offs, SEEK_CUR);
- if(fdpos == (off_t)-1)
- return fdpos;
- s->bpos = s->size = 0;
- s->_eof = 0;
- }
- return 0;
-}
-
-off_t
-ios_pos(ios_t *s)
-{- if(s->state == bst_closed)
- return 0;
- if(s->bm == bm_mem)
- return (off_t)s->bpos;
-
- off_t fdpos = s->fpos;
- if(fdpos == (off_t)-1){- fdpos = lseek(s->fd, 0, SEEK_CUR);
- if(fdpos == (off_t)-1)
- return fdpos;
- s->fpos = fdpos;
- }
-
- if(s->state == bst_wr)
- fdpos += s->bpos;
- else if(s->state == bst_rd)
- fdpos -= s->size - s->bpos;
- return fdpos;
-}
-
-int
-ios_trunc(ios_t *s, off_t size)
-{- if(s->state == bst_closed || s->readonly || size < 0)
- return -1;
- if(s->bm == bm_mem){- if((size_t)size == s->size)
- return 0;
- if((size_t)size < s->size){- if(s->bpos > (size_t)size)
- s->bpos = size;
- }else if(_buf_realloc(s, size) == nil)
- return -1;
- s->size = size;
- return 0;
- }
- return ios_flush(s) == 0 ? ftruncate(s->fd, size) : -1;
-}
-
-bool
-ios_eof(ios_t *s)
-{- if(s->state == bst_closed)
- return true;
- if(s->bm == bm_mem)
- return s->_eof;
- return s->fd == -1 || s->_eof;
-}
-
-int
-ios_flush(ios_t *s)
-{- if(s->ndirty == 0 || s->bm == bm_mem || s->buf == nil)
- return 0;
- if(s->fd == -1)
- return -1;
-
- if(s->state == bst_rd){- if(lseek(s->fd, -(off_t)s->size, SEEK_CUR) == (off_t)-1){- // FIXME eh?
- }
- }
-
- size_t nw, ntowrite = s->ndirty;
- s->fpos = -1;
- int err = _os_write_all(s->fd, s->buf, ntowrite, &nw);
- // todo: try recovering from some kinds of errors (e.g. retry)
-
- if(s->state == bst_rd){- if(lseek(s->fd, s->size - nw, SEEK_CUR) == (off_t)-1){- // FIXME eh?
- }
- }else if(s->state == bst_wr){- if(s->bpos != nw && lseek(s->fd, (off_t)s->bpos - (off_t)nw, SEEK_CUR) == (off_t)-1){- // FIXME eh?
- }
- // now preserve the invariant that data to write
- // begins at the beginning of the buffer, and s->size refers
- // to how much valid file data is stored in the buffer.
- if(s->size > s->ndirty){- size_t delta = s->size - s->ndirty;
- memmove(s->buf, s->buf + s->ndirty, delta);
- }
- s->size -= s->ndirty;
- s->bpos = 0;
- }
-
- s->ndirty = 0;
-
- if(err)
- return err;
- if(nw < ntowrite)
- return -1;
- return 0;
-}
-
-void
-ios_close(ios_t *s)
-{- if(s->state == bst_closed)
- return;
- ios_flush(s);
- if(s->fd != -1 && s->ownfd)
- close(s->fd);
- s->fd = -1;
- if(s->buf != nil && s->ownbuf && s->buf != &s->local[0])
- MEM_FREE(s->buf);
- s->buf = nil;
- s->size = s->maxsize = s->bpos = 0;
- s->state = bst_closed;
-}
-
-void
-ios_free(ios_t *s)
-{- if(s->loc.filename != emptystr){- MEM_FREE(s->loc.filename);
- s->loc.filename = emptystr;
- }
-}
-
-static void
-_buf_init(ios_t *s, bufmode_t bm)
-{- s->bm = bm;
- if(s->bm == bm_mem || s->bm == bm_none){- s->buf = &s->local[0];
- s->maxsize = IOS_INLSIZE;
- }else{- s->buf = nil;
- _buf_realloc(s, IOS_BUFSIZE);
- }
- s->size = s->bpos = 0;
-}
-
-uint8_t *
-ios_takebuf(ios_t *s, size_t *psize)
-{- uint8_t *buf;
-
- ios_flush(s);
-
- if(s->buf == &s->local[0] || s->buf == nil || (!s->ownbuf && s->size == s->maxsize)){- buf = MEM_ALLOC(s->size+1);
- if(buf == nil)
- return nil;
- if(s->buf != nil)
- memcpy(buf, s->buf, s->size);
- }else if(s->size == s->maxsize){- buf = MEM_REALLOC(s->buf, s->size + 1);
- if(buf == nil)
- return nil;
- }else{- buf = s->buf;
- }
- buf[s->size] = '\0';
- *psize = s->size + 1;
-
- /* empty stream and reinitialize */
- _buf_init(s, s->bm);
-
- return buf;
-}
-
-int
-ios_setbuf(ios_t *s, uint8_t *buf, size_t size, int own)
-{- ios_flush(s);
- size_t nvalid;
-
- nvalid = size < s->size ? size : s->size;
- if(nvalid > 0)
- memcpy(buf, s->buf, nvalid);
- if(s->bpos > nvalid){- // truncated
- s->bpos = nvalid;
- }
- s->size = nvalid;
-
- if(s->buf != nil && s->ownbuf && s->buf != &s->local[0])
- MEM_FREE(s->buf);
- s->buf = buf;
- s->maxsize = size;
- s->ownbuf = own;
- return 0;
-}
-
-int
-ios_bufmode(ios_t *s, bufmode_t mode)
-{- // no fd; can only do mem-only buffering
- if(s->fd == -1 && mode != bm_mem)
- return -1;
- s->bm = mode;
- return 0;
-}
-
-void
-ios_set_readonly(ios_t *s)
-{- if(s->readonly)
- return;
- ios_flush(s);
- s->state = bst_none;
- s->readonly = 1;
-}
-
-static size_t
-ios_copy_(ios_t *to, ios_t *from, size_t nbytes, int all)
-{- size_t total = 0, avail;
- if(!ios_eof(from)){- do{- avail = ios_readprep(from, IOS_BUFSIZE/2);
- if(avail == 0){- from->_eof = 1;
- break;
- }
- size_t written, ntowrite;
- ntowrite = (avail <= nbytes || all) ? avail : nbytes;
- written = ios_write(to, from->buf+from->bpos, ntowrite);
- // TODO: should this be +=written instead?
- from->bpos += ntowrite;
- total += written;
- if(!all){- nbytes -= written;
- if(nbytes == 0)
- break;
- }
- if(written < ntowrite)
- break;
- }while(!ios_eof(from));
- }
- return total;
-}
-
-size_t
-ios_copy(ios_t *to, ios_t *from, size_t nbytes)
-{- return ios_copy_(to, from, nbytes, 0);
-}
-
-size_t
-ios_copyall(ios_t *to, ios_t *from)
-{- return ios_copy_(to, from, 0, 1);
-}
-
-#define LINE_CHUNK_SIZE 160
-
-size_t
-ios_copyuntil(ios_t *to, ios_t *from, uint8_t delim)
-{- size_t total = 0, avail = from->size - from->bpos;
- int first = 1;
- if(!ios_eof(from)){- do{- if(avail == 0){- first = 0;
- avail = ios_readprep(from, LINE_CHUNK_SIZE);
- }
- size_t written;
- uint8_t *pd = memchr(from->buf+from->bpos, delim, avail);
- if(pd == nil){- written = ios_write(to, from->buf+from->bpos, avail);
- from->bpos += avail;
- total += written;
- avail = 0;
- }else{- size_t ntowrite = pd - (from->buf+from->bpos) + 1;
- written = ios_write(to, from->buf+from->bpos, ntowrite);
- from->bpos += ntowrite;
- total += written;
- return total;
- }
- }while(!ios_eof(from) && (first || avail >= LINE_CHUNK_SIZE));
- }
- from->_eof = 1;
- return total;
-}
-
-static void
-_ios_init(ios_t *s)
-{- // put all fields in a sane initial state
- memset(s, 0, sizeof(*s));
- s->bm = bm_block;
- s->state = bst_none;
- s->fpos = -1;
- s->fd = -1;
- s->ownbuf = 1;
- s->loc.lineno = 1;
-}
-
-/* stream object initializers. we do no allocation. */
-
-ios_t *
-ios_file(ios_t *s, char *fname, int rd, int wr, int creat, int trunc)
-{- int fd;
- if(!(rd || wr)) // must specify read and/or write
- goto open_file_err;
- int flags = wr ? (rd ? O_RDWR : O_WRONLY) : O_RDONLY;
- if(trunc)
- flags |= O_TRUNC;
-#if defined(__plan9__)
- fd = creat ? create(fname, flags, 0644) : open(fname, flags);
-#else
- if(creat)
- flags |= O_CREAT;
- fd = open(fname, flags, 0644);
-#endif
- s = ios_fd(s, fd, 1, 1);
- if(fd < 0)
- goto open_file_err;
- if(!wr)
- s->readonly = 1;
- s->loc.filename = MEM_STRDUP(fname);
- return s;
-open_file_err:
- s->fd = -1;
- return nil;
-}
-
-ios_t *
-ios_mem(ios_t *s, size_t initsize)
-{- _ios_init(s);
- s->bm = bm_mem;
- s->loc.filename = emptystr;
- _buf_realloc(s, initsize);
- return s;
-}
-
-ios_t *
-ios_static_buffer(ios_t *s, const uint8_t *buf, size_t sz)
-{- ios_mem(s, 0);
- ios_setbuf(s, (uint8_t*)buf, sz, 0);
- s->size = sz;
- ios_set_readonly(s);
- return s;
-}
-
-ios_t *
-ios_fd(ios_t *s, int fd, int isfile, int own)
-{- _ios_init(s);
- s->fd = fd;
- if(isfile)
- s->rereadable = 1;
- _buf_init(s, bm_block);
- s->ownfd = own;
- if(fd == STDERR_FILENO)
- s->bm = bm_none;
- return s;
-}
-
-void
-ios_init_stdstreams(void)
-{- ios_stdin = MEM_ALLOC(sizeof(ios_t));
- ios_fd(ios_stdin, STDIN_FILENO, 0, 0);
- ios_stdin->loc.filename = MEM_STRDUP("*stdin*");-
- ios_stdout = MEM_ALLOC(sizeof(ios_t));
- ios_fd(ios_stdout, STDOUT_FILENO, 0, 0);
- ios_stdout->bm = bm_line;
- ios_stdout->loc.filename = MEM_STRDUP("*stdout*");-
- ios_stderr = MEM_ALLOC(sizeof(ios_t));
- ios_fd(ios_stderr, STDERR_FILENO, 0, 0);
- ios_stderr->bm = bm_none;
- ios_stderr->loc.filename = MEM_STRDUP("*stderr*");-}
-
-/* higher level interface */
-
-int
-ios_putc(ios_t *s, int c)
-{- char ch = c;
-
- if(s->state == bst_wr && s->bpos < s->maxsize && s->bm != bm_none){- s->buf[s->bpos++] = ch;
- _write_update_pos(s);
- if(s->bm == bm_line && ch == '\n')
- ios_flush(s);
- return 1;
- }
- return ios_write(s, &ch, 1);
-}
-
-static void
-ios_loc(ios_t *s, uint8_t ch)
-{- if(ch == '\n'){- s->loc.lineno++;
- s->loc.colno = 0;
- s->colnowait = 0;
- }else if(s->colnowait > 0){- s->colnowait--;
- }else{- s->loc.colno++;
- if(ch & 0x80){- if((ch & 0xe0) == 0xc0)
- s->colnowait = 1;
- else if((ch & 0xf0) == 0xe0)
- s->colnowait = 2;
- else
- s->colnowait = 3;
- }
- }
-}
-
-int
-ios_getc(ios_t *s)
-{- uint8_t ch;
- if(s->state == bst_rd && s->bpos < s->size)
- ch = s->buf[s->bpos++];
- else if(s->_eof || ios_read(s, &ch, 1) < 1)
- return IOS_EOF;
- ios_loc(s, ch);
- return ch;
-}
-
-int
-ios_peekc(ios_t *s)
-{- if(s->bpos < s->size)
- return (uint8_t)s->buf[s->bpos];
- if(s->_eof)
- return IOS_EOF;
- size_t n = ios_readprep(s, 1);
- if(n == 0)
- return IOS_EOF;
- return (uint8_t)s->buf[s->bpos];
-}
-
-int
-ios_wait(ios_t *s, double ws)
-{- if(s->bpos < s->size)
- return 1;
- if(s->_eof)
- return IOS_EOF;
-#if defined(__plan9__) || defined(__macos__)
- USED(ws);
- return 1; // FIXME(sigrid): wait for input, but not too much
-#else
- struct timeval t, *pt = nil;
- if(ws >= 0){- t.tv_sec = ws;
- t.tv_usec = (long)((ws - t.tv_sec) * 1000000.0) % 1000000;
- pt = &t;
- }
- fd_set f;
- FD_ZERO(&f);
- FD_SET(s->fd, &f);
- int r;
- while((r = select(s->fd+1, &f, nil, nil, pt)) == EINTR);
- return r && FD_ISSET(s->fd, &f);
-#endif
-}
-
-int
-ios_getutf8(ios_t *s, Rune *r)
-{- int c;
- size_t i;
- char buf[UTFmax];
-
- for(i = 0; i < sizeof(buf); i++){- if((c = ios_getc(s)) == IOS_EOF){- s->_eof = 1;
- return IOS_EOF;
- }
- buf[i] = c;
- if(fullrune(buf, i+1))
- break;
- }
- chartorune(r, buf);
- if(*r == Runeerror)
- return 0;
- if(*r == '\n')
- s->loc.colno = 0;
- else
- s->loc.colno++;
- return 1;
-}
-
-int
-ios_pututf8(ios_t *s, Rune r)
-{- char buf[UTFmax];
- return ios_write(s, buf, runetochar(buf, &r));
-}
-
-void
-ios_purge(ios_t *s)
-{- if(s->state == bst_rd){- for(; s->bpos < s->size; s->bpos++)
- ios_loc(s, s->buf[s->bpos]);
- }
-}
-
-int
-ios_vprintf(ios_t *s, const char *format, va_list args)
-{- char buf[256];
- char *str;
- int c;
-
- if(s->state == bst_closed)
- return -1;
- /* skip allocations if no buffering needed */
- if(s->bm == bm_none && (s->state == bst_none || s->state == bst_wr))
- return vdprintf(s->fd, format, args);
-
- if((c = vsnprintf(buf, sizeof(buf), format, args)) < nelem(buf))
- str = buf;
- else if(s->state == bst_none || s->state == bst_wr){- /* doesn't fit? prefer no allocations */
- ios_flush(s);
- return vdprintf(s->fd, format, args);
- }else{- str = MEM_ALLOC(c+1);
- c = vsnprintf(str, sizeof(c+1), format, args);
- }
- if(c > 0)
- c = ios_write(s, str, c);
- if(str != buf)
- MEM_FREE(str);
-
- return c;
-}
-
-int
-ios_printf(ios_t *s, const char *format, ...)
-{- va_list args;
- int c;
-
- va_start(args, format);
- c = ios_vprintf(s, format, args);
- va_end(args);
- return c;
-}
--- a/ios.h
+++ /dev/null
@@ -1,191 +1,0 @@
-// this flag controls when data actually moves out to the underlying I/O
-// channel. memory streams are a special case of this where the data
-// never moves out.
-typedef enum {- bm_none,
- bm_line,
- bm_block,
- bm_mem,
-}bufmode_t;
-
-typedef enum {- bst_none,
- bst_rd,
- bst_wr,
- bst_closed,
-}bufstate_t;
-
-#define IOS_INLSIZE 128
-#define IOS_BUFSIZE 32768
-
-typedef struct {- char *filename;
- uint32_t lineno;
- uint32_t colno;
-}ios_loc_t;
-
-typedef struct {- uint8_t *buf; // start of buffer
- size_t maxsize; // space allocated to buffer
- size_t size; // length of valid data in buf, >=ndirty
- size_t bpos; // current position in buffer
- size_t ndirty; // # bytes at &buf[0] that need to be written
- off_t fpos; // cached file pos
- ios_loc_t loc;
- bufmode_t bm;
- int colnowait;
-
- // the state only indicates where the underlying file position is relative
- // to the buffer. reading: at the end. writing: at the beginning.
- // in general, you can do any operation in any state.
- bufstate_t state;
-
- int fd;
-
- uint8_t readonly:1;
- uint8_t ownbuf:1;
- uint8_t ownfd:1;
- uint8_t _eof:1;
-
- // this means you can read, seek back, then read the same data
- // again any number of times. usually only true for files and strings.
- uint8_t rereadable:1;
-
- // this enables "stenciled writes". you can alternately write and
- // seek without flushing in between. this performs read-before-write
- // to populate the buffer, so "rereadable" capability is required.
- // this is off by default.
- //uint8_t stenciled:1;
-
- // request durable writes (fsync)
- // uint8_t durable:1;
-
- // todo: mutex
- uint8_t local[IOS_INLSIZE];
-}ios_t;
-
-void *llt_memrchr(const void *s, int c, size_t n) fl_purefn;
-
-/* low-level interface functions */
-size_t ios_read(ios_t *s, void *dest, size_t n);
-size_t ios_write(ios_t *s, const void *data, size_t n);
-off_t ios_seek(ios_t *s, off_t pos); // absolute seek
-off_t ios_seek_end(ios_t *s);
-off_t ios_skip(ios_t *s, off_t offs); // relative seek
-off_t ios_pos(ios_t *s); // get current position
-int ios_trunc(ios_t *s, off_t size);
-bool ios_eof(ios_t *s) fl_purefn;
-int ios_flush(ios_t *s);
-void ios_close(ios_t *s);
-void ios_free(ios_t *s);
-uint8_t *ios_takebuf(ios_t *s, size_t *psize); // null-terminate and release buffer to caller
-// set buffer space to use
-int ios_setbuf(ios_t *s, uint8_t *buf, size_t size, int own);
-int ios_bufmode(ios_t *s, bufmode_t mode);
-void ios_set_readonly(ios_t *s);
-size_t ios_copy(ios_t *to, ios_t *from, size_t nbytes);
-size_t ios_copyall(ios_t *to, ios_t *from);
-size_t ios_copyuntil(ios_t *to, ios_t *from, uint8_t delim);
-
-int ios_wait(ios_t *s, double ws);
-
-/* stream creation */
-ios_t *ios_file(ios_t *s, char *fname, int rd, int wr, int create, int trunc);
-ios_t *ios_mem(ios_t *s, size_t initsize);
-ios_t *ios_static_buffer(ios_t *s, const uint8_t *buf, size_t sz);
-ios_t *ios_fd(ios_t *s, int fd, int isfile, int own);
-// todo: ios_socket
-extern ios_t *ios_stdin;
-extern ios_t *ios_stdout;
-extern ios_t *ios_stderr;
-void ios_init_stdstreams(void);
-
-/* high-level functions - output */
-int ios_pututf8(ios_t *s, Rune r);
-int ios_printf(ios_t *s, const char *format, ...) fl_printfmt(2, 3);
-int ios_vprintf(ios_t *s, const char *format, va_list args) fl_printfmt(2, 0);
-
-void hexdump(ios_t *dest, const uint8_t *buffer, size_t len, size_t startoffs);
-
-/* high-level stream functions - input */
-int ios_getutf8(ios_t *s, Rune *r);
-
-// discard data buffered for reading
-void ios_purge(ios_t *s);
-
-/* stdio-style functions */
-#define IOS_EOF (-1)
-int ios_putc(ios_t *s, int c);
-int ios_getc(ios_t *s);
-int ios_peekc(ios_t *s);
-#define ios_puts(s, str) ios_write(s, str, strlen(str))
-
-/*
- With memory streams, mixed reads and writes are equivalent to performing
- sequences of *p++, as either an lvalue or rvalue. File streams behave
- similarly, but other streams might not support this. Using unbuffered
- mode makes this more predictable.
-
- Note on "unget" functions:
- There are two kinds of functions here: those that operate on sized
- blocks of bytes and those that operate on logical units like "character"
- or "integer". The "unget" functions only work on logical units. There
- is no "unget n bytes". You can only do an unget after a matching get.
- However, data pushed back by an unget is available to all read operations.
- The reason for this is that unget is defined in terms of its effect on
- the underlying buffer (namely, it rebuffers data as if it had been
- buffered but not read yet). IOS reserves the right to perform large block
- operations directly, bypassing the buffer. In such a case data was
- never buffered, so "rebuffering" has no meaning (i.e. there is no
- correspondence between the buffer and the physical stream).
-
- Single-bit I/O is able to write partial bytes ONLY IF the stream supports
- seeking. Also, line buffering is not well-defined in the context of
- single-bit I/O, so it might not do what you expect.
-
- implementation notes:
- in order to know where we are in a file, we must ensure the buffer
- is only populated from the underlying stream starting with p==buf.
-
- to switch from writing to reading: flush, set p=buf, cnt=0
- to switch from reading to writing: seek backwards cnt bytes, p=buf, cnt=0
-
- when writing: buf starts at curr. physical stream pos, p - buf is how
- many bytes we've written logically. cnt==0
-
- dirty == (bitpos>0 && state==iost_wr), EXCEPT right after switching from
- reading to writing, where we might be in the middle of a byte without
- having changed it.
-
- to write a bit: if !dirty, read up to maxsize-(p-buf) into buffer, then
- seek back by the same amount (undo it). write onto those bits. now set
- the dirty bit. in this state, we can bit-read up to the end of the byte,
- then formally switch to the read state using flush.
-
- design points:
- - data-source independence, including memory streams
- - expose buffer to user, allow user-owned buffers
- - allow direct I/O, don't always go through buffer
- - buffer-internal seeking. makes seeking back 1-2 bytes very fast,
- and makes it possible for sockets where it otherwise wouldn't be
- - tries to allow switching between reading and writing
- - support 64-bit and large files
- - efficient, low-latency buffering
- - special support for utf8
- - type-aware functions with byte-order swapping service
- - position counter for meaningful data offsets with sockets
-
- theory of operation:
-
- the buffer is a view of part of a file/stream. you can seek, read, and
- write around in it as much as you like, as if it were just a string.
-
- we keep track of the part of the buffer that's invalid (written to).
- we remember whether the position of the underlying stream is aligned
- with the end of the buffer (reading mode) or the beginning (writing mode).
-
- based on this info, we might have to seek back before doing a flush.
-
- as optimizations, we do no writing if the buffer isn't "dirty", and we
- do no reading if the data will only be overwritten.
-*/
--- a/iostream.c
+++ /dev/null
@@ -1,449 +1,0 @@
-#include "flisp.h"
-#include "cvalues.h"
-#include "types.h"
-#include "print.h"
-#include "read.h"
-#include "iostream.h"
-
-static void
-print_iostream(value_t v, ios_t *f)
-{- ios_t *s = value2c(ios_t*, v);
- fl_print_str(f, "#<io stream");
- if(*s->loc.filename){- fl_print_chr(f, ' ');
- fl_print_str(f, s->loc.filename);
- }
- fl_print_chr(f, '>');
-}
-
-static void
-free_iostream(value_t self)
-{- ios_t *s = value2c(ios_t*, self);
- ios_close(s);
- ios_free(s);
-}
-
-static void
-relocate_iostream(value_t oldv, value_t newv)
-{- ios_t *olds = value2c(ios_t*, oldv);
- ios_t *news = value2c(ios_t*, newv);
- if(news->buf == &olds->local[0])
- news->buf = &news->local[0];
-}
-
-static cvtable_t iostream_vtable = {- print_iostream,
- relocate_iostream,
- free_iostream,
- nil
-};
-
-static int
-isiostream(value_t v)
-{- return iscvalue(v) && cv_class(ptr(v)) == FL(iostreamtype);
-}
-
-fl_purefn
-BUILTIN("iostream?", iostreamp)-{- argcount(nargs, 1);
- return isiostream(args[0]) ? FL_t : FL_f;
-}
-
-fl_purefn
-BUILTIN("eof-object?", eof_objectp)-{- argcount(nargs, 1);
- return args[0] == FL_eof ? FL_t : FL_f;
-}
-
-fl_purefn
-ios_t *
-toiostream(value_t v)
-{- if(fl_unlikely(!isiostream(v)))
- type_error("iostream", v);- return value2c(ios_t*, v);
-}
-
-BUILTIN("file", file)-{- if(nargs < 1)
- argcount(nargs, 1);
- size_t i;
- int r = 0, w = 0, c = 0, t = 0, a = 0;
- for(i = 1; i < nargs; i++){- if(args[i] == FL_rdsym)
- r = 1;
- else if(args[i] == FL_wrsym)
- w = 1;
- else if(args[i] == FL_apsym)
- a = w = 1;
- else if(args[i] == FL_crsym)
- c = w = 1;
- else if(args[i] == FL_truncsym)
- t = w = 1;
- }
- if((r|w|c|t|a) == 0)
- r = 1; // default to reading
- value_t f = cvalue(FL(iostreamtype), sizeof(ios_t));
- char *fname = tostring(args[0]);
- ios_t *s = value2c(ios_t*, f);
- if(ios_file(s, fname, r, w, c, t) == nil)
- lerrorf(FL_IOError, "could not open \"%s\"", fname);
- if(a)
- ios_seek_end(s);
- return f;
-}
-
-BUILTIN("buffer", buffer)-{- argcount(nargs, 0);
- USED(args);
- value_t f = cvalue(FL(iostreamtype), sizeof(ios_t));
- ios_t *s = value2c(ios_t*, f);
- if(ios_mem(s, 0) == nil)
- lerrorf(FL_MemoryError, "could not allocate stream");
- return f;
-}
-
-BUILTIN("read", read)-{- if(nargs > 1)
- argcount(nargs, 1);
- value_t a = nargs == 0 ? symbol_value(FL_instrsym) : args[0];
- ios_t *s = toiostream(a);
- value_t v = fl_read_sexpr(a);
- return ios_eof(s) ? FL_eof : v;
-}
-
-BUILTIN("io-getc", io_getc)-{- argcount(nargs, 1);
- ios_t *s = toiostream(args[0]);
- Rune r;
- int res;
- if((res = ios_getutf8(s, &r)) == IOS_EOF)
- //lerrorf(FL_IOError, "end of file reached");
- return FL_eof;
- if(res == 0)
- lerrorf(FL_IOError, "invalid UTF-8 sequence");
- return mk_rune(r);
-}
-
-BUILTIN("io-wait", io_wait)-{- if(nargs > 2)
- argcount(nargs, 2);
- ios_t *s = toiostream(args[0]);
- int r = ios_wait(s, nargs > 1 ? todouble(args[1]) : -1);
- if(r >= 0)
- return r ? FL_t : FL_f;
- if(r == IOS_EOF)
- return FL_eof;
- lerrorf(FL_IOError, "i/o error");
-}
-
-BUILTIN("io-putc", io_putc)-{- argcount(nargs, 2);
- ios_t *s = toiostream(args[0]);
- if(!iscprim(args[1]) || ((cprim_t*)ptr(args[1]))->type != FL(runetype))
- type_error("rune", args[1]);- Rune r = *(Rune*)cp_data(ptr(args[1]));
- return fixnum(ios_pututf8(s, r));
-}
-
-BUILTIN("io-skip", io_skip)-{- argcount(nargs, 2);
- ios_t *s = toiostream(args[0]);
- off_t off = tooffset(args[1]);
- off_t res = ios_skip(s, off);
- if(res < 0)
- return FL_f;
- return sizeof(res) == sizeof(int64_t) ? mk_int64(res) : mk_int32(res);
-}
-
-BUILTIN("io-flush", io_flush)-{- argcount(nargs, 1);
- return ios_flush(toiostream(args[0])) == 0 ? FL_t : FL_f;
-}
-
-BUILTIN("io-close", io_close)-{- argcount(nargs, 1);
- ios_close(toiostream(args[0]));
- return FL_void;
-}
-
-BUILTIN("io-truncate", io_truncate)-{- argcount(nargs, 2);
- ios_t *s = toiostream(args[0]);
- if(ios_trunc(s, tooffset(args[1])) < 0)
- lerrorf(FL_IOError, "truncation failed");
- return FL_void;
-}
-
-BUILTIN("io-discardbuffer", io_discardbuffer)-{- argcount(nargs, 1);
- ios_purge(toiostream(args[0]));
- return FL_void;
-}
-
-fl_purefn
-BUILTIN("io-eof?", io_eofp)-{- argcount(nargs, 1);
- return ios_eof(toiostream(args[0])) ? FL_t : FL_f;
-}
-
-BUILTIN("io-seek", io_seek)-{- argcount(nargs, 2);
- ios_t *s = toiostream(args[0]);
- size_t pos = tosize(args[1]);
- off_t res = ios_seek(s, (off_t)pos);
- if(res < 0)
- return FL_f;
- return FL_t;
-}
-
-BUILTIN("io-pos", io_pos)-{- argcount(nargs, 1);
- ios_t *s = toiostream(args[0]);
- off_t res = ios_pos(s);
- if(res < 0)
- return FL_f;
- return size_wrap((size_t)res);
-}
-
-BUILTIN("write", write)-{- if(nargs < 1 || nargs > 2)
- argcount(nargs, 1);
- ios_t *s;
- s = nargs == 2 ? toiostream(args[1]) : toiostream(symbol_value(FL_outstrsym));
- fl_print(s, args[0]);
- return args[0];
-}
-
-BUILTIN("io-read", io_read)-{- if(nargs != 3)
- argcount(nargs, 2);
- ios_t *s = toiostream(args[0]);
- size_t n;
- fltype_t *ft;
- if(nargs == 3){- // form (io.read s type count)
- ft = get_array_type(args[1]);
- n = tosize(args[2]) * ft->elsz;
- }else{- ft = get_type(args[1]);
- if(ft->eltype != nil && !iscons(cdr_(cdr_(args[1]))))
- lerrorf(FL_ArgError, "incomplete type");
- n = ft->size;
- }
- value_t cv = cvalue(ft, n);
- uint8_t *data = cptr(cv);
- size_t got = ios_read(s, data, n);
- if(got < n)
- //lerrorf(FL_IOError, "end of input reached");
- return FL_eof;
- return cv;
-}
-
-// args must contain data[, offset[, count]]
-static void
-get_start_count_args(value_t *args, uint32_t nargs, size_t sz, size_t *offs, size_t *nb)
-{- if(nargs > 1){- *offs = tosize(args[1]);
- *nb = nargs > 2 ? tosize(args[2]) : sz - *offs;
- if(*offs >= sz || *offs + *nb > sz)
- bounds_error(args[0], args[1]);
- }
-}
-
-BUILTIN("io-write", io_write)-{- if(nargs < 2 || nargs > 4)
- argcount(nargs, 2);
- ios_t *s = toiostream(args[0]);
- if(iscprim(args[1]) && ((cprim_t*)ptr(args[1]))->type == FL(runetype)){- if(nargs > 2)
- lerrorf(FL_ArgError, "offset argument not supported for characters");
- Rune r = *(Rune*)cp_data(ptr(args[1]));
- return fixnum(ios_pututf8(s, r));
- }
- uint8_t *data;
- size_t sz, offs = 0;
- to_sized_ptr(args[1], &data, &sz);
- size_t nb = sz;
- if(nargs > 2){- get_start_count_args(&args[1], nargs-1, sz, &offs, &nb);
- data += offs;
- }
- return size_wrap(ios_write(s, data, nb));
-}
-
-static uint8_t
-get_delim_arg(value_t arg)
-{- size_t uldelim = tosize(arg);
- if(uldelim > 0x7f){- // runes > 0x7f, or anything else > 0xff, are out of range
- if((iscprim(arg) && cp_class(ptr(arg)) == FL(runetype)) || uldelim > 0xff)
- lerrorf(FL_ArgError, "delimiter out of range");
- }
- return (uint8_t)uldelim;
-}
-
-BUILTIN("io-readuntil", io_readuntil)-{- argcount(nargs, 2);
- value_t str = cvalue_string(80);
- cvalue_t *cv = ptr(str);
- uint8_t *data = cv_data(cv);
- ios_t dest;
- ios_mem(&dest, 0);
- ios_setbuf(&dest, data, 80, 0);
- uint8_t delim = get_delim_arg(args[1]);
- ios_t *src = toiostream(args[0]);
- size_t n = ios_copyuntil(&dest, src, delim);
- cv->len = n;
- if(dest.buf != data){- // outgrew initial space
- size_t sz;
- cv->data = ios_takebuf(&dest, &sz);
- cv_autorelease(cv);
- }else{- ((uint8_t*)cv->data)[n] = 0;
- }
- if(n == 0 && ios_eof(src))
- return FL_eof;
- return str;
-}
-
-BUILTIN("io-copyuntil", io_copyuntil)-{- argcount(nargs, 3);
- ios_t *dest = toiostream(args[0]);
- ios_t *src = toiostream(args[1]);
- uint8_t delim = get_delim_arg(args[2]);
- return size_wrap(ios_copyuntil(dest, src, delim));
-}
-
-BUILTIN("io-copy", io_copy)-{- if(nargs < 2 || nargs > 3)
- argcount(nargs, 2);
- ios_t *dest = toiostream(args[0]);
- ios_t *src = toiostream(args[1]);
- if(nargs == 3)
- return size_wrap(ios_copy(dest, src, tosize(args[2])));
- return size_wrap(ios_copyall(dest, src));
-}
-
-BUILTIN("io-filename", io_filename)-{- argcount(nargs, 1);
- return string_from_cstr(toiostream(args[0])->loc.filename);
-}
-
-BUILTIN("io-set-filename!", io_set_filename)-{- argcount(nargs, 2);
- ios_t *s = toiostream(args[0]);
- char *f = tostring(args[1]);
- MEM_FREE(s->loc.filename);
- s->loc.filename = MEM_STRDUP(f);
- return args[1];
-}
-
-BUILTIN("io-line", io_line)-{- argcount(nargs, 1);
- return size_wrap(toiostream(args[0])->loc.lineno);
-}
-
-BUILTIN("io-set-line!", io_set_line)-{- argcount(nargs, 2);
- toiostream(args[0])->loc.lineno = tosize(args[1]);
- return args[1];
-}
-
-BUILTIN("io-column", io_column)-{- argcount(nargs, 1);
- return size_wrap(toiostream(args[0])->loc.colno);
-}
-
-BUILTIN("io-set-column!", io_set_column)-{- argcount(nargs, 2);
- toiostream(args[0])->loc.colno = tosize(args[1]);
- return args[1];
-}
-
-value_t
-stream_to_string(value_t *ps)
-{- value_t str;
- size_t n;
- ios_t *st = value2c(ios_t*, *ps);
- if(st->buf == &st->local[0]){- n = st->size;
- str = cvalue_string(n);
- memcpy(cvalue_data(str), st->buf, n);
- ios_trunc(st, 0);
- }else{- uint8_t *b = ios_takebuf(st, &n); n--;
- if(n == 0)
- return FL(the_empty_string);
- b[n] = '\0';
- str = cvalue_from_ref(FL(stringtype), b, n, FL_nil);
- cv_autorelease(ptr(str));
- }
- return str;
-}
-
-BUILTIN("iostream->string", io_tostring)-{- argcount(nargs, 1);
- ios_t *src = toiostream(args[0]);
- if(src->bm != bm_mem)
- lerrorf(FL_ArgError, "requires memory stream");
- bool eof = ios_eof(src);
- value_t v = stream_to_string(&args[0]);
- if(eof && v == FL(the_empty_string))
- v = FL_eof;
- return v;
-}
-
-void
-iostream_init(void)
-{- FL_iostreamsym = symbol("iostream", false);- FL_rdsym = symbol(":read", false);- FL_wrsym = symbol(":write", false);- FL_apsym = symbol(":append", false);- FL_crsym = symbol(":create", false);- FL_truncsym = symbol(":truncate", false);- FL_instrsym = symbol("*input-stream*", false);- FL_outstrsym = symbol("*output-stream*", false);- FL(iostreamtype) = define_opaque_type(FL_iostreamsym, sizeof(ios_t), &iostream_vtable, nil);
- set(symbol("*stdout*", false), cvalue_from_ref(FL(iostreamtype), ios_stdout, sizeof(ios_t), FL_nil));- set(symbol("*stderr*", false), cvalue_from_ref(FL(iostreamtype), ios_stderr, sizeof(ios_t), FL_nil));- set(symbol("*stdin*", false), cvalue_from_ref(FL(iostreamtype), ios_stdin, sizeof(ios_t), FL_nil));-}
--- a/iostream.h
+++ /dev/null
@@ -1,3 +1,0 @@
-ios_t *toiostream(value_t v);
-value_t stream_to_string(value_t *ps);
-void iostream_init(void);
--- a/macos/femtolispm68k.r
+++ /dev/null
@@ -1,22 +1,0 @@
-#include "Retro68APPL.r"
-
-resource 'SIZE' (-1) {- reserved,
- ignoreSuspendResumeEvents,
- reserved,
- cannotBackground,
- needsActivateOnFGSwitch,
- backgroundAndForeground,
- dontGetFrontClicks,
- ignoreChildDiedEvents,
- is32BitCompatible,
- notHighLevelEventAware,
- onlyLocalHLEvents,
- notStationeryAware,
- dontUseTextEditServices,
- reserved,
- reserved,
- reserved,
- 4 * 1024 * 1024,
- 1 * 1024 * 1024
-};
--- a/macos/femtolispppc.r
+++ /dev/null
@@ -1,22 +1,0 @@
-#include "RetroPPCAPPL.r"
-
-resource 'SIZE' (-1) {- reserved,
- ignoreSuspendResumeEvents,
- reserved,
- cannotBackground,
- needsActivateOnFGSwitch,
- backgroundAndForeground,
- dontGetFrontClicks,
- ignoreChildDiedEvents,
- is32BitCompatible,
- notHighLevelEventAware,
- onlyLocalHLEvents,
- notStationeryAware,
- dontUseTextEditServices,
- reserved,
- reserved,
- reserved,
- 16 * 1024 * 1024,
- 8 * 1024 * 1024
-};
--- a/macos/platform.h
+++ /dev/null
@@ -1,57 +1,0 @@
-#pragma once
-
-#define _XOPEN_SOURCE 700
-#include <assert.h>
-#include <ctype.h>
-#include <errno.h>
-#include <fcntl.h>
-#include <float.h>
-#include <inttypes.h>
-#include <limits.h>
-#include <locale.h>
-#include <math.h>
-#include <setjmp.h>
-#include <stdbool.h>
-#include <stdarg.h>
-#include <stdio.h>
-#include <stddef.h>
-#include <stdint.h>
-#include <stdlib.h>
-#include <string.h>
-#include <strings.h>
-#include <sys/stat.h>
-#include <sys/time.h>
-#include <time.h>
-#include <unistd.h>
-#include <wctype.h>
-#include <wchar.h>
-
-#define __os_name__ "macos"
-extern char os_version[];
-#define __os_version__ os_version
-
-#define nil NULL
-#define USED(x) ((void)(x))
-#define nelem(x) (int)(sizeof(x)/sizeof((x)[0]))
-
-#define PATHSEP '/'
-#define PATHSEPSTRING "/"
-#define PATHLISTSEP ':'
-#define PATHLISTSEPSTRING ":"
-#define ISPATHSEP(c) ((c) == '/')
-
-#ifndef BYTE_ORDER
-#error unknown byte order
-#endif
-
-#if !defined(INITIAL_HEAP_SIZE)
-#define INITIAL_HEAP_SIZE 128*1024
-#endif
-#if !defined(ALLOC_LIMIT_TRIGGER)
-#define ALLOC_LIMIT_TRIGGER INITIAL_HEAP_SIZE
-#endif
-
-#include "cc.h"
-#include "mem.h"
-#include "mp.h"
-#include "utf.h"
--- a/maxstack.inc
+++ /dev/null
@@ -1,166 +1,0 @@
-fl_purefn
-static int
-compute_maxstack(uint8_t *code, size_t len)
-{- uint8_t *ip = code+4, *end = code+len;
- int i, n, sp = 0, maxsp = 0;
-
- while(ip < end){- opcode_t op = *ip++;
- if(op >= N_OPCODES)
- return -1;
- switch(op){- case OP_LOADA: case OP_LOADI8: case OP_LOADV: case OP_LOADG:
- ip++; // fallthrough
- case OP_LOADA0: case OP_LOADA1:
- case OP_DUP: case OP_LOADT: case OP_LOADF: case OP_LOADNIL: case OP_LOADVOID:
- case OP_LOAD0:
- case OP_LOAD1: case OP_LOADC0:
- case OP_LOADC1:
- sp++;
- break;
-
- case OP_BRF: case OP_BRT:
- SWAP_INT16(ip);
- ip += 2;
- sp--;
- break;
-
- case OP_POP: case OP_RET:
- case OP_CONS: case OP_SETCAR: case OP_SETCDR:
- case OP_EQ: case OP_EQV: case OP_EQUAL: case OP_ADD2: case OP_SUB2:
- case OP_IDIV: case OP_COMPARE:
- case OP_AREF2: case OP_TRYCATCH:
- sp--;
- break;
-
- case OP_AREF:
- n = 2 + *ip++;
- sp -= n;
- break;
-
- case OP_ARGC: case OP_SETG: case OP_SETA: case OP_BOX:
- ip++;
- continue;
-
- case OP_TCALL: case OP_CALL: case OP_CLOSURE: case OP_SHIFT:
- n = *ip++; // nargs
- sp -= n;
- break;
-
- case OP_LOADVL: case OP_LOADGL: case OP_LOADAL:
- sp++; // fallthrough
- case OP_SETGL: case OP_SETAL: case OP_LARGC: case OP_BOXL:
- SWAP_INT32(ip);
- ip += 4;
- break;
-
- case OP_LOADC:
- sp++;
- ip++;
- break;
-
- case OP_VARGC:
- n = *ip++;
- sp += n+2;
- break;
- case OP_LVARGC:
- SWAP_INT32(ip);
- n = GET_INT32(ip); ip += 4;
- sp += n+2;
- break;
- case OP_OPTARGS:
- SWAP_INT32(ip);
- i = GET_INT32(ip); ip += 4;
- SWAP_INT32(ip);
- n = abs(GET_INT32(ip)); ip += 4;
- sp += n-i;
- break;
- case OP_KEYARGS:
- SWAP_INT32(ip);
- i = GET_INT32(ip); ip += 4;
- SWAP_INT32(ip);
- ip += 4;
- SWAP_INT32(ip);
- n = abs(GET_INT32(ip)); ip += 4;
- sp += n-i;
- break;
- case OP_BRBOUND:
- SWAP_INT32(ip);
- ip += 4;
- sp++;
- break;
- case OP_TCALLL: case OP_CALLL:
- SWAP_INT32(ip);
- n = GET_INT32(ip); ip+=4;
- sp -= n;
- break;
- case OP_JMP:
- SWAP_INT16(ip);
- ip += 2;
- continue;
- case OP_JMPL:
- SWAP_INT32(ip);
- ip += 4;
- continue;
- case OP_BRFL: case OP_BRTL:
- SWAP_INT32(ip);
- ip += 4;
- sp--;
- break;
- case OP_BRNE:
- SWAP_INT16(ip);
- ip += 2;
- sp -= 2;
- break;
- case OP_BRNEL:
- SWAP_INT32(ip);
- ip += 4;
- sp -= 2;
- break;
- case OP_BRNN: case OP_BRN:
- SWAP_INT16(ip);
- ip += 2;
- sp--;
- break;
- case OP_BRNNL: case OP_BRNL:
- SWAP_INT32(ip);
- ip += 4; // fallthrough
- case OP_TAPPLY: case OP_APPLY:
- case OP_LIST: case OP_ADD: case OP_SUB: case OP_MUL: case OP_DIV:
- case OP_VECTOR: case OP_LT: case OP_NUMEQ:
- n = *ip++;
- sp -= n-1;
- break;
-
- case OP_FOR:
- if(maxsp < sp+2)
- maxsp = sp+2; // fallthrough
- case OP_ASET:
- sp -= 2;
- break;
-
- case OP_LOADCL:
- sp++; // fallthrough
- SWAP_INT32(ip);
- ip += 4;
- break;
-
- case OP_CAR: case OP_CDR: case OP_CADR:
- case OP_NOT: case OP_NEG:
- case OP_CONSP: case OP_ATOMP: case OP_SYMBOLP:
- case OP_NULLP: case OP_BOOLEANP: case OP_NUMBERP:
- case OP_FIXNUMP: case OP_BOUNDP: case OP_BUILTINP:
- case OP_FUNCTIONP: case OP_VECTORP: case OP_NANP:
- continue;
-
- case OP_EOF_OBJECT: case N_OPCODES:
- return -1;
- }
- if((int32_t)sp > (int32_t)maxsp)
- maxsp = sp;
- }
- assert(ip == end);
- assert(maxsp >= 0);
- return maxsp+4;
-}
--- a/mem.c
+++ /dev/null
@@ -1,81 +1,0 @@
-#if defined(__macos__)
-#include <MacMemory.h>
-#endif
-#include "platform.h"
-
-#define HAVE_MORECORE 1
-#define MORECORE fl_sbrk
-static void *fl_sbrk(intptr_t increment);
-#define MORECORE_CONTIGUOUS 0
-#define MORECORE_CANNOT_TRIM 1
-#define NO_SEGMENT_TRAVERSAL 1
-#define USE_BUILTIN_FFS 1
-#define MALLOC_ALIGNMENT 8
-#define USE_LOCKS 0
-#define USE_DL_PREFIX 1
-#define LACKS_SYS_PARAM_H
-#define LACKS_FCNTL_H
-#define LACKS_TIME_H
-#define LACKS_SYS_TYPES_H
-#define HAVE_MMAP 0
-#define HAVE_MREMAP 0
-#define NO_MALLINFO 1
-#define NO_MALLOC_STATS 1
-#define DEFAULT_GRANULARITY 64
-#define malloc_getpagesize 4096
-#include "dlmalloc.inc"
-
-void *
-fl_malloc(size_t size)
-{- return dlmalloc(size);
-}
-
-void
-fl_free(void *p)
-{- dlfree(p);
-}
-
-void *
-fl_calloc(size_t n, size_t size)
-{- return dlcalloc(n, size);
-}
-
-void *
-fl_realloc(void *p, size_t size)
-{- return dlrealloc(p, size);
-}
-
-char *
-fl_strdup(const char *s)
-{- size_t sz = strlen(s)+1;
- char *p = dlmalloc(sz);
- memcpy(p, s, sz);
- return p;
-}
-
-#if defined(__macos__)
-static void *
-fl_sbrk(intptr_t increment)
-{- static char *e = nil;
- if(increment == 0)
- return e;
- if(increment < 0)
- return MFAIL;
- increment = (increment + malloc_getpagesize-1) & ~(malloc_getpagesize-1);
- char *p = NewPtr(increment);
- e = p + increment;
- return p;
-}
-#else
-static void *
-fl_sbrk(intptr_t increment)
-{- return sbrk(increment);
-}
-#endif
--- a/mem.h
+++ /dev/null
@@ -1,18 +1,0 @@
-#if defined(USE_DLMALLOC)
-void *fl_malloc(size_t);
-void fl_free(void *);
-void *fl_calloc(size_t, size_t);
-void *fl_realloc(void *, size_t);
-char *fl_strdup(const char *s);
-#define MEM_CALLOC(n, sz) fl_calloc((size_t)(n), (size_t)(sz))
-#define MEM_ALLOC(n) fl_malloc((size_t)(n))
-#define MEM_REALLOC(p, n) fl_realloc((p), (size_t)(n))
-#define MEM_FREE(x) fl_free(x)
-#define MEM_STRDUP(s) fl_strdup(s)
-#else
-#define MEM_CALLOC(n, sz) calloc((size_t)(n), (size_t)(sz))
-#define MEM_ALLOC(n) malloc((size_t)(n))
-#define MEM_REALLOC(p, n) realloc((p), (size_t)(n))
-#define MEM_FREE(x) free(x)
-#define MEM_STRDUP(s) strdup(s)
-#endif
--- a/meson.build
+++ b/meson.build
@@ -7,7 +7,6 @@
'warning_level=3',
'buildtype=debugoptimized',
'b_ndebug=if-release'
- #'b_coverage=true',
],
)
@@ -44,28 +43,28 @@
'3rd/mt19937-64.c',
'3rd/spooky.c',
'3rd/tbl.c',
- 'bitvector.c',
- 'builtins.c',
- 'compress.c',
- 'cvalues.c',
- 'equal.c',
- 'equalhash.c',
- 'flisp.c',
- 'flmain.c',
- 'hashing.c',
- 'htable.c',
- 'ios.c',
- 'iostream.c',
- 'opcodes.c',
- 'operators.c',
- 'print.c',
- 'ptrhash.c',
- 'random.c',
- 'read.c',
- 'string.c',
- 'table.c',
- 'types.c',
- 'utf8.c',
+ 'src/bitvector.c',
+ 'src/builtins.c',
+ 'src/compress.c',
+ 'src/cvalues.c',
+ 'src/equal.c',
+ 'src/equalhash.c',
+ 'src/flisp.c',
+ 'src/flmain.c',
+ 'src/hashing.c',
+ 'src/htable.c',
+ 'src/ios.c',
+ 'src/iostream.c',
+ 'src/opcodes.c',
+ 'src/operators.c',
+ 'src/print.c',
+ 'src/ptrhash.c',
+ 'src/random.c',
+ 'src/read.c',
+ 'src/string.c',
+ 'src/table.c',
+ 'src/types.c',
+ 'src/utf8.c',
]
cc = meson.get_compiler('c')@@ -90,13 +89,14 @@
endif
src_common = [
- 'nan_posix.c',
+ 'src/nan.c',
]
-inc = [include_directories('3rd', '3rd/mp', '3rd/utf', '3rd/brieflz')]+inc = [include_directories('src', '3rd', '3rd/mp', '3rd/utf', '3rd/brieflz')]extras = []
sys = host_machine.system()
+cpu = host_machine.cpu()
if sys == 'macos'
platform = sys
@@ -107,7 +107,7 @@
required: true,
)
cpp = meson.get_compiler('cpp')- if host_machine.cpu() == 'm68k'
+ if cpu == 'm68k'
add_project_arguments(
# don't expect NewPtr-returned pointers to be aligned by 8 bytes
# hence just use dlmalloc, which is also a much faster way to go about it
@@ -115,10 +115,9 @@
language: 'c',
)
src_common += [
- 'mem.c',
+ 'src/mem.c',
]
endif
- inc += [include_directories('macos')]extras += [
cpp.find_library('RetroConsole', required: true), cpp.find_library('retrocrt', required: true),@@ -126,16 +125,14 @@
elif sys == 'dos'
platform = sys
flisp_exe_name = 'flisp.exe'
- inc += [include_directories('dos')]src_flisp += ['3rd/wcwidth.c']
else
platform = 'posix'
flisp_exe_name = 'flisp'
- inc += [include_directories('posix')]endif
-inc += [include_directories(platform)]
-src_flisp += ['sys_' + platform + '.c']
+inc += [include_directories('src'/platform)]+src_flisp += ['src'/platform/'sys.c']
common = static_library(
'common',
@@ -151,13 +148,13 @@
'boot',
capture: true,
input: [
- 'flisp.boot.builtin',
+ 'boot/flisp.boot.builtin',
],
output: [
'flisp.boot.h',
],
command: [
- 'boot2h.sh', '@INPUT@',
+ 'tools/boot2h.sh', '@INPUT@',
],
)
@@ -171,7 +168,7 @@
'builtin_fns.h',
],
command: [
- 'builtins2h.sh', '@INPUT@',
+ 'tools/builtins2h.sh', '@INPUT@',
],
)
@@ -179,13 +176,13 @@
'ops',
capture: true,
input: [
- 'vm.inc',
+ 'src/vm.inc',
],
output: [
'vm_goto.inc',
],
command: [
- 'ops2h.sh', '@INPUT@',
+ 'tools/ops2h.sh', '@INPUT@',
],
)
@@ -275,15 +272,29 @@
)
if platform == 'macos'
- if host_machine.cpu() == 'm68k'
+ fs = import('fs')+ makepef = find_program(
+ 'MakePEF',
+ native: false,
+ required: true,
+ )
+ rez = find_program(
+ 'Rez',
+ native: false,
+ required: true,
+ )
+ rincludes = fs.parent(fs.parent(rez.full_path()))/'RIncludes'
+
+ if cpu == 'm68k'
template = 'femtolispm68k.r'
rez_data = '--copy'
rezflags = []
flisp_code = flisp
else
+ assert(cpu == 'ppc', 'unexpected cpu setting')
template = 'femtolispppc.r'
rez_data = '--data'
- rezflags = ['-DTARGET_API_MAC_CARBON=1']
+ rezflags = ['-DTARGET_API_MAC_CARBON=0']
flisp_code = custom_target(
'flisp.pef',
input: [
@@ -293,14 +304,13 @@
'flisp.pef',
],
command: [
- meson.get_external_property('makepef'),+ makepef,
'@INPUT@',
'-o', '@OUTPUT@',
],
)
endif
- rincludes = meson.get_external_property('rincludes')- template = join_paths(meson.global_source_root(), 'macos', template)
+ template = meson.global_source_root()/'src/macos'/template
flisp_bin = custom_target(
'flisp.bin',
@@ -313,7 +323,7 @@
'flisp.dsk',
],
command: [
- meson.get_external_property('rez'),+ rez,
'-I' + rincludes,
] + rezflags + [
template,
@@ -321,7 +331,7 @@
'-o', 'flisp.bin',
'-t', 'APPL',
'-c', '????',
- rez_data, '@INPUT@',
+ rez_data, flisp_code,
'--cc', 'flisp.dsk',
],
build_by_default: true,
--- a/mkboot0.lsp
+++ /dev/null
@@ -1,30 +1,0 @@
-; -*- scheme -*-
-
-(define update-compiler
- (let ((C ()))
- (with-bindings
- ((eval (λ (x) (set! C (cons (compile-thunk (expand x)) C)))))
- (begin
- (load "instructions.lsp")
- (load "compiler.lsp")))
- (λ () (begin
- (for-each (λ (x) (x)) (reverse! C))
- (set! update-compiler (λ () ()))))))
-
-(define (compile-file inf)
- (let ((in (file inf :read)))
- (let next ((E (read in)))
- (if (not (io-eof? in))
- (begin
- (print (compile-thunk (expand E)))
- (newline)
- (next (read in)))))
- (io-close in)))
-
-(define (do-boot0)
- (for-each (λ (file)
- (compile-file file))
- (cdr *argv*)))
-
-(update-compiler)
-(do-boot0)
--- a/mkboot1.lsp
+++ /dev/null
@@ -1,7 +1,0 @@
-; -*- scheme -*-
-
-(load "builtins.lsp")
-(load "instructions.lsp")
-(load "system.lsp")
-(load "compiler.lsp")
-(make-system-image "flisp.boot")
--- a/mkfile
+++ b/mkfile
@@ -2,17 +2,17 @@
BIN=/$objtype/bin
TARG=flisp
-CFLAGS=$CFLAGS -p -I. -I3rd -I3rd/brieflz -Iplan9 \
+CFLAGS=$CFLAGS -p -Isrc -I3rd -I3rd/brieflz -Isrc/plan9 \
-D__plan9__ -D__${objtype}__ \-DNDEBUG \
-CLEANFILES=plan9/flisp.boot.s plan9/builtin_fns.h
+CLEANFILES=src/plan9/flisp.boot.s src/plan9/builtin_fns.h
HFILES=\
- equalhash.h\
- flisp.h\
- opcodes.h\
- plan9/platform.h\
+ src/equalhash.h\
+ src/flisp.h\
+ src/opcodes.h\
+ src/plan9/platform.h\
OFILES=\
3rd/brieflz/brieflz.$O\
@@ -22,38 +22,39 @@
3rd/spooky.$O\
3rd/tbl.$O\
3rd/wcwidth.$O\
- bitvector.$O\
- builtins.$O\
- builtins_plan9`{test -f builtins_plan9_$objtype.s && echo -n _$objtype}.$O\- compress.$O\
- cvalues.$O\
- equal.$O\
- equalhash.$O\
- flisp.$O\
- flisp.boot.$O\
- flmain.$O\
- hashing.$O\
- htable.$O\
- ios.$O\
- iostream.$O\
- nan_plan9.$O\
- opcodes.$O\
- operators.$O\
- print.$O\
- ptrhash.$O\
- random.$O\
- read.$O\
- string.$O\
- sys_plan9.$O\
- table.$O\
- types.$O\
- utf8.$O\
+ src/bitvector.$O\
+ src/builtins.$O\
+ src/compress.$O\
+ src/cvalues.$O\
+ src/equal.$O\
+ src/equalhash.$O\
+ src/flisp.$O\
+ src/flmain.$O\
+ src/hashing.$O\
+ src/htable.$O\
+ src/ios.$O\
+ src/iostream.$O\
+ src/nan.$O\
+ src/opcodes.$O\
+ src/operators.$O\
+ src/plan9/clz`{test -f src/plan9/clz_$objtype.s && echo -n _$objtype}.$O\+ src/plan9/flisp.boot.$O\
+ src/plan9/popcount`{test -f src/plan9/popcount_$objtype.s && echo -n _$objtype}.$O\+ src/plan9/sys.$O\
+ src/print.$O\
+ src/ptrhash.$O\
+ src/random.$O\
+ src/read.$O\
+ src/string.$O\
+ src/table.$O\
+ src/types.$O\
+ src/utf8.$O\
default:V: all
</sys/src/cmd/mkone
-plan9/builtin_fns.h:D:
+src/plan9/builtin_fns.h:D:
awk -F '[()]' '\
/^fl_.*fn/ {attr=$1; next} \ /^_Noreturn/ {attr=$1; next} \@@ -61,32 +62,33 @@
{attr=""}' \ `{ls `{echo $OFILES | sed 's/\.'$O'/.c/g'} >[2]/dev/null} | sort >$target-cvalues.$O: fl_arith_any.inc
-flisp.$O: maxstack.inc vm.inc
+cvalues.$O: src/fl_arith_any.inc
+flisp.$O: src/maxstack.inc src/vm.inc
-plan9/flisp.boot.s:D: flisp.boot.builtin
- aux/data2s boot <flisp.boot.builtin >$target
+src/plan9/flisp.boot.s:D: boot/flisp.boot.builtin
+ aux/data2s boot <$prereq >$target
-flisp.boot.$O: plan9/flisp.boot.s
- $AS -o $target plan9/flisp.boot.s
-
%.$O: %.c
$CC $CFLAGS -o $target $stem.c
-%.$O: plan9/builtin_fns.h
+%.$O: %.s
+ $AS $CFLAGS -o $target $stem.s
+%.$O: src/plan9/builtin_fns.h
+
bootstrap:V: $O.out
- ./$O.out gen.lsp && \
- cp flisp.boot flisp.boot.bak && \
- ./$O.out mkboot0.lsp builtins.lsp instructions.lsp system.lsp compiler.lsp > flisp.boot.new && \
- mv flisp.boot.new flisp.boot && \
- cp flisp.boot flisp.boot.builtin && \
+ cd src && \
+ ../$O.out ../tools/gen.lsp && \
+ cp ../boot/flisp.boot ../boot/flisp.boot.bak && \
+ ../$O.out ../tools/mkboot0.lsp builtins.lsp instructions.lsp system.lsp compiler.lsp > ../boot/flisp.boot.new && \
+ mv ../boot/flisp.boot.new ../boot/flisp.boot && \
+ cp ../boot/flisp.boot ../boot/flisp.boot.builtin && \
+ cd .. && \
mk && \
- ./$O.out mkboot1.lsp && \
+ cd boot && \
+ ../$O.out ../tools/mkboot1.lsp && \
+ cd .. && \
mk
-nuke:V:
- rm -f *.[$OS] */*.[$OS] [$OS].out *.acid $TARG $CLEANFILES
-
clean:V:
- rm -f *.[$OS] */*.[$OS] [$OS].out $TARG $CLEANFILES
+ rm -f */*/*.[$OS] */*.[$OS] [$OS].out *.acid $TARG $CLEANFILES
--- a/nan.h
+++ /dev/null
@@ -1,11 +1,0 @@
-#pragma once
-
-#if defined(__plan9__)
-extern double D_PNAN, D_PINF;
-#else
-#define D_PNAN __builtin_nan("")-#define D_PINF __builtin_inf()
-#endif
-extern double D_NNAN, D_NINF;
-
-void nan_init(void);
--- a/nan_plan9.c
+++ /dev/null
@@ -1,18 +1,0 @@
-#include "platform.h"
-#include "nan.h"
-#include "ieee754.h"
-
-double D_PNAN, D_NNAN, D_PINF, D_NINF;
-
-void
-nan_init(void)
-{- D_PNAN = D_NNAN = strtod("+NaN", nil);- D_PINF = D_NINF = strtod("+Inf", nil);-
- union ieee754_double *d;
- d = (union ieee754_double *)&D_NNAN;
- d->ieee.negative = 1;
- d = (union ieee754_double *)&D_NINF;
- d->ieee.negative = 1;
-}
--- a/nan_posix.c
+++ /dev/null
@@ -1,15 +1,0 @@
-#include "platform.h"
-#include "nan.h"
-#include "ieee754.h"
-
-double D_NNAN = D_PNAN, D_NINF = D_PINF;
-
-void
-nan_init(void)
-{- union ieee754_double *d;
- d = (union ieee754_double *)&D_NNAN;
- d->ieee.negative = 1;
- d = (union ieee754_double *)&D_NINF;
- d->ieee.negative = 1;
-}
--- a/opcodes.c
+++ /dev/null
@@ -1,40 +1,0 @@
-#include "flisp.h"
-
-const Builtin builtins[N_OPCODES] = {- [OP_SETCAR] = {"set-car!", 2},- [OP_NANP] = {"nan?", 1},- [OP_CDR] = {"cdr", 1},- [OP_BOOLEANP] = {"boolean?", 1},- [OP_FUNCTIONP] = {"function?", 1},- [OP_CADR] = {"cadr", 1},- [OP_SETCDR] = {"set-cdr!", 2},- [OP_EQ] = {"eq?", 2},- [OP_APPLY] = {"apply", -2},- [OP_NULLP] = {"null?", 1},- [OP_CONSP] = {"cons?", 1},- [OP_ATOMP] = {"atom?", 1},- [OP_ASET] = {"aset!", -3},- [OP_NOT] = {"not", 1},- [OP_LIST] = {"list", ANYARGS},- [OP_CONS] = {"cons", 2},- [OP_NUMBERP] = {"number?", 1},- [OP_BOUNDP] = {"bound?", 1},- [OP_LT] = {"<", -1},- [OP_VECTORP] = {"vector?", 1},- [OP_CAR] = {"car", 1},- [OP_EQV] = {"eqv?", 2},- [OP_IDIV] = {"div0", 2},- [OP_FIXNUMP] = {"fixnum?", 1},- [OP_NUMEQ] = {"=", -1},- [OP_SYMBOLP] = {"symbol?", 1},- [OP_BUILTINP] = {"builtin?", 1},- [OP_SUB] = {"-", -1},- [OP_COMPARE] = {"compare", 2},- [OP_FOR] = {"for", 3},- [OP_MUL] = {"*", ANYARGS},- [OP_ADD] = {"+", ANYARGS},- [OP_AREF] = {"aref", -2},- [OP_DIV] = {"/", -1},- [OP_VECTOR] = {"vector", ANYARGS},- [OP_EQUAL] = {"equal?", 2},-};
--- a/opcodes.h
+++ /dev/null
@@ -1,101 +1,0 @@
-typedef enum {- OP_LOADA0,
- OP_LOADA1,
- OP_LOADV,
- OP_BRF,
- OP_POP,
- OP_CALL,
- OP_TCALL,
- OP_LOADG,
- OP_LOADA,
- OP_LOADC,
- OP_RET,
- OP_DUP,
- OP_CAR,
- OP_CDR,
- OP_CLOSURE,
- OP_SETA,
- OP_JMP,
- OP_LOADC0,
- OP_CONSP,
- OP_BRNE,
- OP_LOADT,
- OP_LOAD0,
- OP_LOADC1,
- OP_AREF2,
- OP_ATOMP,
- OP_BRT,
- OP_BRNN,
- OP_LOAD1,
- OP_LT,
- OP_ADD2,
- OP_SETCDR,
- OP_LOADF,
- OP_CONS,
- OP_EQ,
- OP_SYMBOLP,
- OP_NOT,
- OP_CADR,
- OP_NEG,
- OP_NULLP,
- OP_BOOLEANP,
- OP_NUMBERP,
- OP_FIXNUMP,
- OP_BOUNDP,
- OP_BUILTINP,
- OP_FUNCTIONP,
- OP_VECTORP,
- OP_SHIFT,
- OP_SETCAR,
- OP_JMPL,
- OP_BRFL,
- OP_BRTL,
- OP_EQV,
- OP_EQUAL,
- OP_LIST,
- OP_APPLY,
- OP_ADD,
- OP_SUB,
- OP_MUL,
- OP_DIV,
- OP_IDIV,
- OP_NUMEQ,
- OP_COMPARE,
- OP_ARGC,
- OP_VECTOR,
- OP_ASET,
- OP_LOADNIL,
- OP_LOADI8,
- OP_LOADVL,
- OP_LOADGL,
- OP_LOADAL,
- OP_LOADCL,
- OP_SETG,
- OP_SETGL,
- OP_SETAL,
- OP_VARGC,
- OP_TRYCATCH,
- OP_FOR,
- OP_TAPPLY,
- OP_SUB2,
- OP_LARGC,
- OP_LVARGC,
- OP_CALLL,
- OP_TCALLL,
- OP_BRNEL,
- OP_BRNNL,
- OP_BRN,
- OP_BRNL,
- OP_OPTARGS,
- OP_BRBOUND,
- OP_KEYARGS,
- OP_BOX,
- OP_BOXL,
- OP_AREF,
- OP_LOADVOID,
- OP_NANP,
- OP_EOF_OBJECT,
- N_OPCODES
-}opcode_t;
-
-extern const Builtin builtins[N_OPCODES];
--- a/operators.c
+++ /dev/null
@@ -1,290 +1,0 @@
-#include "flisp.h"
-#include "operators.h"
-
-mpint *
-conv_to_mpint(void *data, numerictype_t tag)
-{- switch(tag){- case T_INT8: return itomp(*(int8_t*)data, nil);
- case T_UINT8: return uitomp(*(uint8_t*)data, nil);
- case T_INT16: return itomp(*(int16_t*)data, nil);
- case T_UINT16: return uitomp(*(uint16_t*)data, nil);
- case T_INT32: return itomp(*(int32_t*)data, nil);
- case T_UINT32: return uitomp(*(uint32_t*)data, nil);
- case T_INT64: return vtomp(*(int64_t*)data, nil);
- case T_UINT64: return uvtomp(*(int64_t*)data, nil);
- case T_MPINT: return mpcopy(*(mpint**)data);
- case T_FLOAT: return dtomp(*(float*)data, nil);
- case T_DOUBLE: return dtomp(*(double*)data, nil);
- }
- return mpzero;
-}
-
-fl_purefn
-double
-conv_to_double(void *data, numerictype_t tag)
-{- double d;
- switch(tag){- case T_INT8: return *(int8_t*)data;
- case T_UINT8: return *(uint8_t*)data;
- case T_INT16: return *(int16_t*)data;
- case T_UINT16: return *(uint16_t*)data;
- case T_INT32: return *(int32_t*)data;
- case T_UINT32: return *(uint32_t*)data;
- case T_INT64:
- d = *(int64_t*)data;
- if(d > 0 && *(int64_t*)data < 0) // can happen!
- d = -d;
- return d;
- case T_UINT64: return *(uint64_t*)data;
- case T_MPINT: return mptod(*(mpint**)data);
- case T_FLOAT: return *(float*)data;
- case T_DOUBLE: return *(double*)data;
- }
- return 0;
-}
-
-void
-conv_from_double(void *dest, double d, numerictype_t tag)
-{- switch(tag){- case T_INT8: *(int8_t*)dest = d; break;
- case T_UINT8: *(uint8_t*)dest = d; break;
- case T_INT16: *(int16_t*)dest = d; break;
- case T_UINT16: *(uint16_t*)dest = d; break;
- case T_INT32: *(int32_t*)dest = d; break;
- case T_UINT32: *(uint32_t*)dest = d; break;
- case T_INT64:
- *(int64_t*)dest = d;
- if(d > 0 && *(int64_t*)dest < 0) // 0x8000000000000000 is a bitch
- *(int64_t*)dest = INT64_MAX;
- break;
- case T_UINT64: *(uint64_t*)dest = d; break;
- case T_MPINT: *(mpint**)dest = dtomp(d, nil); break;
- case T_FLOAT: *(float*)dest = d; break;
- case T_DOUBLE: *(double*)dest = d; break;
- }
-}
-
-// FIXME sign with mpint
-#define CONV_TO_INTTYPE(name, ctype) \
-fl_purefn \
-ctype \
-conv_to_##name(void *data, numerictype_t tag) \
-{ \- switch(tag){ \- case T_INT8: return (ctype)*(int8_t*)data; \
- case T_UINT8: return (ctype)*(uint8_t*)data; \
- case T_INT16: return (ctype)*(int16_t*)data; \
- case T_UINT16: return (ctype)*(uint16_t*)data; \
- case T_INT32: return (ctype)*(int32_t*)data; \
- case T_UINT32: return (ctype)*(uint32_t*)data; \
- case T_INT64: return (ctype)*(int64_t*)data; \
- case T_UINT64: return (ctype)*(uint64_t*)data; \
- case T_MPINT: return (ctype)mptov(*(mpint**)data); \
- case T_FLOAT: return (ctype)*(float*)data; \
- case T_DOUBLE: return (ctype)*(double*)data; \
- } \
- return 0; \
-}
-
-CONV_TO_INTTYPE(int64, int64_t)
-CONV_TO_INTTYPE(int32, int32_t)
-CONV_TO_INTTYPE(uint32, uint32_t)
-
-// this is needed to work around an UB casting negative
-// floats and doubles to uint64. you need to cast to int64
-// first.
-fl_purefn
-uint64_t
-conv_to_uint64(void *data, numerictype_t tag)
-{- int64_t s;
- switch(tag){- case T_INT8: return *(int8_t*)data; break;
- case T_UINT8: return *(uint8_t*)data; break;
- case T_INT16: return *(int16_t*)data; break;
- case T_UINT16: return *(uint16_t*)data; break;
- case T_INT32: return *(int32_t*)data; break;
- case T_UINT32: return *(uint32_t*)data; break;
- case T_INT64: return *(int64_t*)data; break;
- case T_UINT64: return *(uint64_t*)data; break;
- case T_MPINT: return mptouv(*(mpint**)data); break;
- case T_FLOAT:
- if(*(float*)data >= 0)
- return *(float*)data;
- s = *(float*)data;
- return s;
- case T_DOUBLE:
- if(*(double*)data >= 0)
- return *(double*)data;
- s = *(double*)data;
- return s;
- }
- return 0;
-}
-
-fl_purefn
-int
-cmp_same_lt(void *a, void *b, numerictype_t tag)
-{- switch(tag){- case T_INT8: return *(int8_t*)a < *(int8_t*)b;
- case T_UINT8: return *(uint8_t*)a < *(uint8_t*)b;
- case T_INT16: return *(int16_t*)a < *(int16_t*)b;
- case T_UINT16: return *(uint16_t*)a < *(uint16_t*)b;
- case T_INT32: return *(int32_t*)a < *(int32_t*)b;
- case T_UINT32: return *(uint32_t*)a < *(uint32_t*)b;
- case T_INT64: return *(int64_t*)a < *(int64_t*)b;
- case T_UINT64: return *(uint64_t*)a < *(uint64_t*)b;
- case T_MPINT: return mpcmp(*(mpint**)a, *(mpint**)b) < 0;
- case T_FLOAT: return *(float*)a < *(float*)b;
- case T_DOUBLE: return *(double*)a < *(double*)b;
- }
- return 0;
-}
-
-fl_purefn
-int
-cmp_same_eq(void *a, void *b, numerictype_t tag)
-{- switch(tag){- case T_INT8: return *(int8_t*)a == *(int8_t*)b;
- case T_UINT8: return *(uint8_t*)a == *(uint8_t*)b;
- case T_INT16: return *(int16_t*)a == *(int16_t*)b;
- case T_UINT16: return *(uint16_t*)a == *(uint16_t*)b;
- case T_INT32: return *(int32_t*)a == *(int32_t*)b;
- case T_UINT32: return *(uint32_t*)a == *(uint32_t*)b;
- case T_INT64: return *(int64_t*)a == *(int64_t*)b;
- case T_UINT64: return *(uint64_t*)a == *(uint64_t*)b;
- case T_MPINT: return mpcmp(*(mpint**)a, *(mpint**)b) == 0;
- case T_FLOAT: return *(float*)a == *(float*)b && !isnan(*(float*)a);
- case T_DOUBLE: return *(double*)a == *(double*)b && !isnan(*(double*)b);
- }
- return 0;
-}
-
-/* FIXME one is allocated for all compare ops */
-static mpint *cmpmpint;
-
-int
-cmp_lt(void *a, numerictype_t atag, void *b, numerictype_t btag)
-{- if(atag == btag)
- return cmp_same_lt(a, b, atag);
-
- double da = conv_to_double(a, atag);
- double db = conv_to_double(b, btag);
-
- // casting to double will only get the wrong answer for big int64s
- // that differ in low bits
- if(da < db && !isnan(da) && !isnan(db))
- return 1;
- if(db < da)
- return 0;
-
- if(cmpmpint == nil && (atag == T_MPINT || btag == T_MPINT))
- cmpmpint = mpnew(0);
-
- if(atag == T_UINT64){- if(btag == T_INT64){- if(*(int64_t*)b >= 0)
- return *(uint64_t*)a < (uint64_t)*(int64_t*)b;
- return (int64_t)*(uint64_t*)a < *(int64_t*)b;
- }
- if(btag == T_DOUBLE)
- return db == db ? *(uint64_t*)a < (uint64_t)*(double*)b : 0;
- if(btag == T_MPINT)
- return mpcmp(uvtomp(*(uint64_t*)a, cmpmpint), *(mpint**)b) < 0;
- }
- if(atag == T_INT64){- if(btag == T_UINT64){- if(*(int64_t*)a >= 0)
- return (uint64_t)*(int64_t*)a < *(uint64_t*)b;
- return *(int64_t*)a < (int64_t)*(uint64_t*)b;
- }
- if(btag == T_DOUBLE)
- return db == db ? *(int64_t*)a < (int64_t)*(double*)b : 0;
- if(btag == T_MPINT)
- return mpcmp(vtomp(*(int64_t*)a, cmpmpint), *(mpint**)b) < 0;
- }
- if(btag == T_UINT64){- if(atag == T_DOUBLE)
- return da == da ? *(uint64_t*)b > (uint64_t)*(double*)a : 0;
- if(atag == T_MPINT)
- return mpcmp(*(mpint**)a, uvtomp(*(uint64_t*)b, cmpmpint)) < 0;
- }
- if(btag == T_INT64){- if(atag == T_DOUBLE)
- return da == da ? *(int64_t*)b > (int64_t)*(double*)a : 0;
- if(atag == T_MPINT)
- return mpcmp(*(mpint**)a, vtomp(*(int64_t*)b, cmpmpint)) < 0;
- }
- return 0;
-}
-
-int
-cmp_eq(void *a, numerictype_t atag, void *b, numerictype_t btag, int equalnans)
-{- union {- double d;
- int64_t i64;
- }u, v;
-
- if(atag == btag && (!equalnans || atag < T_FLOAT))
- return cmp_same_eq(a, b, atag);
-
- double da = conv_to_double(a, atag);
- double db = conv_to_double(b, btag);
-
- if((int)atag >= T_FLOAT && (int)btag >= T_FLOAT){- if(equalnans){- u.d = da; v.d = db;
- return u.i64 == v.i64;
- }
- return da == db;
- }
-
- if(da != db)
- return 0;
-
- if(cmpmpint == nil && (atag == T_MPINT || btag == T_MPINT))
- cmpmpint = mpnew(0);
-
- if(atag == T_UINT64){- // this is safe because if a had been bigger than INT64_MAX,
- // we would already have concluded that it's bigger than b.
- if(btag == T_INT64)
- return (int64_t)*(uint64_t*)a == *(int64_t*)b;
- if(btag == T_DOUBLE)
- return *(uint64_t*)a == (uint64_t)(int64_t)*(double*)b;
- if(btag == T_MPINT)
- return mpcmp(uvtomp(*(uint64_t*)a, cmpmpint), *(mpint**)b) == 0;
- }
- if(atag == T_INT64){- if(btag == T_UINT64)
- return *(int64_t*)a == (int64_t)*(uint64_t*)b;
- if(btag == T_DOUBLE)
- return *(int64_t*)a == (int64_t)*(double*)b;
- if(btag == T_MPINT)
- return mpcmp(vtomp(*(int64_t*)a, cmpmpint), *(mpint**)b) == 0;
- }
- if(btag == T_UINT64){- if(atag == T_INT64)
- return (int64_t)*(uint64_t*)b == *(int64_t*)a;
- if(atag == T_DOUBLE)
- return *(uint64_t*)b == (uint64_t)(int64_t)*(double*)a;
- if(atag == T_MPINT)
- return mpcmp(*(mpint**)a, uvtomp(*(uint64_t*)b, cmpmpint)) == 0;
- }
- if(btag == T_INT64){- if(atag == T_UINT64)
- return *(int64_t*)b == (int64_t)*(uint64_t*)a;
- if(atag == T_DOUBLE)
- return *(int64_t*)b == (int64_t)*(double*)a;
- if(atag == T_MPINT)
- return mpcmp(*(mpint**)a, vtomp(*(int64_t*)b, cmpmpint)) == 0;
- }
- return 1;
-}
--- a/operators.h
+++ /dev/null
@@ -1,16 +1,0 @@
-#pragma once
-
-mpint * conv_to_mpint(void *data, numerictype_t tag);
-double conv_to_double(void *data, numerictype_t tag);
-void conv_from_double(void *dest, double d, numerictype_t tag);
-
-int cmp_same_lt(void *a, void *b, numerictype_t tag);
-int cmp_same_eq(void *a, void *b, numerictype_t tag);
-int cmp_lt(void *a, numerictype_t atag, void *b, numerictype_t btag);
-int cmp_eq(void *a, numerictype_t atag, void *b, numerictype_t btag, int equalnans);
-
-int64_t conv_to_int64(void *data, numerictype_t tag);
-uint64_t conv_to_uint64(void *data, numerictype_t tag);
-int32_t conv_to_int32(void *data, numerictype_t tag);
-uint32_t conv_to_uint32(void *data, numerictype_t tag);
-Rune conv_to_Rune(void *data, numerictype_t tag);
--- a/ops2h.sh
+++ /dev/null
@@ -1,3 +1,0 @@
-#!/bin/sh
-set -e
-sed -nE 's/.*(OP_[A-Z0-9]+).*/GOTO_OP_OFFSET(\1),/p' $* | sort -u
--- a/plan9/platform.h
+++ /dev/null
@@ -1,146 +1,0 @@
-#pragma once
-
-#include <u.h>
-#include <libc.h>
-#include <ctype.h>
-#include <mp.h>
-
-#ifdef NDEBUG
-#undef assert
-#define assert(x)
-#define static_assert(a,b)
-#else
-#define static_assert_cat(a, b) a##b
-#define static_assert_name(line) static_assert_cat(static_assert_, line)
-#define static_assert(must_be_true, message) \
- static const void *static_assert_name(__LINE__) \
- [must_be_true ? 2 : -1] = { \- message, \
- static_assert_name(__LINE__), \
- }
-#endif
-
-#define __os_name__ "plan9"
-
-static int
-fl_popcount(u32int w)
-{- w -= (w >> 1) & 0x55555555U;
- w = (w & 0x33333333U) + ((w >> 2) & 0x33333333U);
- w = (w + (w >> 4)) & 0x0F0F0F0FU;
- w = (w * 0x01010101U) >> 24;
- return w;
-}
-
-int fl_clz(unsigned int x);
-
-#if defined(__amd64__) || \
- defined(__arm64__) || \
- defined(__mips64__) || \
- defined(__power64__) || \
- defined(__sparc64__)
-#define BITS64
-#define PRIdPTR PRId64
-#define PRIuPTR PRIu64
-#else
-#define PRIdPTR "ld"
-#define PRIuPTR "lud"
-#endif
-
-#if defined(__386__) || defined(__amd64__) || defined(__arm64__)
-#define MEM_UNALIGNED_ACCESS
-#endif
-
-#define unsetenv(name) putenv(name, "")
-#define setenv(name, val, overwrite) putenv(name, val)
-#define exit(x) exits((x) ? "error" : nil)
-#define isinf(x) isInf(x, 0)
-#define isnan(x) isNaN(x)
-
-#define getcwd getwd
-#define vsnprintf vsnprint
-#define vdprintf vfprint
-#define snprintf snprint
-#define strcasecmp cistrcmp
-#define lseek seek
-#define towupper toupperrune
-#define towlower tolowerrune
-#define iswalpha isalpharune
-#define signbit(r) ((*(uint64_t*)&(r)) & (1ULL<<63))
-#define isfinite(d) (((*(uint64_t*)&(d))&0x7ff0000000000000ULL) != 0x7ff0000000000000ULL)
-
-#define PRId32 "d"
-#define PRIu32 "ud"
-#define PRIx32 "x"
-#define PRId64 "lld"
-#define PRIu64 "llud"
-#define PRIx64 "llx"
-
-#define INT32_MAX 0x7fffffff
-#define UINT32_MAX 0xffffffffU
-#define INT32_MIN (-INT32_MAX-1)
-#define INT64_MIN ((int64_t)0x8000000000000000LL)
-#define INT64_MAX 0x7fffffffffffffffLL
-#define UINT64_MAX 0xffffffffffffffffULL
-#define ULONG_MAX UINT32_MAX
-
-#define PATHSEP '/'
-#define PATHSEPSTRING "/"
-#define PATHLISTSEP ':'
-#define PATHLISTSEPSTRING ":"
-#define ISPATHSEP(c) ((c) == '/')
-
-enum {- SEEK_SET,
- SEEK_CUR,
- SEEK_END,
-
- STDIN_FILENO = 0,
- STDOUT_FILENO,
- STDERR_FILENO,
-};
-
-#define O_RDWR ORDWR
-#define O_WRONLY OWRITE
-#define O_RDONLY OREAD
-#define O_TRUNC OTRUNC
-#define F_OK 0
-
-#define LITTLE_ENDIAN 1234
-#define BIG_ENDIAN 4321
-
-#if defined(__mips__) || \
- defined(__power__) || defined(__power64__) || \
- defined(__sparc__) || defined(__sparc64__)
-#define BYTE_ORDER BIG_ENDIAN
-#else
-#define BYTE_ORDER LITTLE_ENDIAN
-#endif
-
-typedef s8int int8_t;
-typedef s16int int16_t;
-typedef s32int int32_t;
-typedef s64int int64_t;
-typedef u8int uint8_t;
-typedef u16int uint16_t;
-typedef u32int uint32_t;
-typedef u64int uint64_t;
-typedef vlong off_t;
-typedef intptr intptr_t;
-typedef uintptr uintptr_t;
-typedef intptr ssize_t;
-typedef uintptr size_t;
-typedef enum { false, true } bool;-
-int wcwidth(Rune c);
-int ftruncate(int f, off_t sz);
-
-#if !defined(INITIAL_HEAP_SIZE)
-#define INITIAL_HEAP_SIZE 16*1024*1024
-#endif
-#if !defined(ALLOC_LIMIT_TRIGGER)
-#define ALLOC_LIMIT_TRIGGER INITIAL_HEAP_SIZE
-#endif
-
-#include "cc.h"
-#include "mem.h"
--- a/posix/platform.h
+++ /dev/null
@@ -1,102 +1,0 @@
-#pragma once
-
-#define _XOPEN_SOURCE 700
-#include <assert.h>
-#include <ctype.h>
-#if defined(__APPLE__)
-#include <machine/endian.h>
-#else
-#include <endian.h>
-#endif
-#include <errno.h>
-#include <fcntl.h>
-#include <float.h>
-#include <inttypes.h>
-#include <limits.h>
-#include <locale.h>
-#include <math.h>
-#include <setjmp.h>
-#include <stdbool.h>
-#include <stdarg.h>
-#include <stdio.h>
-#include <stddef.h>
-#include <stdint.h>
-#include <stdlib.h>
-#include <string.h>
-#include <strings.h>
-#include <sys/stat.h>
-#include <sys/time.h>
-#include <time.h>
-#include <unistd.h>
-#include <wctype.h>
-#include <wchar.h>
-
-#if defined(__linux__)
-#define __os_name__ "linux"
-#elif defined(__OpenBSD__)
-#define __os_name__ "openbsd"
-#elif defined(__FreeBSD__)
-#define __os_name__ "freebsd"
-#elif defined(__NetBSD__)
-#define __os_name__ "netbsd"
-#elif defined(__DragonFly__)
-#define __os_name__ "dragonflybsd"
-#elif defined(__APPLE__)
-#define __os_name__ "macosx"
-#elif defined(__HAIKU__)
-#define __os_name__ "haiku"
-#else
-#define __os_name__ "unknown"
-#endif
-
-extern char __os_version__[];
-#define __os_version__ __os_version__
-
-#ifndef __SIZEOF_POINTER__
-#error pointer size unknown
-#elif __SIZEOF_POINTER__ == 8
-#define BITS64
-#endif
-
-#define nil NULL
-#define USED(x) ((void)(x))
-#define nelem(x) (int)(sizeof(x)/sizeof((x)[0]))
-
-#define PATHSEP '/'
-#define PATHSEPSTRING "/"
-#define PATHLISTSEP ':'
-#define PATHLISTSEPSTRING ":"
-#define ISPATHSEP(c) ((c) == '/')
-
-#if !defined(BYTE_ORDER)
-#if !defined(__BYTE_ORDER)
-#define LITTLE_ENDIAN 1234
-#define BIG_ENDIAN 4321
-#if defined(__LITTLE_ENDIAN__)
-#define BYTE_ORDER LITTLE_ENDIAN
-#else
-#define BYTE_ORDER BIG_ENDIAN
-#endif
-#else
-#define LITTLE_ENDIAN __LITTLE_ENDIAN
-#define BIG_ENDIAN __BIG_ENDIAN
-#define BYTE_ORDER __BYTE_ORDER
-#endif
-#endif
-
-// FIXME: __clang__ because no idea how to check if ubsan is enabled.
-#if !defined(__clang__) && (defined(__386__) || defined(__x86_64__) || defined(__aarch64__))
-#define MEM_UNALIGNED_ACCESS
-#endif
-
-#if !defined(INITIAL_HEAP_SIZE)
-#define INITIAL_HEAP_SIZE 16*1024*1024
-#endif
-#if !defined(ALLOC_LIMIT_TRIGGER)
-#define ALLOC_LIMIT_TRIGGER INITIAL_HEAP_SIZE
-#endif
-
-#include "cc.h"
-#include "mem.h"
-#include "mp.h"
-#include "utf.h"
--- a/print.c
+++ /dev/null
@@ -1,873 +1,0 @@
-#include "flisp.h"
-#include "operators.h"
-#include "cvalues.h"
-#include "ieee754.h"
-#include "print.h"
-#include "read.h"
-
-#define LOG2_10 3.321928094887362347870319429489
-
-static void
-outc(ios_t *f, char c)
-{- ios_putc(f, c);
- if(c == '\n')
- FL(hpos) = 0;
- else
- FL(hpos)++;
-}
-
-static void
-outs(ios_t *f, const char *s)
-{- ios_puts(f, s);
- FL(hpos) += u8_strwidth(s);
-}
-
-static void
-outsn(ios_t *f, const char *s, size_t n)
-{- ios_write(f, s, n);
- FL(hpos) += u8_strwidth(s);
-}
-
-static int
-outindent(ios_t *f, int n)
-{- // move back to left margin if we get too indented
- if(n > FL(scr_width)-12)
- n = 2;
- int n0 = n;
- ios_putc(f, '\n');
- FL(vpos)++;
- FL(hpos) = n;
- while(n >= 8){- ios_putc(f, '\t');
- n -= 8;
- }
- while(n){- ios_putc(f, ' ');
- n--;
- }
- return n0;
-}
-
-void
-fl_print_chr(ios_t *f, char c)
-{- outc(f, c);
-}
-
-void
-fl_print_str(ios_t *f, const char *s)
-{- outs(f, s);
-}
-
-void
-print_traverse(value_t v)
-{- value_t *bp;
- while(iscons(v)){- if(ismarked(v)){- bp = (value_t*)ptrhash_bp(&FL(printconses), (void*)v);
- if(*bp == (value_t)HT_NOTFOUND)
- *bp = fixnum(FL(printlabel)++);
- return;
- }
- mark_cons(v);
- print_traverse(car_(v));
- v = cdr_(v);
- }
- if(!ismanaged(v) || issymbol(v))
- return;
- if(ismarked(v)){- bp = (value_t*)ptrhash_bp(&FL(printconses), (void*)v);
- if(*bp == (value_t)HT_NOTFOUND)
- *bp = fixnum(FL(printlabel)++);
- return;
- }
- if(isvector(v)){- if(vector_size(v) > 0)
- mark_cons(v);
- unsigned int i;
- for(i = 0; i < vector_size(v); i++)
- print_traverse(vector_elt(v, i));
- }else if(iscprim(v)){- // don't consider shared references to e.g. chars
- }else if(isclosure(v)){- mark_cons(v);
- function_t *f = ptr(v);
- print_traverse(f->bcode);
- print_traverse(f->vals);
- print_traverse(f->env);
- }else if(iscvalue(v)){- cvalue_t *cv = ptr(v);
- // don't consider shared references to ""
- if(!cv_isstr(cv) || cv_len(cv) != 0)
- mark_cons(v);
- fltype_t *t = cv_class(cv);
- if(t->vtable != nil && t->vtable->print_traverse != nil)
- t->vtable->print_traverse(v);
- }
-}
-
-static void
-print_symbol_name(ios_t *f, const char *name)
-{- int i, escape = 0, charescape = 0;
-
- if((name[0] == '\0') ||
- (name[0] == '.' && name[1] == '\0') ||
- (name[0] == '#') ||
- fl_read_numtok(name, nil, 0))
- escape = 1;
- i = 0;
- while(name[i]){- if(!symchar(name[i])){- escape = 1;
- if(name[i] == '|' || name[i] == '\\'){- charescape = 1;
- break;
- }
- }
- i++;
- }
- if(escape){- if(charescape){- outc(f, '|');
- i = 0;
- while(name[i]){- if(name[i] == '|' || name[i] == '\\')
- outc(f, '\\');
- outc(f, name[i]);
- i++;
- }
- outc(f, '|');
- }else{- outc(f, '|');
- outs(f, name);
- outc(f, '|');
- }
- }else{- outs(f, name);
- }
-}
-
-/*
- The following implements a simple pretty-printing algorithm. This is
- an unlimited-width approach that doesn't require an extra pass.
- It uses some heuristics to guess whether an expression is "small",
- and avoids wrapping symbols across lines. The result is high
- performance and nice output for typical code. Quality is poor for
- pathological or deeply-nested expressions, but those are difficult
- to print anyway.
-*/
-#define SMALL_STR_LEN 20
-static inline int
-tinyp(value_t v)
-{- if(issymbol(v))
- return u8_strwidth(symbol_name(v)) < SMALL_STR_LEN;
- if(fl_isstring(v))
- return cv_len(ptr(v)) < SMALL_STR_LEN;
- return (
- isfixnum(v) || isbuiltin(v) || iscprim(v) ||
- v == FL_f || v == FL_t ||
- v == FL_nil || v == FL_eof || v == FL_void
- );
-}
-
-static int
-smallp(value_t v)
-{- if(tinyp(v))
- return 1;
- if(fl_isnumber(v))
- return 1;
- if(iscons(v)){- if(tinyp(car_(v)) &&
- (tinyp(cdr_(v)) || (iscons(cdr_(v)) && tinyp(car_(cdr_(v))) && cdr_(cdr_(v)) == FL_nil)))
- return 1;
- return 0;
- }
- if(isvector(v)){- size_t s = vector_size(v);
- return (
- s == 0 ||
- (tinyp(vector_elt(v, 0)) && (s == 1 || (s == 2 && tinyp(vector_elt(v, 1)))))
- );
- }
- return 0;
-}
-
-static int
-specialindent(value_t head)
-{- // indent these forms 2 spaces, not lined up with the first argument
- if(head == FL_lambda || head == FL_trycatch || head == FL_definesym ||
- head == FL_defmacrosym || head == FL_forsym)
- return 2;
- return -1;
-}
-
-static int
-lengthestimate(value_t v)
-{- // get the width of an expression if we can do so cheaply
- if(issymbol(v))
- return u8_strwidth(symbol_name(v));
- if(iscprim(v) && ptr(v) != nil && cp_class(ptr(v)) == FL(runetype))
- return 4;
- return -1;
-}
-
-static int
-allsmallp(value_t v)
-{- int n = 1;
- while(iscons(v)){- if(!smallp(car_(v)))
- return 0;
- v = cdr_(v);
- n++;
- if(n > 25)
- return n;
- }
- return n;
-}
-
-static int
-indentafter3(value_t head, value_t v)
-{- // for certain X always indent (X a b c) after b
- return head == FL_forsym && !allsmallp(cdr_(v));
-}
-
-static int
-indentafter2(value_t head, value_t v)
-{- // for certain X always indent (X a b) after a
- return (head == FL_definesym || head == FL_defmacrosym) && !allsmallp(cdr_(v));
-}
-
-static int
-indentevery(value_t v)
-{- // indent before every subform of a special form, unless every
- // subform is "small"
- value_t c = car_(v);
- if(c == FL_lambda || c == FL_setqsym)
- return 0;
- //if(c == FL(IF)) // TODO: others
- // return !allsmallp(cdr_(v));
- return 0;
-}
-
-static int
-blockindent(value_t v)
-{- // in this case we switch to block indent mode, where the head
- // is no longer considered special:
- // (a b c d e
- // f g h i j)
- return allsmallp(v) > 9;
-}
-
-static void
-print_cons(ios_t *f, value_t v)
-{- value_t cd;
- const char *op;
- if(iscons(cdr_(v)) && cdr_(cdr_(v)) == FL_nil &&
- !ptrhash_has(&FL(printconses), (void*)cdr_(v)) &&
- ((car_(v) == FL_quote && (op = "'")) ||
- (car_(v) == FL_backquote && (op = "`")) ||
- (car_(v) == FL_comma && (op = ",")) ||
- (car_(v) == FL_commaat && (op = ",@")) ||
- (car_(v) == FL_commadot && (op = ",.")))){- // special prefix syntax
- unmark_cons(v);
- unmark_cons(cdr_(v));
- outs(f, op);
- fl_print_child(f, car_(cdr_(v)));
- return;
- }
- int startpos = FL(hpos);
- outc(f, '(');- int newindent = FL(hpos), blk = blockindent(v);
- int lastv, n = 0, si, ind, est, always = 0, nextsmall, thistiny;
- if(!blk)
- always = indentevery(v);
- value_t head = car_(v);
- int after3 = indentafter3(head, v);
- int after2 = indentafter2(head, v);
- int n_unindented = 1;
- while(1){- cd = cdr_(v);
- if(FL(print_length) >= 0 && n >= FL(print_length) && cd != FL_nil){- outsn(f, "...)", 4);
- break;
- }
- lastv = FL(vpos);
- unmark_cons(v);
- fl_print_child(f, car_(v));
- if(!iscons(cd) || ptrhash_has(&FL(printconses), (void*)cd)){- if(cd != FL_nil){- outsn(f, " . ", 3);
- fl_print_child(f, cd);
- }
- outc(f, ')');
- break;
- }
-
- if(!FL(print_pretty) ||
- (head == FL_lambda && n == 0)){- // never break line before lambda-list
- ind = 0;
- }else{- est = lengthestimate(car_(cd));
- nextsmall = smallp(car_(cd));
- thistiny = tinyp(car_(v));
- ind = ((FL(vpos) > lastv ||
- (FL(hpos)>FL(scr_width)/2 && !nextsmall && !thistiny && n>0)) ||
-
- (FL(hpos) > FL(scr_width)-4) ||
-
- (est != -1 && FL(hpos)+est > FL(scr_width)-2) ||
-
- (head == FL_lambda && !nextsmall) ||
-
- (n > 0 && always) ||
-
- (n == 2 && after3) ||
- (n == 1 && after2) ||
-
- (n_unindented >= 3 && !nextsmall) ||
-
- (n == 0 && !smallp(head)));
- }
-
- if(ind){- newindent = outindent(f, newindent);
- n_unindented = 1;
- }else{- n_unindented++;
- outc(f, ' ');
- if(n == 0){- // set indent level after printing head
- si = specialindent(head);
- if(si != -1)
- newindent = startpos + si;
- else if(!blk)
- newindent = FL(hpos);
- }
- }
- n++;
- v = cd;
- }
-}
-
-static void cvalue_print(ios_t *f, value_t v);
-
-static int
-print_circle_prefix(ios_t *f, value_t v)
-{- value_t label;
- if((label = (value_t)ptrhash_get(&FL(printconses), (void*)v)) != (value_t)HT_NOTFOUND){- if(!ismarked(v)){- FL(hpos) += ios_printf(f, "#%"PRIdPTR"#", (intptr_t)numval(label));
- return 1;
- }
- FL(hpos) += ios_printf(f, "#%"PRIdPTR"=", (intptr_t)numval(label));
- }
- if(ismanaged(v))
- unmark_cons(v);
- return 0;
-}
-
-void
-fl_print_child(ios_t *f, value_t v)
-{- const char *name;
- if(FL(print_level) >= 0 && FL(p_level) >= FL(print_level) && (iscons(v) || isvector(v) || isclosure(v))){- outc(f, '#');
- return;
- }
- FL(p_level)++;
-
- switch(tag(v)){- case TAG_NUM: case TAG_NUM1:
- FL(hpos) += ios_printf(f, "%"PRIdFIXNUM, numval(v));
- break;
- case TAG_SYM:
- name = symbol_name(v);
- if(FL(print_princ))
- outs(f, name);
- else if(ismanaged(v)){- outsn(f, "#:", 2);
- outs(f, name);
- }else
- print_symbol_name(f, name);
- break;
- case TAG_FUNCTION:
- if(v == FL_t)
- outsn(f, "#t", 2);
- else if(v == FL_f)
- outsn(f, "#f", 2);
- else if(v == FL_nil)
- outsn(f, "nil", 3);
- else if(v == FL_eof)
- outsn(f, "#<eof>", 6);
- else if(v == FL_void){- outsn(f, "#<void>", 7);
- }else if(isbuiltin(v)){- if(!FL(print_princ))
- outsn(f, "#.", 2);
- outs(f, builtins[uintval(v)].name);
- }else{- assert(isclosure(v));
- if(!FL(print_princ)){- if(print_circle_prefix(f, v))
- break;
- function_t *fn = ptr(v);
- outs(f, "#fn(");- char *data = cvalue_data(fn->bcode);
- size_t i, sz = cvalue_len(fn->bcode);
- for(i = 0; i < sz; i++)
- data[i] += 48;
- fl_print_child(f, fn->bcode);
- for(i = 0; i < sz; i++)
- data[i] -= 48;
- outc(f, ' ');
- fl_print_child(f, fn->vals);
- if(fn->env != FL_nil){- outc(f, ' ');
- fl_print_child(f, fn->env);
- }
- if(fn->name != FL_lambda){- outc(f, ' ');
- fl_print_child(f, fn->name);
- }
- outc(f, ')');
- }else{- outs(f, "#<function>");
- }
- }
- break;
- case TAG_CPRIM:
- if(v == UNBOUND)
- outs(f, "#<undefined>");
- else
- cvalue_print(f, v);
- break;
- case TAG_CVALUE:
- case TAG_VECTOR:
- case TAG_CONS:
- if(!FL(print_princ) && print_circle_prefix(f, v))
- break;
- if(isvector(v)){- outs(f, "#(");- int newindent = FL(hpos), est;
- int i, sz = vector_size(v);
- for(i = 0; i < sz; i++){- if(FL(print_length) >= 0 && i >= FL(print_length) && i < sz-1){- outsn(f, "...", 3);
- break;
- }
- fl_print_child(f, vector_elt(v, i));
- if(i < sz-1){- if(!FL(print_pretty))
- outc(f, ' ');
- else{- est = lengthestimate(vector_elt(v, i+1));
- if(FL(hpos) > FL(scr_width)-4 ||
- (est != -1 && (FL(hpos)+est > FL(scr_width)-2)) ||
- (FL(hpos) > FL(scr_width)/2 && !smallp(vector_elt(v, i+1)) && !tinyp(vector_elt(v, i))))
- newindent = outindent(f, newindent);
- else
- outc(f, ' ');
- }
- }
- }
- outc(f, ')');
- break;
- }
- if(iscvalue(v))
- cvalue_print(f, v);
- else
- print_cons(f, v);
- break;
- }
- FL(p_level)--;
-}
-
-static void
-print_string(ios_t *f, const char *str, size_t sz)
-{- char buf[64];
- uint8_t c;
- static const char hexdig[] = "0123456789abcdef";
-
- size_t i = 0;
- if(!u8_isvalid(str, sz)){- // alternate print algorithm that preserves data if it's not UTF-8
- for(; i < sz; i++){- c = str[i];
- if(c == '\\')
- outsn(f, "\\\\", 2);
- else if(c == '"')
- outsn(f, "\\\"", 2);
- else if(c >= 32 && c < 0x7f)
- outc(f, c);
- else{- outsn(f, "\\x", 2);
- outc(f, hexdig[c>>4]);
- outc(f, hexdig[c&0xf]);
- }
- }
- }else{- while(i < sz){- size_t n = u8_escape(buf, sizeof(buf), str, &i, sz, true, false);
- outsn(f, buf, n-1);
- }
- }
-}
-
-static int
-double_exponent(double d)
-{- union ieee754_double dl;
-
- dl.d = d;
- return dl.ieee.exponent - IEEE754_DOUBLE_BIAS;
-}
-
-static void
-snprint_real(char *s, size_t cnt, double r,
- int width, // printf field width, or 0
- int dec, // # decimal digits desired, recommend 16
- // # of zeros in .00...0x before using scientific notation
- // recommend 3-4 or so
- int max_digs_rt,
- // # of digits left of decimal before scientific notation
- // recommend 10
- int max_digs_lf)
-{- bool keepz = false;
- int mag, sz;
-
- s[0] = '\0';
- if(width == -1){- width = 0;
- keepz = true;
- }
- if(isinf(r)){- strncpy(s, signbit(r) ? "-inf" : "inf", cnt);
- return;
- }
- if(isnan(r)){- strncpy(s, signbit(r) ? "-nan" : "nan", cnt);
- return;
- }
- if(r == 0){- strncpy(s, "0", cnt);
- return;
- }
-
- char num_format[4];
- num_format[0] = 'l';
- num_format[2] = '\0';
-
- mag = double_exponent(r);
- mag = (int)(((double)mag)/LOG2_10 + 0.5);
- if(r == 0)
- mag = 0;
- double fpart, temp;
- if(mag > max_digs_lf-1 || mag < -max_digs_rt){- num_format[1] = 'e';
- temp = r/pow(10, mag); /* see if number will have a decimal */
- fpart = temp - floor(temp); /* when written in scientific notation */
- }else{- num_format[1] = 'f';
- fpart = r - floor(r);
- }
- if(fpart == 0)
- dec = 0;
-
- char format[28];
- if(width == 0)
- snprintf(format, sizeof(format), "%%.%d%s", dec, num_format);
- else
- snprintf(format, sizeof(format), "%%%d.%d%s", width, dec, num_format);
-#pragma GCC diagnostic push
-#pragma GCC diagnostic ignored "-Wformat-nonliteral"
- sz = snprintf(s, cnt, format, r);
-#pragma GCC diagnostic pop
- /* trim trailing zeros from fractions. not when using scientific
- notation, since we might have e.g. 1.2000e+100. also not when we
- need a specific output width */
- if(width == 0 && !keepz){- if(sz > 2 && fpart){- char *e = nil;
- if(num_format[1] == 'e'){- while(s[--sz] != 'e');
- e = s + sz--;
- }
- while(s[sz-1] == '0'){- s[sz-1] = '\0';
- sz--;
- }
- // don't need trailing .
- if(s[sz-1] == '.')
- s[--sz] = '\0';
- if(num_format[1] == 'e'){- while(*e)
- s[sz++] = *e++;
- s[sz] = 0;
- }
- }
- }
-}
-
-// 'weak' means we don't need to accurately reproduce the type, so
-// for example #int32(0) can be printed as just 0. this is used
-// printing in a context where a type is already implied, e.g. inside
-// an array.
-static void
-cvalue_printdata(ios_t *f, void *data, size_t len, value_t type, int weak)
-{- if(type == FL_bytesym){- uint8_t ch = *(uint8_t*)data;
- if(FL(print_princ))
- outc(f, ch);
- else if(weak)
- FL(hpos) += ios_printf(f, "0x%hhx", ch);
- else
- FL(hpos) += ios_printf(f, "#byte(0x%hhx)", ch);
- }else if(type == FL_runesym){- Rune r = *(Rune*)data;
- char seq[UTFmax+1];
- int nb = runetochar(seq, &r);
- seq[nb] = '\0';
- if(FL(print_princ)){- outsn(f, seq, nb);
- }else{- outsn(f, "#\\", 2);
- switch(r){- case 0x00: outsn(f, "nul", 3); break;
- case 0x07: outsn(f, "alarm", 5); break;
- case 0x08: outsn(f, "backspace", 9); break;
- case 0x09: outsn(f, "tab", 3); break;
- case 0x0a: outsn(f, "newline", 7); break;
- case 0x0b: outsn(f, "vtab", 4); break;
- case 0x0c: outsn(f, "page", 4); break;
- case 0x0d: outsn(f, "return", 6); break;
- case 0x1b: outsn(f, "esc", 3); break;
- case ' ': outsn(f, "space", 5); break;
- case 0x7f: outsn(f, "delete", 6); break;
- default:
- if(u8_iswprint(r))
- outs(f, seq);
- else
- FL(hpos) += ios_printf(f, "x%04"PRIx32, r);
- break;
- }
- }
- }else if(type == FL_floatsym || type == FL_doublesym){- char buf[64];
- double d;
- int ndec;
- if(type == FL_floatsym){- d = (double)*(float*)data;
- ndec = 8;
- }else{- d = *(double*)data;
- ndec = 16;
- }
- if(!isfinite(d)){- const char *rep;
- if(isinf(d))
- rep = signbit(d) ? "-inf.0" : "+inf.0";
- else if(isnan(d))
- rep = signbit(d) ? "-nan.0" : "+nan.0";
- else
- rep = signbit(d) ? "-wtf.0" : "+wtf.0";
- if(type == FL_floatsym && !FL(print_princ) && !weak)
- FL(hpos) += ios_printf(f, "#%s(%s)", symbol_name(type), rep);
- else
- outs(f, rep);
- }else if(d == 0){- if(1/d < 0)
- outsn(f, "-0.0", 4);
- else
- outsn(f, "0.0", 3);
- if(type == FL_floatsym && !FL(print_princ) && !weak)
- outc(f, 'f');
- }else{- snprint_real(buf, sizeof(buf), d, 0, ndec, 3, 10);
- int hasdec = (strpbrk(buf, ".eE") != nil);
- outs(f, buf);
- if(!hasdec)
- outsn(f, ".0", 2);
- if(type == FL_floatsym && !FL(print_princ) && !weak)
- outc(f, 'f');
- }
- }else if(type == FL_uint64sym){- uint64_t ui64 = *(uint64_t*)data;
- if(weak || FL(print_princ))
- FL(hpos) += ios_printf(f, "%"PRIu64, ui64);
- else
- FL(hpos) += ios_printf(f, "#%s(%"PRIu64")", symbol_name(type), ui64);
- }else if(type == FL_bignumsym){- mpint *i = *(mpint**)data;
- char *s = mptoa(i, 10, nil, 0);
- FL(hpos) += ios_printf(f, "%s", s);
- MEM_FREE(s);
- }else if(issymbol(type)){- // handle other integer prims. we know it's smaller than uint64
- // at this point, so int64 is big enough to capture everything.
- numerictype_t nt = sym_to_numtype(type);
- if(valid_numtype(nt)){- int64_t i64 = conv_to_int64(data, nt);
- if(weak || FL(print_princ))
- FL(hpos) += ios_printf(f, "%"PRId64, i64);
- else
- FL(hpos) += ios_printf(f, "#%s(%"PRId64")", symbol_name(type), i64);
- }else{- FL(hpos) += ios_printf(f, "#<%s>", symbol_name(type));
- }
- }else if(iscons(type)){- if(car_(type) == FL_arraysym){- size_t i;
- value_t eltype = car(cdr_(type));
- size_t cnt, elsize;
- if(iscons(cdr_(cdr_(type)))){- cnt = tosize(car_(cdr_(cdr_(type))));
- elsize = cnt ? len/cnt : 0;
- }else{- // incomplete array type
- elsize = ctype_sizeof(eltype);
- cnt = elsize ? len/elsize : 0;
- }
- if(eltype == FL_bytesym){- if(FL(print_princ)){- ios_write(f, data, len);
- /*
- char *nl = llt_memrchr(data, '\n', len);
- if(nl)
- FL(hpos) = u8_strwidth(nl+1);
- else
- FL(hpos) += u8_strwidth(data);
- */
- }else{- outc(f, '"');
- print_string(f, (char*)data, len);
- outc(f, '"');
- }
- return;
- }else if(eltype == FL_runesym){- char buf[UTFmax+1];
- if(!FL(print_princ))
- outc(f, '"');
- for(i = 0; i < cnt; i++, data = (char*)data + elsize){- int n = runetochar(buf, (Rune*)data);
- buf[n] = 0;
- if(FL(print_princ))
- ios_write(f, buf, n);
- else
- print_string(f, buf, n);
- }
- if(!FL(print_princ))
- outc(f, '"');
- return;
- }
- if(!weak){- if(eltype == FL_uint8sym){- outsn(f, "#vu8(", 5);- }else{- outsn(f, "#array(", 7);- fl_print_child(f, eltype);
- if(cnt > 0)
- outc(f, ' ');
- }
- }else{- outs(f, "#(");- }
- for(i = 0; i < cnt; i++){- if(i > 0)
- outc(f, ' ');
- cvalue_printdata(f, data, elsize, eltype, 1);
- data = (char*)data + elsize;
- }
- outc(f, ')');
- }
- }
-}
-
-static void
-cvalue_print(ios_t *f, value_t v)
-{- cvalue_t *cv = ptr(v);
- void *data = cptr(v);
- value_t label;
-
- if(cv_class(cv) == FL(builtintype)){- void *fptr = *(void**)data;
- label = (value_t)ptrhash_get(&FL(reverse_dlsym_lookup_table), cv);
- if(label == (value_t)HT_NOTFOUND){- FL(hpos) += ios_printf(f, "#<builtin @%p>", fptr);
- }else{- if(FL(print_princ)){- outs(f, symbol_name(label));
- }else{- outsn(f, "#fn(", 4);- outs(f, symbol_name(label));
- outc(f, ')');
- }
- }
- }else if(cv_class(cv)->vtable != nil && cv_class(cv)->vtable->print != nil){- cv_class(cv)->vtable->print(v, f);
- }else{- value_t type = cv_type(cv);
- size_t len = iscprim(v) ? cv_class(cv)->size : cv_len(cv);
- cvalue_printdata(f, data, len, type, 0);
- }
-}
-
-static void
-set_print_width(void)
-{- value_t pw = symbol_value(FL_printwidthsym);
- if(!isfixnum(pw))
- return;
- FL(scr_width) = numval(pw);
-}
-
-void
-fl_print(ios_t *f, value_t v)
-{- FL(print_pretty) = symbol_value(FL_printprettysym) != FL_f;
- if(FL(print_pretty))
- set_print_width();
- FL(print_princ) = symbol_value(FL_printreadablysym) == FL_f;
- value_t pl = symbol_value(FL_printlengthsym);
- FL(print_length) = isfixnum(pl) ? numval(pl) : -1;
- pl = symbol_value(FL_printlevelsym);
- FL(print_level) = isfixnum(pl) ? numval(pl) : -1;
- FL(p_level) = 0;
-
- FL(printlabel) = 0;
- if(!FL(print_princ))
- print_traverse(v);
- FL(hpos) = FL(vpos) = 0;
-
- fl_print_child(f, v);
-
- if(FL(print_level) >= 0 || FL(print_length) >= 0)
- memset(FL(consflags), 0, 4*bitvector_nwords(FL(heapsize)/sizeof(cons_t)));
-
- if((iscons(v) || isvector(v) || isfunction(v) || iscvalue(v)) &&
- !fl_isstring(v) && v != FL_t && v != FL_f && v != FL_nil && v != FL_void)
- htable_reset(&FL(printconses), 32);
-}
--- a/print.h
+++ /dev/null
@@ -1,7 +1,0 @@
-#pragma once
-
-void fl_print(ios_t *f, value_t v);
-void print_traverse(value_t v);
-void fl_print_chr(ios_t *f, char c);
-void fl_print_str(ios_t *f, const char *s);
-void fl_print_child(ios_t *f, value_t v);
--- a/ptrhash.c
+++ /dev/null
@@ -1,39 +1,0 @@
-/*
- pointer hash table
- optimized for storing info about particular values
-*/
-
-#include "flisp.h"
-
-#if defined(BITS64)
-static uint64_t
-_pinthash(uint64_t key)
-{- key = (~key) + (key << 21); // key = (key << 21) - key - 1;
- key = key ^ (key >> 24);
- key = (key + (key << 3)) + (key << 8); // key * 265
- key = key ^ (key >> 14);
- key = (key + (key << 2)) + (key << 4); // key * 21
- key = key ^ (key >> 28);
- key = key + (key << 31);
- return key;
-}
-#else
-static uint32_t
-_pinthash(uint32_t a)
-{- a = (a+0x7ed55d16) + (a<<12);
- a = (a^0xc761c23c) ^ (a>>19);
- a = (a+0x165667b1) + (a<<5);
- a = (a+0xd3a2646c) ^ (a<<9);
- a = (a+0xfd7046c5) + (a<<3);
- a = (a^0xb55a4f09) ^ (a>>16);
- return a;
-}
-#endif
-
-#define HTNAME(suffix) ptrhash##suffix
-#define HFUNC(v) _pinthash((value_t)(v))
-#define EQFUNC(x, y) ((x) == (y))
-
-#include "htable.inc"
--- a/random.c
+++ /dev/null
@@ -1,31 +1,0 @@
-#include "flisp.h"
-#include "mt19937-64.h"
-#include "timefuncs.h"
-#include "random.h"
-
-static mt19937_64 ctx;
-
-uint64_t
-genrand_uint64(void)
-{- return genrand64_int64(&ctx);
-}
-
-uint32_t
-genrand_uint32(void)
-{- return genrand64_int64(&ctx) >> 32;
-}
-
-double
-genrand_double(void)
-{- return genrand64_real1(&ctx);
-}
-
-void
-randomize(void)
-{- unsigned long long tm = sec_realtime() * 1000.0;
- init_by_array64(&ctx, &tm, 1);
-}
--- a/random.h
+++ /dev/null
@@ -1,6 +1,0 @@
-#pragma once
-
-void randomize(void);
-double genrand_double(void);
-uint64_t genrand_uint64(void);
-uint32_t genrand_uint32(void);
--- a/read.c
+++ /dev/null
@@ -1,737 +1,0 @@
-#include "flisp.h"
-#include "cvalues.h"
-#include "read.h"
-#include "nan.h"
-
-enum {- TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM,
- TOK_BQ, TOK_COMMA, TOK_COMMAAT, TOK_COMMADOT,
- TOK_SHARPDOT, TOK_LABEL, TOK_BACKREF, TOK_SHARPQUOTE, TOK_SHARPOPEN,
- TOK_OPENB, TOK_CLOSEB, TOK_SHARPSYM, TOK_GENSYM, TOK_DOUBLEQUOTE,
- TOK_OPENC, TOK_CLOSEC,
-};
-
-#define PAtLoc "at %"PRIu32":%"PRIu32
-
-typedef struct Rctx Rctx;
-
-struct Rctx {- uint32_t toktype;
- value_t tokval;
- ios_loc_t loc;
- char buf[1024];
-};
-
-static value_t do_read_sexpr(Rctx *ctx, value_t label);
-
-#define RS value2c(ios_t*, FL(readstate)->source)
-
-bool
-fl_read_numtok(const char *tok, value_t *pval, int base)
-{- char *end;
- int64_t i64;
- double d;
-
- if(*tok == '\0')
- return false;
- if(!((tok[0] == '0' && tok[1] == 'x') || (base >= 15)) && strpbrk(tok, ".eEpP")){- d = strtod(tok, &end);
- if(*end == '\0'){- if(pval)
- *pval = mk_double(d);
- return true;
- }
- // floats can end in f or f0
- if(end > tok && end[0] == 'f' &&
- (end[1] == '\0' ||
- (end[1] == '0' && end[2] == '\0'))){- if(pval)
- *pval = mk_float((float)d);
- return true;
- }
- }
-
- if(tok[0] == '+'){- if(!strcmp(tok, "+NaN") || !strcasecmp(tok, "+nan.0")){- if(pval)
- *pval = mk_double(D_PNAN);
- return true;
- }
- if(!strcmp(tok, "+Inf") || !strcasecmp(tok, "+inf.0")){- if(pval)
- *pval = mk_double(D_PINF);
- return true;
- }
- }else if(tok[0] == '-'){- if(!strcmp(tok, "-NaN") || !strcasecmp(tok, "-nan.0")){- if(pval)
- *pval = mk_double(D_NNAN);
- return true;
- }
- if(!strcmp(tok, "-Inf") || !strcasecmp(tok, "-inf.0")){- if(pval)
- *pval = mk_double(D_NINF);
- return true;
- }
- }
- i64 = strtoll(tok, &end, base);
- if(*end != '\0')
- return false;
- if(pval != nil){- mpint *m;
- if(fits_fixnum(i64))
- *pval = fixnum(i64);
- else if((m = strtomp(tok, &end, base, nil)) != nil)
- *pval = mk_mpint(m);
- else
- return false;
- }
- return true;
-}
-
-static char
-nextchar(void)
-{- int ch;
- char c;
- ios_t *f = RS;
-
- do{- ch = ios_getc(RS);
- if(ch == IOS_EOF)
- return 0;
- c = (char)ch;
- if(c == ';'){- // single-line comment
- do{- ch = ios_getc(f);
- if(ch == IOS_EOF)
- return 0;
- }while((char)ch != '\n');
- c = (char)ch;
- }
- }while(c == ' ' || isspace(c));
- return c;
-}
-
-static void
-take(Rctx *ctx)
-{- ctx->toktype = TOK_NONE;
-}
-
-static _Noreturn void fl_printfmt(2, 3)
-parse_error(ios_loc_t *loc, const char *format, ...)
-{- char msgbuf[512];
- va_list args;
- int n;
-
- n = snprintf(msgbuf, sizeof(msgbuf), "%s:%"PRIu64":%"PRIu64": ",
- loc->filename, (uint64_t)loc->lineno, (uint64_t)loc->colno);
- if(n >= (int)sizeof(msgbuf))
- n = 0;
- va_start(args, format);
- vsnprintf(msgbuf+n, sizeof(msgbuf)-n, format, args);
- value_t msg = string_from_cstr(msgbuf);
- va_end(args);
-
- fl_raise(fl_list2(FL_ParseError, msg));
-}
-
-static void
-accumchar(Rctx *ctx, char c, int *pi)
-{- ctx->buf[(*pi)++] = c;
- if(*pi >= (int)(sizeof(ctx->buf)-1))
- parse_error(&ctx->loc, "token too long");
-}
-
-// return: 1 if escaped (forced to be symbol)
-static bool
-read_token(Rctx *ctx, char c, bool digits)
-{- int i = 0, ch, nc = 0;
- bool escaped = false, issym = false;
-
- while(1){- if(nc != 0){- if(nc != 1)
- ios_getc(RS);
- ch = ios_peekc(RS);
- if(ch == IOS_EOF)
- goto terminate;
- c = (char)ch;
- }
- if(c == '|'){- issym = true;
- escaped = !escaped;
- }else if(c == '\\'){- issym = true;
- ios_getc(RS);
- ch = ios_peekc(RS);
- if(ch == IOS_EOF)
- goto terminate;
- accumchar(ctx, (char)ch, &i);
- }else if(!escaped && !(symchar(c) && (!digits || isdigit(c)))){- break;
- }else{- accumchar(ctx, c, &i);
- }
- nc++;
- }
- if(nc == 0)
- ios_skip(RS, -1);
-terminate:
- ctx->buf[i++] = '\0';
- return issym;
-}
-
-static int
-isdigit_base(char c, int base)
-{- if(base < 11)
- return c >= '0' && c < '0'+base;
- return (c >= '0' && c <= '9') || (c >= 'a' && c < 'a'+base-10) || (c >= 'A' && c < 'A'+base-10);
-}
-
-static uint32_t
-peek(Rctx *ctx)
-{- char c, *end;
- fixnum_t x;
- int ch, base;
-
- if(ctx->toktype != TOK_NONE)
- return ctx->toktype;
- c = nextchar();
- ctx->loc = RS->loc;
- if(ios_eof(RS))
- return TOK_NONE;
- if(c == '(')- ctx->toktype = TOK_OPEN;
- else if(c == ')')
- ctx->toktype = TOK_CLOSE;
- else if(c == '[')
- ctx->toktype = TOK_OPENB;
- else if(c == ']')
- ctx->toktype = TOK_CLOSEB;
- else if(c == '{')- ctx->toktype = TOK_OPENC;
- else if(c == '}')
- ctx->toktype = TOK_CLOSEC;
- else if(c == '\'')
- ctx->toktype = TOK_QUOTE;
- else if(c == '`')
- ctx->toktype = TOK_BQ;
- else if(c == '"')
- ctx->toktype = TOK_DOUBLEQUOTE;
- else if(c == '#'){- ch = ios_getc(RS); c = (char)ch;
- if(ch == IOS_EOF)
- parse_error(&ctx->loc, "invalid read macro");
- if(c == '.')
- ctx->toktype = TOK_SHARPDOT;
- else if(c == '\'')
- ctx->toktype = TOK_SHARPQUOTE;
- else if(c == '\\'){- Rune cval;
- if(ios_getutf8(RS, &cval) == IOS_EOF)
- parse_error(&ctx->loc, "end of input in character constant");
- if(cval == 'u' || cval == 'U' || cval == 'x'){- read_token(ctx, 'u', 0);
- if(ctx->buf[1] != '\0'){ // not a solitary 'u','U','x'- if(!fl_read_numtok(&ctx->buf[1], &ctx->tokval, 16))
- parse_error(&ctx->loc, "invalid hex character constant");
- cval = numval(ctx->tokval);
- }
- }else if(cval >= 'a' && cval <= 'z'){- read_token(ctx, (char)cval, 0);
- ctx->tokval = symbol(ctx->buf, true);
- if(ctx->buf[1] == '\0') USED(cval); /* one character */
- else if(ctx->tokval == FL_nulsym) cval = 0x00;
- else if(ctx->tokval == FL_alarmsym) cval = 0x07;
- else if(ctx->tokval == FL_backspacesym) cval = 0x08;
- else if(ctx->tokval == FL_tabsym) cval = 0x09;
- else if(ctx->tokval == FL_linefeedsym) cval = 0x0A;
- else if(ctx->tokval == FL_newlinesym) cval = 0x0A;
- else if(ctx->tokval == FL_vtabsym) cval = 0x0B;
- else if(ctx->tokval == FL_pagesym) cval = 0x0C;
- else if(ctx->tokval == FL_returnsym) cval = 0x0D;
- else if(ctx->tokval == FL_escsym) cval = 0x1B;
- else if(ctx->tokval == FL_spacesym) cval = 0x20;
- else if(ctx->tokval == FL_deletesym) cval = 0x7F;
- else
- parse_error(&ctx->loc, "unknown character #\\%s", ctx->buf);
- }
- ctx->toktype = TOK_NUM;
- ctx->tokval = mk_rune(cval);
- }else if(c == '('){- ctx->toktype = TOK_SHARPOPEN;
- }else if(c == '<'){- parse_error(&ctx->loc, "unreadable object");
- }else if(isdigit(c)){- read_token(ctx, c, 1);
- c = (char)ios_getc(RS);
- if(c == '#')
- ctx->toktype = TOK_BACKREF;
- else if(c == '=')
- ctx->toktype = TOK_LABEL;
- else
- parse_error(&ctx->loc, "invalid label");
- x = strtoll(ctx->buf, &end, 10);
- if(*end != '\0')
- parse_error(&ctx->loc, "invalid label");
- ctx->tokval = fixnum(x);
- }else if(c == '!'){- // #! single line comment for shbang script support
- do{- ch = ios_getc(RS);
- }while(ch != IOS_EOF && (char)ch != '\n');
- return peek(ctx);
- }else if(c == '|'){- // multiline comment
- int commentlevel = 1;
- while(1){- ch = ios_getc(RS);
- hashpipe_gotc:
- if(ch == IOS_EOF)
- parse_error(&ctx->loc, "eof within comment");
- if((char)ch == '|'){- ch = ios_getc(RS);
- if((char)ch == '#'){- commentlevel--;
- if(commentlevel == 0)
- break;
- else
- continue;
- }
- goto hashpipe_gotc;
- }else if((char)ch == '#'){- ch = ios_getc(RS);
- if((char)ch == '|')
- commentlevel++;
- else
- goto hashpipe_gotc;
- }
- }
- // this was whitespace, so keep peeking
- return peek(ctx);
- }else if(c == ';'){- // datum comment
- (void)do_read_sexpr(ctx, UNBOUND); // skip
- return peek(ctx);
- }else if(c == ':'){- // gensym
- ch = ios_getc(RS);
- if((char)ch == 'g')
- ch = ios_getc(RS);
- read_token(ctx, (char)ch, 0);
- x = strtol(ctx->buf, &end, 10);
- if(*end != '\0' || ctx->buf[0] == '\0')
- parse_error(&ctx->loc, "invalid gensym label");
- ctx->toktype = TOK_GENSYM;
- ctx->tokval = fixnum(x);
- }else if(symchar(c)){- read_token(ctx, ch, 0);
-
- if(((c == 'b' && (base = 2)) ||
- (c == 'o' && (base = 8)) ||
- (c == 'd' && (base = 10)) ||
- (c == 'x' && (base = 16))) && (isdigit_base(ctx->buf[1], base) || ctx->buf[1] == '-')){- if(!fl_read_numtok(&ctx->buf[1], &ctx->tokval, base))
- parse_error(&ctx->loc, "invalid base %d constant", base);
- return (ctx->toktype = TOK_NUM);
- }
-
- ctx->toktype = TOK_SHARPSYM;
- ctx->tokval = symbol(ctx->buf, true);
- }else{- parse_error(&ctx->loc, "unknown read macro");
- }
- }else if(c == ','){- ctx->toktype = TOK_COMMA;
- ch = ios_peekc(RS);
- if(ch == IOS_EOF)
- return ctx->toktype;
- if((char)ch == '@')
- ctx->toktype = TOK_COMMAAT;
- else if((char)ch == '.')
- ctx->toktype = TOK_COMMADOT;
- else
- return ctx->toktype;
- ios_getc(RS);
- }else{- if(!read_token(ctx, c, 0)){- if(ctx->buf[0] == '.' && ctx->buf[1] == '\0')
- return (ctx->toktype = TOK_DOT);
- if(fl_read_numtok(ctx->buf, &ctx->tokval, 0))
- return (ctx->toktype = TOK_NUM);
- }
- ctx->toktype = TOK_SYM;
- const char *name = (strcmp(ctx->buf, "lambda") == 0 || strcmp(ctx->buf, "λ") == 0) ? "λ" : ctx->buf;
- ctx->tokval = strcasecmp(name, "nil") == 0 ? FL_nil : symbol(name, name == ctx->buf);
- }
- return ctx->toktype;
-}
-
-// NOTE: this is NOT an efficient operation. it is only used by the
-// reader, and requires at least 1 and up to 3 garbage collections!
-static value_t
-vector_grow(value_t v, bool rewrite_refs)
-{- size_t i, s = vector_size(v);
- size_t d = vector_grow_amt(s);
- PUSHSAFE(v);
- assert(s+d > s);
- value_t newv = alloc_vector(s+d, 1);
- v = FL(stack)[FL(sp)-1];
- for(i = 0; i < s; i++)
- vector_elt(newv, i) = vector_elt(v, i);
- // use gc to rewrite references from the old vector to the new
- FL(stack)[FL(sp)-1] = newv;
- if(s > 0 && rewrite_refs){- ((size_t*)ptr(v))[0] |= 0x1;
- vector_elt(v, 0) = newv;
- fl_gc(0);
- }
- return POP();
-}
-
-static value_t
-read_vector(Rctx *ctx, value_t label, uint32_t closer)
-{- value_t v = FL(the_empty_vector), elt;
- uint32_t i = 0;
- PUSHSAFE(v);
- if(label != UNBOUND)
- ptrhash_put(&FL(readstate)->backrefs, (void*)label, (void*)v);
- while(peek(ctx) != closer){- if(ios_eof(RS))
- parse_error(&ctx->loc, "unexpected end of input");
- v = FL(stack)[FL(sp)-1]; // reload after possible alloc in peek()
- if(i >= vector_size(v)){- v = FL(stack)[FL(sp)-1] = vector_grow(v, label != UNBOUND);
- if(label != UNBOUND)
- ptrhash_put(&FL(readstate)->backrefs, (void*)label, (void*)v);
- }
- elt = do_read_sexpr(ctx, UNBOUND);
- v = FL(stack)[FL(sp)-1];
- assert(i < vector_size(v));
- vector_elt(v, i) = elt;
- i++;
- }
- take(ctx);
- if(i > 0)
- vector_setsize(v, i);
- return POP();
-}
-
-static value_t
-read_string(Rctx *ctx)
-{- char *buf, *temp;
- char eseq[10];
- size_t i = 0, j, sz, ndig;
- int c;
- value_t s;
- Rune r = 0;
-
- sz = sizeof(ctx->buf);
- buf = ctx->buf;
- while(1){- if(i >= sz-UTFmax){ // -UTFmax: leaves room for longest utf8 sequence- sz *= 2;
- if(buf == ctx->buf){- if((temp = MEM_ALLOC(sz)) != nil)
- memcpy(temp, ctx->buf, i);
- }else
- temp = MEM_REALLOC(buf, sz);
- if(temp == nil){- if(buf == ctx->buf)
- MEM_FREE(buf);
- parse_error(&ctx->loc, "out of memory reading string");
- }
- buf = temp;
- }
- c = ios_getc(RS);
- if(c == IOS_EOF){- if(buf != ctx->buf)
- MEM_FREE(buf);
- parse_error(&ctx->loc, "unexpected end of input in string");
- }
- if(c == '"')
- break;
- else if(c == '\\'){- c = ios_getc(RS);
- if(c == IOS_EOF){- if(buf != ctx->buf)
- MEM_FREE(buf);
- parse_error(&ctx->loc, "end of input in escape sequence");
- }
- j = 0;
- if(octal_digit(c)){- while(1){- eseq[j++] = c;
- c = ios_peekc(RS);
- if(c == IOS_EOF || !octal_digit(c) || j >= 3)
- break;
- ios_getc(RS);
- }
- eseq[j] = '\0';
- r = strtol(eseq, nil, 8);
- // \DDD and \xXX read bytes, not characters
- buf[i++] = (char)r;
- }else if((c == 'x' && (ndig = 2)) || (c == 'u' && (ndig = 4)) || (c == 'U' && (ndig = 8))){- while(1){- c = ios_peekc(RS);
- if(c == IOS_EOF || !hex_digit(c) || j >= ndig)
- break;
- eseq[j++] = c;
- ios_getc(RS);
- }
- eseq[j] = '\0';
- if(j)
- r = strtol(eseq, nil, 16);
- if(!j || r > Runemax){- if(buf != ctx->buf)
- MEM_FREE(buf);
- parse_error(&ctx->loc, "invalid escape sequence");
- }
- if(ndig == 2)
- buf[i++] = (char)r;
- else
- i += runetochar(&buf[i], &r);
- }else if(c == '\n'){- /* do nothing */
- }else{- char esc = read_escape_control_char((char)c);
- if(esc == (char)c && !strchr("\\'\"`", esc)){- if(buf != ctx->buf)
- MEM_FREE(buf);
- ios_loc_t *l = &RS->loc;
- parse_error(
- &ctx->loc,
- "invalid escape sequence \\%c "PAtLoc,
- (char)c,
- l->lineno,
- l->colno
- );
- }
- buf[i++] = esc;
- }
- }else{- buf[i++] = c;
- }
- }
- s = cvalue_string(i);
- memcpy(cvalue_data(s), buf, i);
- if(buf != ctx->buf)
- MEM_FREE(buf);
- return s;
-}
-
-// build a list of conses. this is complicated by the fact that all conses
-// can move whenever a new cons is allocated. we have to refer to every cons
-// through a handle to a relocatable pointer (i.e. a pointer on the stack).
-static void
-read_list(Rctx *ctx, value_t label, uint32_t closer)
-{- value_t c, *pc, *pval;
- uint32_t t, ipval, ipc;
- ios_loc_t loc0;
-
- loc0 = RS->loc;
- loc0.colno--;
- ipval = FL(sp)-1;
- PUSHSAFE(FL_nil);
- ipc = FL(sp)-1; // to keep track of current cons cell
- t = peek(ctx);
- while(t != closer){- if(ios_eof(RS))
- parse_error(&loc0, "not closed: unexpected EOI "PAtLoc, ctx->loc.lineno, ctx->loc.colno);
- c = mk_cons(); car_(c) = cdr_(c) = FL_nil;
- pc = &FL(stack)[ipc];
- if(iscons(*pc))
- cdr_(*pc) = c;
- else{- pval = &FL(stack)[ipval];
- *pval = c;
- if(label != UNBOUND)
- ptrhash_put(&FL(readstate)->backrefs, (void*)label, (void*)c);
- }
- *pc = c;
- c = do_read_sexpr(ctx, UNBOUND);
- pc = &FL(stack)[ipc];
- car_(*pc) = c;
-
- t = peek(ctx);
- if(t == TOK_DOT){- take(ctx);
- c = do_read_sexpr(ctx, UNBOUND);
- pc = &FL(stack)[ipc];
- cdr_(*pc) = c;
- t = peek(ctx);
- if(ios_eof(RS))
- parse_error(&ctx->loc, "unexpected end of input");
- if(t != closer){- take(ctx);
- parse_error(
- &ctx->loc,
- "expected '%c'",
- closer == TOK_CLOSEB ? ']' : (closer == TOK_CLOSEC ? '}' : ')')
- );
- }
- }
- }
- take(ctx);
- c = POP();
- USED(c);
-}
-
-// label is the backreference we'd like to fix up with this read
-static value_t
-do_read_sexpr(Rctx *ctx, value_t label)
-{- value_t v, sym, oldtokval, *head;
- value_t *pv;
- uint32_t t;
- char c;
-
- t = peek(ctx);
- take(ctx);
- switch(t){- case TOK_OPEN:
- PUSHSAFE(FL_nil);
- read_list(ctx, label, TOK_CLOSE);
- return POP();
- case TOK_SYM:
- case TOK_NUM:
- return ctx->tokval;
- case TOK_OPENB:
- PUSHSAFE(FL_nil);
- read_list(ctx, label, TOK_CLOSEB);
- return POP();
- case TOK_OPENC:
- PUSHSAFE(FL_nil);
- read_list(ctx, label, TOK_CLOSEC);
- return POP();
- case TOK_COMMA:
- head = &FL_comma; goto listwith;
- case TOK_COMMAAT:
- head = &FL_commaat; goto listwith;
- case TOK_COMMADOT:
- head = &FL_commadot; goto listwith;
- case TOK_BQ:
- head = &FL_backquote; goto listwith;
- case TOK_QUOTE:
- head = &FL_quote;
- listwith:
- v = cons_reserve(2);
- car_(v) = *head;
- cdr_(v) = tagptr((cons_t*)ptr(v)+1, TAG_CONS);
- car_(cdr_(v)) = cdr_(cdr_(v)) = FL_nil;
- PUSHSAFE(v);
- if(label != UNBOUND)
- ptrhash_put(&FL(readstate)->backrefs, (void*)label, (void*)v);
- v = do_read_sexpr(ctx, UNBOUND);
- car_(cdr_(FL(stack)[FL(sp)-1])) = v;
- return POP();
- case TOK_SHARPQUOTE:
- // femtoLisp doesn't need symbol-function, so #' does nothing
- return do_read_sexpr(ctx, label);
- case TOK_SHARPSYM:
- sym = ctx->tokval;
- if(sym == FL_tsym || sym == FL_Tsym)
- return FL_t;
- if(sym == FL_fsym || sym == FL_Fsym)
- return FL_f;
- // constructor notation
- c = nextchar();
- ctx->loc = RS->loc;
- if(c != '('){- take(ctx);
- parse_error(&ctx->loc, "expected argument list for %s", symbol_name(ctx->tokval));
- }
- PUSHSAFE(FL_nil);
- read_list(ctx, UNBOUND, TOK_CLOSE);
- if(sym == FL_vu8sym){- sym = FL_arraysym;
- FL(stack)[FL(sp)-1] = fl_cons(FL_uint8sym, FL(stack)[FL(sp)-1]);
- }else if(sym == FL_fnsym){- sym = FL_function;
- }
- v = symbol_value(sym);
- if(v == UNBOUND)
- unbound_error(sym);
- return fl_apply(v, POP());
- case TOK_SHARPOPEN:
- return read_vector(ctx, label, TOK_CLOSE);
- case TOK_SHARPDOT:
- // eval-when-read
- // evaluated expressions can refer to existing backreferences, but they
- // cannot see pending labels. in other words:
- // (... #2=#.#0# ... ) OK
- // (... #2=#.(#2#) ... ) DO NOT WANT
- sym = do_read_sexpr(ctx, UNBOUND);
- if(issymbol(sym)){- v = symbol_value(sym);
- if(v == UNBOUND)
- unbound_error(sym);
- return v;
- }
- return fl_toplevel_eval(sym);
- case TOK_LABEL:
- // create backreference label
- if(ptrhash_has(&FL(readstate)->backrefs, (void*)ctx->tokval))
- parse_error(&ctx->loc, "label %"PRIdPTR" redefined", (intptr_t)numval(ctx->tokval));
- oldtokval = ctx->tokval;
- v = do_read_sexpr(ctx, ctx->tokval);
- ptrhash_put(&FL(readstate)->backrefs, (void*)oldtokval, (void*)v);
- return v;
- case TOK_BACKREF:
- // look up backreference
- v = (value_t)ptrhash_get(&FL(readstate)->backrefs, (void*)ctx->tokval);
- if(v == (value_t)HT_NOTFOUND)
- parse_error(&ctx->loc, "undefined label %"PRIdPTR, (intptr_t)numval(ctx->tokval));
- return v;
- case TOK_GENSYM:
- pv = (value_t*)ptrhash_bp(&FL(readstate)->gensyms, (void*)ctx->tokval);
- if(*pv == (value_t)HT_NOTFOUND)
- *pv = gensym();
- return *pv;
- case TOK_DOUBLEQUOTE:
- return read_string(ctx);
- case TOK_CLOSE:
- parse_error(&ctx->loc, "unexpected ')'");
- case TOK_CLOSEB:
- parse_error(&ctx->loc, "unexpected ']'");
- case TOK_CLOSEC:
- parse_error(&ctx->loc, "unexpected '}'");
- case TOK_DOT:
- parse_error(&ctx->loc, "unexpected '.'");
- }
- return FL_void;
-}
-
-value_t
-fl_read_sexpr(value_t f)
-{- fl_readstate_t state;
- state.prev = FL(readstate);
- htable_new(&state.backrefs, 8);
- htable_new(&state.gensyms, 8);
- state.source = f;
- FL(readstate) = &state;
- Rctx ctx;
- ctx.toktype = TOK_NONE;
- fl_gc_handle(&ctx.tokval);
-
- value_t v = do_read_sexpr(&ctx, UNBOUND);
-
- fl_free_gc_handles(1);
- FL(readstate) = state.prev;
- free_readstate(&state);
- return v;
-}
--- a/read.h
+++ /dev/null
@@ -1,10 +1,0 @@
-#pragma once
-
-value_t fl_read_sexpr(value_t f);
-bool fl_read_numtok(const char *tok, value_t *pval, int base);
-
-// defines which characters are ordinary symbol characters.
-// exceptions are '.', which is an ordinary symbol character
-// unless it's the only character in the symbol, and '#', which is
-// an ordinary symbol character unless it's the first character.
-#define symchar(c) (!strchr("()[]{}'\";`,\\| \a\b\f\n\r\t\v", (c)))--- /dev/null
+++ b/src/bitvector.c
@@ -1,0 +1,16 @@
+#include "flisp.h"
+
+uint32_t *
+bitvector_resize(uint32_t *b, uint64_t oldsz, uint64_t newsz, int initzero)
+{+ uint32_t *p;
+ size_t sz = ((newsz+31)>>5) * sizeof(uint32_t);
+ p = MEM_REALLOC(b, sz);
+ if(p == nil)
+ return nil;
+ if(initzero && newsz>oldsz){+ size_t osz = ((oldsz+31)>>5) * sizeof(uint32_t);
+ memset(&p[osz/sizeof(uint32_t)], 0, sz-osz);
+ }
+ return p;
+}
--- /dev/null
+++ b/src/bitvector.h
@@ -1,0 +1,11 @@
+uint32_t *bitvector_resize(uint32_t *b, uint64_t oldsz, uint64_t newsz, int initzero);
+
+#define bitvector_new(n, initzero) bitvector_resize(nil, 0, (n), (initzero))
+#define bitvector_nwords(nbits) (((uint64_t)(nbits)+31)>>5)
+#define bitvector_get(b, n) (b[(n)>>5] & (1U<<((n)&31)))
+#define bitvector_set(b, n) do{ \+ b[(n)>>5] |= 1U<<((n)&31); \
+ }while(0)
+#define bitvector_reset(b, n) do{ \+ b[(n)>>5] &= ~(1U<<((n)&31)); \
+ }while(0)
--- /dev/null
+++ b/src/builtins.c
@@ -1,0 +1,508 @@
+/*
+ Extra femtoLisp builtin functions
+*/
+
+#include "flisp.h"
+#include "operators.h"
+#include "cvalues.h"
+#include "timefuncs.h"
+#include "table.h"
+#include "random.h"
+#include "nan.h"
+
+#define DBL_MAXINT (1LL<<53)
+#define FLT_MAXINT (1<<24)
+
+size_t
+llength(value_t v)
+{+ size_t n = 0;
+ while(iscons(v)){+ n++;
+ v = cdr_(v);
+ }
+ return n;
+}
+
+BUILTIN("nconc", nconc)+{+ if(nargs == 0)
+ return FL_nil;
+
+ value_t lst, first = FL_nil;
+ value_t *pcdr = &first;
+ cons_t *c;
+ uint32_t i = 0;
+
+ while(1){+ lst = args[i++];
+ if(i >= nargs)
+ break;
+ if(iscons(lst)){+ *pcdr = lst;
+ c = ptr(lst);
+ while(iscons(c->cdr))
+ c = ptr(c->cdr);
+ pcdr = &c->cdr;
+ }else if(lst != FL_nil)
+ type_error("cons", lst);+ }
+ *pcdr = lst;
+ return first;
+}
+
+fl_purefn
+BUILTIN("assq", assq)+{+ argcount(nargs, 2);
+
+ value_t item = args[0];
+ value_t v = args[1];
+ value_t bind;
+
+ while(iscons(v)){+ bind = car_(v);
+ if(iscons(bind) && car_(bind) == item)
+ return bind;
+ v = cdr_(v);
+ }
+ return FL_f;
+}
+
+fl_purefn
+BUILTIN("memq", memq)+{+ argcount(nargs, 2);
+
+ value_t v;
+ cons_t *c;
+ for(v = args[1]; iscons(v); v = c->cdr){+ if((c = ptr(v))->car == args[0])
+ return v;
+ }
+ return FL_f;
+}
+
+BUILTIN("length", length)+{+ argcount(nargs, 1);
+
+ value_t a = args[0];
+ cvalue_t *cv;
+
+ if(iscons(a)){+ size_t n = 0;
+ value_t v = a, v2 = a;
+ do{+ n++;
+ v = cdr_(v);
+ v2 = cdr_(v2);
+ if(iscons(v2))
+ v2 = cdr_(v2);
+ }while(iscons(v) && iscons(v2) && v != v2);
+ if(iscons(v2))
+ return mk_double(D_PINF);
+ n += llength(v);
+ return size_wrap(n);
+ }
+ if(iscprim(a)){+ cv = ptr(a);
+ if(cp_class(cv) == FL(bytetype))
+ return fixnum(1);
+ if(cp_class(cv) == FL(runetype))
+ return fixnum(runelen(*(Rune*)cp_data(cv)));
+ }
+ if(iscvalue(a) && cv_class(ptr(a))->eltype != nil)
+ return size_wrap(cvalue_arraylen(a));
+ if(isvector(a))
+ return size_wrap(vector_size(a));
+ if(ishashtable(a)){+ htable_t *h = totable(a);
+ void **t = h->table;
+ size_t sz = h->size;
+ size_t n = 0;
+ for(size_t i = 0; i < sz; i += 2){+ if(t[i+1] != HT_NOTFOUND)
+ n++;
+ }
+ return size_wrap(n);
+ }
+ if(a == FL_nil)
+ return fixnum(0);
+ type_error("sequence", a);+}
+
+_Noreturn
+BUILTIN("raise", raise)+{+ argcount(nargs, 1);
+ fl_raise(args[0]);
+}
+
+_Noreturn
+BUILTIN("exit", exit)+{+ if(nargs > 1)
+ argcount(nargs, 1);
+ fl_exit(nargs > 0 ? tofixnum(args[0]) : 0);
+}
+
+BUILTIN("symbol", symbol)+{+ argcount(nargs, 1);
+ if(fl_unlikely(!fl_isstring(args[0])))
+ type_error("string", args[0]);+ return symbol(cvalue_data(args[0]), true);
+}
+
+fl_purefn
+BUILTIN("keyword?", keywordp)+{+ argcount(nargs, 1);
+ return (issymbol(args[0]) && iskeyword((symbol_t*)ptr(args[0]))) ? FL_t : FL_f;
+}
+
+fl_purefn
+BUILTIN("top-level-value", top_level_value)+{+ argcount(nargs, 1);
+ symbol_t *sym = tosymbol(args[0]);
+ if(sym->binding == UNBOUND)
+ unbound_error(args[0]);
+ return sym->binding;
+}
+
+BUILTIN("set-top-level-value!", set_top_level_value)+{+ argcount(nargs, 2);
+ symbol_t *sym = tosymbol(args[0]);
+ if(!isconstant(sym))
+ sym->binding = args[1];
+ return args[1];
+}
+
+BUILTIN("makunbound", makunbound)+{+ argcount(nargs, 1);
+ symbol_t *sym = tosymbol(args[0]);
+ if(!isconstant(sym))
+ sym->binding = UNBOUND;
+ return FL_void;
+}
+
+BUILTIN("environment", environment)+{+ USED(args);
+ argcount(nargs, 0);
+ value_t lst = FL_nil;
+ fl_gc_handle(&lst);
+ const char *k = nil;
+ symbol_t *v;
+ while(Tnext(FL(symtab), &k, (void**)&v)){+ if(v->binding != UNBOUND && (v->flags & FLAG_KEYWORD) == 0)
+ lst = fl_cons(tagptr(v, TAG_SYM), lst);
+ }
+ fl_free_gc_handles(1);
+ return lst;
+}
+
+fl_purefn
+BUILTIN("constant?", constantp)+{+ argcount(nargs, 1);
+ if(issymbol(args[0]))
+ return isconstant((symbol_t*)ptr(args[0])) ? FL_t : FL_f;
+ if(iscons(args[0])){+ if(car_(args[0]) == FL_quote)
+ return FL_t;
+ return FL_f;
+ }
+ return FL_t;
+}
+
+fl_purefn
+BUILTIN("integer-valued?", integer_valuedp)+{+ argcount(nargs, 1);
+ value_t v = args[0];
+ if(isfixnum(v))
+ return FL_t;
+ if(iscprim(v)){+ numerictype_t nt = cp_numtype(ptr(v));
+ if(nt < T_FLOAT)
+ return FL_t;
+ void *data = cp_data(ptr(v));
+ if(nt == T_FLOAT){+ float f = *(float*)data;
+ if(f < 0)
+ f = -f;
+ if(f <= FLT_MAXINT && (float)(int32_t)f == f)
+ return FL_t;
+ }else{+ assert(nt == T_DOUBLE);
+ double d = *(double*)data;
+ if(d < 0)
+ d = -d;
+ if(d <= DBL_MAXINT && (double)(int64_t)d == d)
+ return FL_t;
+ }
+ }
+ return FL_f;
+}
+
+fl_purefn
+BUILTIN("integer?", integerp)+{+ argcount(nargs, 1);
+ value_t v = args[0];
+ return (isfixnum(v) ||
+ (iscprim(v) && cp_numtype(ptr(v)) < T_FLOAT)) ?
+ FL_t : FL_f;
+}
+
+fl_purefn
+BUILTIN("bignum?", bignump)+{+ argcount(nargs, 1);
+ value_t v = args[0];
+ return (iscvalue(v) && cp_numtype(ptr(v)) == T_MPINT) ?
+ FL_t : FL_f;
+}
+
+BUILTIN("fixnum", fixnum)+{+ argcount(nargs, 1);
+ value_t v = args[0];
+ if(isfixnum(v))
+ return v;
+ void *p = ptr(v);
+ if(iscprim(v))
+ return fixnum(conv_to_int64(cp_data(p), cp_numtype(p)));
+ if(iscvalue(v) && cp_numtype(p) == T_MPINT)
+#ifdef BITS64
+ return fixnum(mptov(*(mpint**)cv_data(p)));
+#else
+ return fixnum(mptoi(*(mpint**)cv_data(p)));
+#endif
+ type_error("number", v);+}
+
+BUILTIN("truncate", truncate)+{+ argcount(nargs, 1);
+ if(isfixnum(args[0]))
+ return args[0];
+ if(iscprim(args[0])){+ cprim_t *cp = ptr(args[0]);
+ void *data = cp_data(cp);
+ numerictype_t nt = cp_numtype(cp);
+ double d;
+ if(nt == T_FLOAT)
+ d = (double)*(float*)data;
+ else if(nt == T_DOUBLE)
+ d = *(double*)data;
+ else
+ return args[0];
+
+ if(d > 0){+ if(d > (double)INT64_MAX)
+ return args[0];
+ return return_from_uint64((uint64_t)d);
+ }
+ if(d > (double)INT64_MAX || d < (double)INT64_MIN)
+ return args[0];
+ return return_from_int64((int64_t)d);
+ }
+ type_error("number", args[0]);+}
+
+BUILTIN("vector-alloc", vector_alloc)+{+ size_t i, k, a;
+ value_t f, v;
+ if(nargs < 1)
+ argcount(nargs, 1);
+ i = tosize(args[0]);
+ v = alloc_vector(i, 0);
+ a = 1;
+ for(k = 0; k < i; k++){+ f = a < nargs ? args[a] : FL_void;
+ vector_elt(v, k) = f;
+ if((a = (a + 1) % nargs) < 1)
+ a = 1;
+ }
+ return v;
+}
+
+BUILTIN("time-now", time_now)+{+ argcount(nargs, 0);
+ USED(args);
+ return mk_double(sec_realtime());
+}
+
+BUILTIN("nanoseconds-monotonic", nanoseconds_monotonic)+{+ argcount(nargs, 0);
+ USED(args);
+ return mk_uint64(nanosec_monotonic());
+}
+
+double
+todouble(value_t a)
+{+ if(isfixnum(a))
+ return (double)numval(a);
+ if(iscprim(a)){+ cprim_t *cp = ptr(a);
+ numerictype_t nt = cp_numtype(cp);
+ return conv_to_double(cp_data(cp), nt);
+ }
+ type_error("number", a);+}
+
+BUILTIN("time->string", time_string)+{+ argcount(nargs, 1);
+ double t = todouble(args[0]);
+ char buf[64];
+ timestring(t, buf, sizeof(buf));
+ return string_from_cstr(buf);
+}
+
+BUILTIN("string->time", string_time)+{+ argcount(nargs, 1);
+ char *ptr = tostring(args[0]);
+ double t = parsetime(ptr);
+ int64_t it = (int64_t)t;
+ if((double)it == t && fits_fixnum(it))
+ return fixnum(it);
+ return mk_double(t);
+}
+
+BUILTIN("path-cwd", path_cwd)+{+ if(nargs > 1)
+ argcount(nargs, 1);
+ if(nargs == 0){+ char buf[4096];
+ if(getcwd(buf, sizeof(buf)) == nil)
+ lerrorf(FL_IOError, "could not get current dir");
+ return string_from_cstr(buf);
+ }
+ char *ptr = tostring(args[0]);
+ if(chdir(ptr) != 0)
+ lerrorf(FL_IOError, "could not cd to %s", ptr);
+ return FL_void;
+}
+
+BUILTIN("path-exists?", path_existsp)+{+ argcount(nargs, 1);
+ const char *path = tostring(args[0]);
+ return access(path, F_OK) == 0 ? FL_t : FL_f;
+}
+
+BUILTIN("delete-file", delete_file)+{+ argcount(nargs, 1);
+ const char *path = tostring(args[0]);
+ if(remove(path) != 0)
+ lerrorf(FL_IOError, "could not remove %s", path);
+ return FL_void;
+}
+
+BUILTIN("os-getenv", os_getenv)+{+ argcount(nargs, 1);
+ char *name = tostring(args[0]);
+ char *val = getenv(name);
+ if(val == nil)
+ return FL_f;
+ return cvalue_static_cstring(val);
+}
+
+BUILTIN("os-setenv", os_setenv)+{+ argcount(nargs, 2);
+ char *name = tostring(args[0]);
+ int result;
+ if(args[1] == FL_f)
+ result = unsetenv(name);
+ else{+ char *val = tostring(args[1]);
+ result = setenv(name, val, 1);
+ }
+ if(result != 0)
+ lerrorf(FL_ArgError, "invalid environment variable");
+ return FL_t;
+}
+
+BUILTIN("rand", rand)+{+ USED(args); USED(nargs);
+#ifdef BITS64
+ uint64_t x = genrand_uint64();
+#else
+ uint32_t x = genrand_uint32();
+#endif
+ return fixnum(x >> 3);
+}
+
+BUILTIN("rand-uint32", rand_uint32)+{+ USED(args); USED(nargs);
+ return mk_uint32(genrand_uint32());
+}
+
+BUILTIN("rand-uint64", rand_uint64)+{+ USED(args); USED(nargs);
+ return mk_uint64(genrand_uint64());
+}
+
+BUILTIN("rand-double", rand_double)+{+ USED(args); USED(nargs);
+ return mk_double(genrand_double());
+}
+
+BUILTIN("rand-float", rand_float)+{+ USED(args); USED(nargs);
+ return mk_float(genrand_double());
+}
+
+#define BUILTIN_(lname, cname) \
+ BUILTIN(lname, cname) \
+ { \+ argcount(nargs, 1); \
+ return mk_double(cname(todouble(args[0]))); \
+ }
+
+BUILTIN_("sqrt", sqrt)+BUILTIN_("exp", exp)+BUILTIN_("log", log)+BUILTIN_("log10", log10)+BUILTIN_("sin", sin)+BUILTIN_("cos", cos)+BUILTIN_("tan", tan)+BUILTIN_("asin", asin)+BUILTIN_("acos", acos)+BUILTIN_("atan", atan)+BUILTIN_("floor", floor)+BUILTIN_("ceiling", ceil)+BUILTIN_("sinh", sinh)+BUILTIN_("cosh", cosh)+BUILTIN_("tanh", tanh)+
+#undef BUILTIN_
+#define BUILTIN_(lname, cname) \
+ BUILTIN(lname, cname) \
+ { \+ argcount(nargs, 2); \
+ return mk_double(cname(todouble(args[0]), todouble(args[1]))); \
+ }
+
+BUILTIN_("expt", pow)--- /dev/null
+++ b/src/cc.h
@@ -1,0 +1,58 @@
+#pragma once
+
+#ifdef __GNUC__
+
+#define fl_unlikely(x) __builtin_expect(!!(x), 0)
+#define fl_likely(x) __builtin_expect(!!(x), 1)
+#define fl_printfmt(x, y) __attribute__((format(printf, x, y)))
+#if defined(NDEBUG) && !defined(__macos__) && !defined(__dos__)
+#define fl_thread(x) __thread x
+#else
+#define fl_thread(x) x
+#endif
+#define fl_prefetch(x) __builtin_prefetch(x)
+#define fl_constfn __attribute__((const))
+#define fl_purefn __attribute__((pure))
+#define fl_hotfn __attribute__((hot))
+#define fl_aligned(x) __attribute__((aligned(x)))
+#define fl_popcount(x) __builtin_popcount(x)
+#define fl_clz(x) __builtin_clz(x)
+#define sadd_overflow __builtin_add_overflow
+#define sadd_overflow_64 __builtin_add_overflow
+#define smul_overflow_64 __builtin_mul_overflow
+
+#else
+
+#define fl_unlikely(x) (x)
+#define fl_likely(x) (x)
+#define fl_printfmt(x, y)
+#define fl_thread(x) x
+#define fl_prefetch(x)
+#define fl_constfn
+#define fl_purefn
+#define fl_hotfn
+#define fl_aligned(x)
+
+/* FIXME(sigrid): s*_overflow_* can be more optimal */
+#define sadd_overflow_64(a, b, c) ( \
+ (b < 1) ? \
+ ((INT64_MAX-(b) <= (a)) ? ((*(c)=(a)+(b)), 0) : 1) : \
+ ((INT64_MAX-(b) >= (a)) ? ((*(c)=(a)+(b)), 0) : 1) \
+)
+#define smul_overflow_64(a, b, c) ( \
+ ((a)>0 ? ((b)>0 ? (a)>INT64_MAX/(b) : (b)<INT64_MIN/(a)) \
+ : ((b)>0 ? (a)<INT64_MIN/(b) : ((a)!=0 && (b)<INT64_MAX/(a)))) \
+ ? 1 \
+ : ((*(c)=(a)*(b)), 0) \
+)
+#if defined(BITS64)
+#define sadd_overflow(a, b, c) sadd_overflow_64(a, b, c)
+#else
+#define sadd_overflow(a, b, c) ( \
+ (b < 1) ? \
+ ((INT32_MAX-(b) <= (a)) ? ((*(c)=(a)+(b)), 0) : 1) : \
+ ((INT32_MAX-(b) >= (a)) ? ((*(c)=(a)+(b)), 0) : 1) \
+)
+#endif
+
+#endif
--- /dev/null
+++ b/src/compiler.lsp
@@ -1,0 +1,881 @@
+; -*- scheme -*-
+
+;; code generation state, constant tables, bytecode encoding
+
+(define (make-code-emitter) (vector () (table) 0 () 0))
+(define-macro (bcode:code b) `(aref ,b 0))
+(define-macro (bcode:ctable b) `(aref ,b 1))
+(define-macro (bcode:nconst b) `(aref ,b 2))
+(define-macro (bcode:cenv b) `(aref ,b 3))
+(define-macro (bcode:sp b) `(aref ,b 4))
+(define-macro (bcode:stack b n) `(aset! ,b 4 (+ (bcode:sp ,b) ,n)))
+
+;; 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)))
+ (if (has? const-to-idx v)
+ (get const-to-idx v)
+ (begin (put! const-to-idx v nconst)
+ (prog1 nconst
+ (aset! b 2 (+ nconst 1)))))))
+
+(define (emit e inst . args)
+ (define (load? i)
+ (member i '(load0 load1 loadt loadf loadnil loadvoid))) ; FIXME no load immediate here yet
+ (let ((bc (aref e 0)))
+ (if (null? args)
+ (if (and (eq? inst 'car)
+ (eq? (car bc) 'cdr))
+ (set-car! bc 'cadr)
+ (cond ((and (eq? inst 'pop) (load? (car bc)))
+ (aset! e 0 (cdr bc)))
+ (else
+ (aset! e 0 (cons inst bc)))))
+ (begin
+ (if (memq inst '(loadv loadg setg))
+ (set! args (list (bcode:indexfor e (car args)))))
+ (let ((longform
+ (assq inst '((loadv loadv.l) (loadg loadg.l) (setg setg.l)
+ (loada loada.l) (seta seta.l) (box box.l)))))
+ (if (and longform
+ (> (car args) 255))
+ (set! inst (cadr longform))))
+ (let ((longform
+ (assq inst '((loadc loadc.l)))))
+ (if (and longform (> (car args) 255))
+ (set! inst (cadr longform))))
+ (if (eq? inst 'loada)
+ (cond ((equal? args '(0))
+ (set! inst 'loada0)
+ (set! args ()))
+ ((equal? args '(1))
+ (set! inst 'loada1)
+ (set! args ()))))
+ (if (eq? inst 'loadc)
+ (cond ((equal? args '(0))
+ (set! inst 'loadc0)
+ (set! args ()))
+ ((equal? args '(1))
+ (set! inst 'loadc1)
+ (set! args ()))))
+
+ (let ((lasti (car bc)))
+ (cond ((and (eq? inst 'brf)
+ (cond ((and (eq? lasti 'not)
+ (eq? (cadr bc) 'null?))
+ (aset! e 0 (cons (car args) (cons 'brn (cddr bc)))))
+ ((eq? lasti 'not)
+ (aset! e 0 (cons (car args) (cons 'brt (cdr bc)))))
+ ((eq? lasti 'eq?)
+ (aset! e 0 (cons (car args) (cons 'brne (cdr bc)))))
+ ((eq? lasti 'null?)
+ (aset! e 0 (cons (car args) (cons 'brnn (cdr bc)))))
+ (else #f))))
+ ((and (eq? inst 'brt) (eq? lasti 'null?))
+ (aset! e 0 (cons (car args) (cons 'brn (cdr bc)))))
+ (else
+ (aset! e 0 (nreconc (cons inst args) bc)))))))
+ e))
+
+(define-macro (make-label e) `(gensym))
+(define-macro (mark-label e l) `(emit ,e 'label ,l))
+
+;; 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
+ (* 3 (div0 (length v) 2)))
+ 65536)))
+ (let ((n (length v))
+ (i 0)
+ (label-to-loc (table))
+ (fixup-to-label (table))
+ (bcode (buffer))
+ (vi #f)
+ (nxt #f))
+ (io-write bcode #int32(0))
+ (while (< i n)
+ (begin
+ (set! vi (aref v i))
+ (if (eq? vi 'label)
+ (begin (put! label-to-loc (aref v (+ i 1)) (sizeof bcode))
+ (set! i (+ i 2)))
+ (begin
+ (io-write bcode
+ (byte
+ (get Instructions
+ (if long?
+ (case vi
+ (jmp 'jmp.l)
+ (brt 'brt.l)
+ (brf 'brf.l)
+ (brne 'brne.l)
+ (brnn 'brnn.l)
+ (brn 'brn.l)
+ (else vi))
+ vi))))
+ (set! i (+ i 1))
+ (set! nxt (if (< i n) (aref v i) #f))
+ (cond ((memq vi '(jmp brf brt brne brnn brn))
+ (put! fixup-to-label (sizeof bcode) nxt)
+ (io-write bcode ((if long? int32 int16) 0))
+ (set! i (+ i 1)))
+ ((eq? vi 'brbound)
+ (io-write bcode (int32 nxt))
+ (set! i (+ i 1)))
+ ((number? nxt)
+ (case vi
+ ((loadv.l loadg.l setg.l loada.l seta.l
+ largc lvargc call.l tcall.l loadc.l box.l)
+ (io-write bcode (int32 nxt))
+ (set! i (+ i 1)))
+
+ ((optargs keyargs) ; 2 int32 args
+ (io-write bcode (int32 nxt))
+ (set! i (+ i 1))
+ (io-write bcode (int32 (aref v i)))
+ (set! i (+ i 1))
+ (if (eq? vi 'keyargs)
+ (begin (io-write bcode (int32 (aref v i)))
+ (set! i (+ i 1)))))
+
+ (else
+ ; other number arguments are always uint8
+ (io-write bcode (uint8 nxt))
+ (set! i (+ i 1)))))
+ (else #f))))))
+
+ (for-each
+ (λ (addr labl)
+ (begin (io-seek bcode addr)
+ (io-write bcode ((if long? int32 int16)
+ (- (get label-to-loc labl)
+ addr)))))
+ fixup-to-label)
+ (iostream->string bcode))))
+
+(define (const-to-idx-vec e)
+ (let ((cvec (vector-alloc (bcode:nconst e))))
+ (for-each (λ (val idx) (aset! cvec idx val))
+ (bcode:ctable e))
+ cvec))
+
+;; variables
+
+(define (vinfo sym heap? index) (list sym heap? index))
+(define vinfo:sym car)
+(define vinfo:heap? cadr)
+(define vinfo:index caddr)
+
+(define (quoted? e) (eq? (car e) 'quote))
+
+(define (capture-var! g sym)
+ (let ((ce (bcode:cenv g)))
+ (let ((n (index-of sym ce 0)))
+ (or n
+ (prog1 (length ce)
+ (aset! g 3 (nconc ce (list sym))))))))
+
+(define (index-of item lst start)
+ (cond ((null? lst) #f)
+ ((eq? item (car lst)) start)
+ (else (index-of item (cdr lst) (+ start 1)))))
+
+(define (in-env? s env)
+ (and (cons? env)
+ (or (assq s (car env))
+ (in-env? s (cdr env)))))
+
+(define (lookup-sym s env lev)
+ (if (null? env)
+ 'global
+ (let* ((curr (car env))
+ (vi (assq s curr)))
+ (if vi
+ (cons lev vi)
+ (lookup-sym s
+ (cdr env)
+ (+ lev 1))))))
+
+(define (printable? x) (not (or (iostream? x)
+ (void? x)
+ (eof-object? x))))
+
+(define (compile-sym g env s deref)
+ (let ((loc (lookup-sym s env 0)))
+ (cond ((eq? loc 'global)
+ (if (and (constant? s)
+ (printable? (top-level-value s)))
+ (emit g 'loadv (top-level-value s))
+ (emit g 'loadg s)))
+
+ ((= (car loc) 0)
+ (emit g 'loada (vinfo:index (cdr loc)))
+ (if (and deref (vinfo:heap? (cdr loc)))
+ (emit g 'car)))
+
+ (else
+ (emit g 'loadc (capture-var! g s))
+ (if (and deref (vinfo:heap? (cdr loc)))
+ (emit g 'car))))))
+
+(define (compile-aset! g env args)
+ (let ((nref (- (length args) 2)))
+ (cond ((= nref 1)
+ (compile-app g env #f (cons 'aset! args)))
+ ((> nref 1)
+ (compile-app g env #f (cons 'aref (list-head args nref)))
+ (let ((nargs (compile-arglist g env (list-tail args nref))))
+ (bcode:stack g (- nargs))
+ (emit g 'aset!)))
+ (else (argc-error 'aset! 3)))))
+
+(define (compile-set! g env s rhs)
+ (let ((loc (lookup-sym s env 0)))
+ (if (eq? loc 'global)
+ (begin (compile-in g env #f rhs)
+ (emit g 'setg s))
+ (let ((arg? (= (car loc) 0)))
+ (let ((h? (vinfo:heap? (cdr loc)))
+ (idx (if arg?
+ (vinfo:index (cdr loc))
+ (capture-var! g s))))
+ (if h?
+ (begin (emit g (if arg? 'loada 'loadc) idx)
+ (bcode:stack g 1)
+ (compile-in g env #f rhs)
+ (bcode:stack g -1)
+ (emit g 'set-car!))
+
+ (begin (compile-in g env #f rhs)
+ (if (not arg?) (error (string "internal error: misallocated var " s)))
+ (emit g 'seta idx))))))))
+
+(define (box-vars g env)
+ (let loop ((e env))
+ (if (cons? e)
+ (begin (if (cadr (car e))
+ (emit g 'box (caddr (car e))))
+ (loop (cdr e))))))
+
+;; control flow
+
+(define (compile-if g env tail? x)
+ (let ((thenl (make-label g))
+ (elsel (make-label g))
+ (endl (make-label g))
+ (test (cadr x))
+ (then (caddr x))
+ (else (if (cons? (cdddr x))
+ (cadddr x)
+ #f)))
+ (cond ((eq? test #t)
+ (compile-in g env tail? then))
+ ((eq? test #f)
+ (compile-in g env tail? else))
+ (else
+ (compile-in g env #f test elsel)
+ (emit g 'brf elsel)
+ (mark-label g thenl)
+ (compile-in g env tail? then)
+ (if tail?
+ (emit g 'ret)
+ (emit g 'jmp endl))
+ (mark-label g elsel)
+ (compile-in g env tail? else)
+ (mark-label g endl)))))
+
+(define (compile-begin g env tail? forms)
+ (cond ((atom? forms) (compile-in g env tail? (void)))
+ ((atom? (cdr forms))
+ (compile-in g env tail? (car forms)))
+ (else
+ (compile-in g env #f (car forms))
+ (emit g 'pop)
+ (compile-begin g env tail? (cdr forms)))))
+
+(define (compile-prog1 g env x)
+ (compile-in g env #f (cadr x))
+ (if (cons? (cddr x))
+ (begin (bcode:stack g 1)
+ (compile-begin g env #f (cddr x))
+ (emit g 'pop)
+ (bcode:stack g -1))))
+
+(define (compile-while g env cond body)
+ (let ((top (make-label g))
+ (end (make-label g)))
+ (compile-in g env #f (void))
+ (bcode:stack g 1)
+ (mark-label g top)
+ (compile-in g env #f cond)
+ (emit g 'brf end)
+ (emit g 'pop)
+ (bcode:stack g -1)
+ (compile-in g env #f body)
+ (emit g 'jmp top)
+ (mark-label g end)))
+
+(define (is-lambda? a)
+ (or (eq? a 'λ)
+ (eq? a 'lambda)))
+
+(define (1arg-lambda? func)
+ (and (cons? func)
+ (is-lambda? (car func))
+ (length= (cadr func) 1)))
+
+(define (compile-short-circuit g env tail? forms default branch outl)
+ (cond ((atom? forms) (compile-in g env tail? default outl))
+ ((atom? (cdr forms)) (compile-in g env tail? (car forms) outl))
+ (else
+ (let ((end (or outl (make-label g))))
+ (compile-in g env #f (car forms) outl)
+ (bcode:stack g 1)
+ (unless outl (emit g 'dup))
+ (emit g branch end)
+ (bcode:stack g -1)
+ (unless outl (emit g 'pop))
+ (compile-short-circuit g env tail? (cdr forms) default branch outl)
+ (unless outl (mark-label g end))))))
+
+(define (compile-and g env tail? forms outl)
+ (compile-short-circuit g env tail? forms #t 'brf outl))
+(define (compile-or g env tail? forms)
+ (compile-short-circuit g env tail? forms #f 'brt #f))
+
+;; calls
+
+(define (compile-arglist g env lst)
+ (for-each (λ (a)
+ (compile-in g env #f a)
+ (bcode:stack g 1))
+ lst)
+ (length lst))
+
+(define (argc-error head count)
+ (error "compile error: " head " expects " count
+ (if (= count 1)
+ " argument."
+ " arguments.")))
+
+(define builtin->instruction
+ (let ((b2i (table number? 'number? cons 'cons
+ fixnum? 'fixnum? equal? 'equal?
+ eq? 'eq? symbol? 'symbol?
+ div0 'div0 builtin? 'builtin?
+ aset! 'aset! - '- boolean? 'boolean? not 'not
+ apply 'apply atom? 'atom? nan? 'nan?
+ set-cdr! 'set-cdr! / '/
+ function? 'function? vector 'vector
+ list 'list bound? 'bound?
+ < '< * '* cdr 'cdr cadr 'cadr null? 'null?
+ + '+ eqv? 'eqv? compare 'compare aref 'aref
+ set-car! 'set-car! car 'car for 'for
+ cons? 'cons? = '= vector? 'vector?)))
+ (λ (b)
+ (get b2i b #f))))
+
+(define (compile-builtin-call g env tail? x head b nargs)
+ (define (num-compare)
+ (if (= nargs 0)
+ (argc-error b 1)
+ (emit g b nargs)))
+ (let ((count (get arg-counts b #f)))
+ (if (and count
+ (not (length= (cdr x) count)))
+ (argc-error b count))
+ (case b ; handle special cases of vararg builtins
+ (list (if (= nargs 0)
+ (emit g 'loadnil)
+ (emit g b nargs)))
+ (< (num-compare))
+ (= (num-compare))
+ (+ (cond ((= nargs 0) (emit g 'load0))
+ ((= nargs 2) (emit g 'add2))
+ (else (emit g b nargs))))
+ (- (cond ((= nargs 0) (argc-error b 1))
+ ((= nargs 1) (emit g 'neg))
+ ((= nargs 2) (emit g 'sub2))
+ (else (emit g b nargs))))
+ (* (if (= nargs 0)
+ (emit g 'load1)
+ (emit g b nargs)))
+ (/ (if (= nargs 0)
+ (argc-error b 1)
+ (emit g b nargs)))
+ (vector (if (= nargs 0)
+ (emit g 'loadv #())
+ (emit g b nargs)))
+ (apply (if (< nargs 2)
+ (argc-error b 2)
+ (emit g (if tail? 'tapply 'apply) nargs)))
+ (aref (cond ((= nargs 2) (emit g 'aref2))
+ ((> nargs 2) (emit g b (- nargs 3)))
+ (else (argc-error b 2))))
+ (else (emit g b)))))
+
+(define (inlineable? form)
+ (let ((lam (car form)))
+ (and (cons? lam)
+ (is-lambda? (car lam))
+ (list? (cadr lam))
+ (every symbol? (cadr lam))
+ (not (length> (cadr lam) 255))
+ (length= (cadr lam) (length (cdr form))))))
+
+;; compile call to lambda in head position, inlined
+(define (compile-let g env tail? form)
+ (let ((lam (car form))
+ (args (cdr form))
+ (sp (bcode:sp g)))
+ (let ((vars (cadr lam))
+ (n (compile-arglist g env args)))
+ (let ((newvars
+ (vars-to-env vars (complex-bindings (caddr lam) vars) sp)))
+ (box-vars g newvars)
+ (let ((newenv
+ (cons (nconc newvars (car env))
+ (cdr env))))
+ (compile-in g newenv tail? (caddr lam))
+ (bcode:stack g (- n))
+ (if (and (> n 0) (not tail?))
+ (emit g 'shift n)))))))
+
+(define (compile-app g env tail? x)
+ (let ((head (car x)))
+ (let ((head
+ (if (and (symbol? head)
+ (not (in-env? head env))
+ (bound? head)
+ (builtin? (top-level-value head)))
+ (top-level-value head)
+ head)))
+ (if (length> (cdr x) 255)
+ ;; more than 255 arguments, need long versions of instructions
+ (begin (compile-in g env #f head)
+ (bcode:stack g 1)
+ (let ((nargs (compile-arglist g env (cdr x))))
+ (bcode:stack g (- nargs))
+ (emit g (if tail? 'tcall.l 'call.l) nargs)))
+ (let ((b (and (builtin? head)
+ (builtin->instruction head))))
+ (if (and (eq? head 'cadr)
+ (not (in-env? head env))
+ (equal? (top-level-value 'cadr) cadr)
+ (length= x 2))
+ (begin (compile-in g env #f (cadr x))
+ (emit g 'cadr))
+ (if (and (cons? head)
+ (is-lambda? (car head))
+ (inlineable? x))
+ (compile-let g env tail? x)
+ (begin
+ (unless b
+ (compile-in g env #f head)
+ (bcode:stack g 1))
+ (let ((nargs (compile-arglist g env (cdr x))))
+ (bcode:stack g (- nargs))
+ (unless b (bcode:stack g -1))
+ (if b
+ (compile-builtin-call g env tail? x head b nargs)
+ (emit g (if tail? 'tcall 'call) nargs)))))))))))
+
+;; lambda, main compilation loop
+
+(define (fits-i8 x) (and (fixnum? x) (>= 127 x -128)))
+
+(define (compile-in g env tail? x (outl #f))
+ (cond ((symbol? x) (compile-sym g env x #t))
+ ((atom? x)
+ (cond ((eq? x 0) (emit g 'load0))
+ ((eq? x 1) (emit g 'load1))
+ ((eq? x #t) (emit g 'loadt))
+ ((eq? x #f) (emit g 'loadf))
+ ((eq? x nil) (emit g 'loadnil))
+ ((void? x) (emit g 'loadvoid))
+ ((fits-i8 x) (emit g 'loadi8 x))
+ (else (emit g 'loadv x))))
+ ((eq? (car x) 'aset!)
+ (compile-aset! g env (cdr x)))
+ ((or (not (symbol? (car x))) (bound? (car x)) (in-env? (car x) env))
+ (compile-app g env tail? x))
+ (else
+ (case (car x)
+ (quote (if (self-evaluating? (cadr x))
+ (compile-in g env tail? (cadr x))
+ (emit g 'loadv (cadr x))))
+ (if (compile-if g env tail? x))
+ (begin (compile-begin g env tail? (cdr x)))
+ (prog1 (compile-prog1 g env x))
+ (λ (receive (the-f cenv) (compile-f- env x)
+ (begin (emit g 'loadv the-f)
+ (if (not (null? cenv))
+ (begin
+ (for-each (λ (var)
+ (compile-sym g env var #f))
+ cenv)
+ (emit g 'closure (length cenv)))))))
+ (and (compile-and g env tail? (cdr x) outl))
+ (or (compile-or g env tail? (cdr x)))
+ (while (compile-while g env (cadr x) (cons 'begin (cddr x))))
+ (return (compile-in g env #t (cadr x))
+ (emit g 'ret))
+ (set! (let* ((name (cadr x))
+ (value (cddr x))
+ (doc (value-get-doc value)))
+ (unless (symbol? name)
+ (error "set!: name must be a symbol"))
+ (when doc
+ (set! value (cdr value))
+ (symbol-set-doc name doc (and (cons? (car value))
+ (is-lambda? (car (car value)))
+ (lambda:vars (car value)))))
+ (compile-set! g env name (car value))))
+ (trycatch (compile-in g env #f `(λ () ,(cadr x)))
+ (unless (1arg-lambda? (caddr x))
+ (error "trycatch: second form must be a 1-argument lambda"))
+ (compile-in g env #f (caddr x))
+ (emit g 'trycatch))
+ (else (compile-app g env tail? x))))))
+
+;; optional and keyword args
+
+(define (keyword-arg? x) (and (cons? x) (keyword? (car x))))
+(define (keyword->symbol k)
+ (if (keyword? k)
+ (symbol (let ((s (string k)))
+ (string-sub s 1 (string-length s))))
+ k))
+
+(define (lambda-vars l)
+ (define (check-formals l o opt kw)
+ (cond ((or (null? l) (symbol? l)) #t)
+ ((and (cons? l) (symbol? (car l)))
+ (if (or opt kw)
+ (error "compile error: invalid argument list "
+ o ": optional arguments must come after required.")
+ (check-formals (cdr l) o opt kw)))
+ ((and (cons? l) (cons? (car l)))
+ (unless (and (length= (car l) 2)
+ (symbol? (caar l)))
+ (error "compile error: invalid optional argument " (car l)
+ " in list " o))
+ (if (keyword? (caar l))
+ (check-formals (cdr l) o opt #t)
+ (if kw
+ (error "compile error: invalid argument list "
+ o ": keyword arguments must come last.")
+ (check-formals (cdr l) o #t kw))))
+ ((cons? l)
+ (error "compile error: invalid formal argument " (car l)
+ " in list " o))
+ (else
+ (if (eq? l o)
+ (error "compile error: invalid argument list " o)
+ (error "compile error: invalid formal argument " l
+ " in list " o)))))
+ (check-formals l l #f #f)
+ (map (λ (s) (if (cons? s) (keyword->symbol (car s)) s))
+ (to-proper l)))
+
+(define (emit-optional-arg-inits g env opta vars i)
+ ; i is the lexical var index of the opt arg to process next
+ (if (cons? opta)
+ (let ((nxt (make-label g)))
+ (emit g 'brbound i)
+ (emit g 'brt nxt)
+ (compile-in g (extend-env env (list-head vars i) '()) #f (cadar opta))
+ (emit g 'seta i)
+ (emit g 'pop)
+ (mark-label g nxt)
+ (emit-optional-arg-inits g env (cdr opta) vars (+ i 1)))))
+
+;; define
+
+(define (expand-define x)
+ ;; expand a single `define` expression to `set!`
+ (let* ((form (cadr x))
+ (body (if (cons? (cddr x))
+ (cddr x)
+ (if (symbol? form)
+ #.void
+ (error "compile error: invalid syntax " (print-to-string x))))))
+ (if (symbol? form)
+ `(#.void (set! ,form ,(car body)))
+ `(#.void (set! ,(car form)
+ (λ ,(cdr form) ,@body . ,(car form)))))))
+
+(define get-defined-vars
+ (letrec ((get-defined-vars-
+ (λ (expr)
+ (cond ((atom? expr) ())
+ ((and (eq? (car expr) 'define)
+ (cons? (cdr expr)))
+ (or (and (symbol? (cadr expr))
+ (list (cadr expr)))
+ (and (cons? (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 (lower-define e)
+ ;; convert lambda to one body expression and process internal defines
+ (define (λ-body e)
+ (let* ((B (if (cons? (cddr e))
+ (if (cons? (cdddr e))
+ (cons 'begin (cddr e))
+ (caddr e))
+ (void)))
+ (V (get-defined-vars B))
+ (new-B (lower-define B)))
+ (if (null? V)
+ new-B
+ (cons `(λ ,V ,new-B)
+ (map 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))))
+
+;; closure analysis
+
+(define (lambda:body e) (caddr e))
+(define (lambda:vars e) (lambda-vars (cadr e)))
+
+(define (diff s1 s2)
+ (cond ((null? s1) '())
+ ((memq (car s1) s2) (diff (cdr s1) s2))
+ (else (cons (car s1) (diff (cdr s1) s2)))))
+
+;; bindings that are both captured and set!'d
+(define (complex-bindings- e vars head nested capt setd)
+ (cond ((null? vars) #f)
+ ((symbol? e)
+ (if (and nested (memq e vars))
+ (put! capt e #t)))
+ ((or (atom? e) (quoted? e)) #f)
+ ((eq? (car e) 'set!)
+ (if (memq (cadr e) vars)
+ (begin (put! setd (cadr e) #t)
+ (if nested (put! capt (cadr e) #t))))
+ (complex-bindings- (caddr e) vars #f nested capt setd))
+ ((is-lambda? (car e))
+ (complex-bindings- (lambda:body e)
+ (diff vars (lambda:vars e))
+ #f
+ (or (not head) nested)
+ capt setd))
+ (else
+ (cons (complex-bindings- (car e) vars (inlineable? e) nested capt setd)
+ (map (λ (x)
+ (complex-bindings- x vars #f nested capt setd))
+ (cdr e))))))
+
+(define (complex-bindings e vars)
+ (let ((capt (table))
+ (setd (table)))
+ (complex-bindings- e vars #f #f capt setd)
+ (filter (λ (x) (has? capt x))
+ (table-keys setd))))
+
+(define (vars-to-env vars cb offs)
+ (map (λ (var i) (vinfo var (not (not (memq var cb))) (+ i offs)))
+ vars (iota (length vars))))
+
+(define (extend-env env vars cb)
+ (cons (vars-to-env vars cb 0)
+ env))
+
+;; main entry points
+
+(define (compile f) (compile-f () (lower-define f)))
+
+(define (compile-thunk expr)
+ ;; to eval a top-level expression we need to avoid internal define
+ (compile-f () `(λ () ,(lower-define expr))))
+
+(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 f))
+ (opta (filter cons? (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)))
+
+ (let ((newenv (extend-env env vars (complex-bindings (lambda:body f) vars))))
+ (box-vars g (car newenv))
+ ;; set initial stack pointer
+ (aset! g 4 (+ (length vars) 4))
+ ;; compile body and return
+ (compile-in g newenv #t (lambda:body f))
+ (emit g 'ret)
+ (values (function (encode-byte-code (bcode:code g))
+ (const-to-idx-vec g) name)
+ (bcode:cenv g))))))
+
+;; disassembler
+
+(define (ref-int32-LE a i)
+ (int32 (+ (ash (aref a (+ i 0)) 0)
+ (ash (aref a (+ i 1)) 8)
+ (ash (aref a (+ i 2)) 16)
+ (ash (aref a (+ i 3)) 24))))
+
+(define (ref-int16-LE a i)
+ (int16 (+ (ash (aref a (+ i 0)) 0)
+ (ash (aref a (+ i 1)) 8))))
+
+(define (hex5 n)
+ (string-lpad (number->string n 16) 5 #\0))
+
+(define (disassemble f (ip #f) . lev?)
+ (if (null? lev?)
+ (begin (disassemble f ip 0)
+ (newline)
+ (return (void))))
+ (let ((lev (car lev?))
+ (code (function:code f))
+ (vals (function:vals f)))
+ (define (print-val v)
+ (if (and (function? v) (not (builtin? v)))
+ (begin (newline)
+ (disassemble v #f (+ lev 1)))
+ (print v)))
+ (define (print-inst inst s sz) (princ (if (and ip (= lev 0) (>= ip (1- s)) (< ip (+ s sz)))
+ " >"
+ " ")
+ (hex5 (- s 5)) ": "
+ inst " "))
+ (let ((i 4)
+ (N (length code)))
+ (while (< i N)
+ ; find key whose value matches the current byte
+ (let ((inst (table-foldl (λ (k v z)
+ (or z (and (eq? v (aref code i))
+ k)))
+ #f Instructions)))
+ (if (> i 4) (newline))
+ (dotimes (xx lev) (princ "\t"))
+ (set! i (+ i 1))
+ (case inst
+ ((loadv.l loadg.l setg.l)
+ (print-inst inst i 4)
+ (print-val (aref vals (ref-int32-LE code i)))
+ (set! i (+ i 4)))
+
+ ((loadv loadg setg)
+ (print-inst inst i 1)
+ (print-val (aref vals (aref code i)))
+ (set! i (+ i 1)))
+
+ ((loada seta loadc call tcall list + - * / < = vector
+ argc vargc loadi8 apply tapply closure box shift aref)
+ (print-inst inst i 1)
+ (princ (number->string (+ (aref code i) (if (eq? inst 'aref) 3 0))))
+ (set! i (+ i 1)))
+
+ ((loada.l seta.l loadc.l largc lvargc call.l tcall.l box.l)
+ (print-inst inst i 4)
+ (princ (number->string (ref-int32-LE code i)))
+ (set! i (+ i 4)))
+
+ ((optargs keyargs)
+ (print-inst inst i (+ 8 (if (eq? inst 'keyargs) 4 0)))
+ (princ (number->string (ref-int32-LE code i)) " ")
+ (set! i (+ i 4))
+ (princ (number->string (ref-int32-LE code i)))
+ (set! i (+ i 4))
+ (if (eq? inst 'keyargs)
+ (begin
+ (princ " ")
+ (princ (number->string (ref-int32-LE code i)) " ")
+ (set! i (+ i 4)))))
+
+ ((brbound)
+ (print-inst inst i 4)
+ (princ (number->string (ref-int32-LE code i)) " ")
+ (set! i (+ i 4)))
+
+ ((jmp brf brt brne brnn brn)
+ (print-inst inst i 2)
+ (princ "@" (hex5 (+ i -4 (ref-int16-LE code i))))
+ (set! i (+ i 2)))
+
+ ((jmp.l brf.l brt.l brne.l brnn.l brn.l)
+ (print-inst inst i 4)
+ (princ "@" (hex5 (+ i -4 (ref-int32-LE code i))))
+ (set! i (+ i 4)))
+
+ (else (print-inst inst i 0))))))))
+
+; From SRFI 89 by Marc Feeley (http://srfi.schemers.org/srfi-89/srfi-89.html)
+; Copyright (C) Marc Feeley 2006. All Rights Reserved.
+;
+; "alist" is a list of pairs of the form "(keyword . value)"
+; The result is a perfect hash-table represented as a vector of
+; length 2*N, where N is the hash modulus. If the keyword K is in
+; the hash-table it is at index
+;
+; X = (* 2 ($hash-keyword K N))
+;
+; and the associated value is at index X+1.
+(define (make-perfect-hash-table alist)
+ (define ($hash-keyword key n) (mod0 (abs (hash key)) n))
+ (let loop1 ((n (length alist)))
+ (let ((v (vector-alloc (* 2 n) #f)))
+ (let loop2 ((lst alist))
+ (if (cons? lst)
+ (let ((key (caar lst)))
+ (let ((x (* 2 ($hash-keyword key n))))
+ (if (aref v x)
+ (loop1 (+ n 1))
+ (begin
+ (aset! v x key)
+ (aset! v (+ x 1) (cdar lst))
+ (loop2 (cdr lst))))))
+ v)))))
--- /dev/null
+++ b/src/compress.c
@@ -1,0 +1,76 @@
+#include "flisp.h"
+#include "compress.h"
+#include "cvalues.h"
+#include "types.h"
+#include "brieflz.h"
+
+BUILTIN("lz-pack", lz_pack)+{+ if(nargs < 1)
+ argcount(nargs, 1);
+ if(nargs > 2)
+ argcount(nargs, 2);
+
+ if(!isarray(args[0]))
+ type_error("array", args[0]);+ uint8_t *in;
+ size_t insz;
+ to_sized_ptr(args[0], &in, &insz);
+ int level = nargs > 1 ? tofixnum(args[1]) : 0;
+ if(level < 0)
+ level = 0;
+ else if(level > 10)
+ level = 10;
+
+ value_t v = cvalue(cv_class(ptr(args[0])), blz_max_packed_size(insz));
+ uint8_t *out = cvalue_data(v);
+
+ size_t worksz = level > 0
+ ? blz_workmem_size_level(insz, level)
+ : blz_workmem_size(insz);
+ uint8_t *work = MEM_ALLOC(worksz);
+ unsigned long n = level > 0
+ ? blz_pack_level(in, out, insz, work, level)
+ : blz_pack(in, out, insz, work);
+ MEM_FREE(work);
+ if(n == BLZ_ERROR)
+ lerrorf(FL_ArgError, "blz error");
+ cvalue_len(v) = n;
+ return v;
+}
+
+BUILTIN("lz-unpack", lz_unpack)+{+ argcount(nargs, 3);
+
+ uint8_t *in;
+ size_t insz;
+ to_sized_ptr(args[0], &in, &insz);
+ if(!isarray(args[0]))
+ type_error("array", args[0]);+ size_t outsz;
+ uint8_t *out;
+ value_t v;
+ if(args[1] == FL_sizesym){+ outsz = tosize(args[2]);
+ v = cvalue(cv_class(ptr(args[0])), outsz);
+ out = cvalue_data(v);
+ }else if(args[1] == FL_tosym){+ v = args[2];
+ to_sized_ptr(v, &out, &outsz);
+ }else{+ lerrorf(FL_ArgError, "either :size or :to must be specified");
+ }
+ unsigned long n = blz_depack_safe(in, insz, out, outsz);
+ if(n == BLZ_ERROR)
+ lerrorf(FL_ArgError, "blz error");
+ cvalue_len(v) = n;
+ return v;
+}
+
+void
+compress_init(void)
+{+ FL_sizesym = symbol(":size", false);+ FL_tosym = symbol(":to", false);+}
--- /dev/null
+++ b/src/compress.h
@@ -1,0 +1,1 @@
+void compress_init(void);
--- /dev/null
+++ b/src/cvalues.c
@@ -1,0 +1,1384 @@
+#include "flisp.h"
+#include "operators.h"
+#include "cvalues.h"
+#include "types.h"
+#include "iostream.h"
+#include "equal.h"
+
+static void cvalue_init(fltype_t *type, value_t v, void *dest);
+
+void
+add_finalizer(cvalue_t *cv)
+{+ if(FL(nfinalizers) == FL(maxfinalizers)){+ size_t nn = FL(maxfinalizers) == 0 ? 256 : FL(maxfinalizers)*2;
+ cvalue_t **temp = MEM_REALLOC(FL(finalizers), nn*sizeof(cvalue_t*));
+ if(temp == nil)
+ lerrorf(FL_MemoryError, "out of memory");
+ FL(finalizers) = temp;
+ FL(maxfinalizers) = nn;
+ }
+ FL(finalizers)[FL(nfinalizers)++] = cv;
+}
+
+// remove dead objects from finalization list in-place
+void
+sweep_finalizers(void)
+{+ cvalue_t **lst = FL(finalizers);
+ size_t n = 0, ndel = 0, l = FL(nfinalizers);
+ cvalue_t *tmp;
+#define SWAP_sf(a, b) (tmp = a, a = b, b = tmp, 1)
+ if(l == 0)
+ return;
+ do{+ tmp = lst[n];
+ if(isforwarded((value_t)tmp)){+ // object is alive
+ lst[n] = ptr(forwardloc((value_t)tmp));
+ n++;
+ }else{+ fltype_t *t = cv_class(tmp);
+ if(t->vtable != nil && t->vtable->finalize != nil)
+ t->vtable->finalize(tagptr(tmp, TAG_CVALUE));
+ if(!isinlined(tmp) && owned(tmp) && !FL(exiting)){+ memset(cv_data(tmp), 0xbb, cv_len(tmp));
+ MEM_FREE(cv_data(tmp));
+ }
+ ndel++;
+ }
+ }while((n < l-ndel) && SWAP_sf(lst[n], lst[n+ndel]));
+
+ FL(nfinalizers) -= ndel;
+#if defined(VERBOSEGC)
+ if(ndel > 0)
+ printf("GC: finalized %d objects\n", ndel);+#endif
+
+ FL(malloc_pressure) = 0;
+}
+
+// compute the size of the metadata object for a cvalue
+static size_t
+cv_nwords(cvalue_t *cv)
+{+ if(isinlined(cv)){+ size_t n = cv_len(cv);
+ if(n == 0 || cv_isstr(cv))
+ n++;
+ return CVALUE_NWORDS - 1 + NWORDS(n);
+ }
+ return CVALUE_NWORDS;
+}
+
+static void
+autorelease(cvalue_t *cv)
+{+ cv->type = (fltype_t*)(((uintptr_t)cv->type) | CV_OWNED_BIT);
+ add_finalizer(cv);
+}
+
+void
+cv_autorelease(cvalue_t *cv)
+{+ autorelease(cv);
+}
+
+static value_t
+cprim(fltype_t *type, size_t sz)
+{+ assert(!ismanaged((uintptr_t)type));
+ assert(sz == type->size);
+ cprim_t *pcp = alloc_words(CPRIM_NWORDS-1+NWORDS(sz));
+ pcp->type = type;
+ return tagptr(pcp, TAG_CPRIM);
+}
+
+value_t
+cvalue_(fltype_t *type, size_t sz, bool nofinalize)
+{+ cvalue_t *pcv;
+ int str = 0;
+
+ assert(type != nil);
+ if(valid_numtype(type->numtype) && type->numtype != T_MPINT)
+ return cprim(type, sz);
+
+ if(type->eltype == FL(bytetype)){+ if(sz == 0)
+ return FL(the_empty_string);
+ sz++;
+ str = 1;
+ }
+ if(sz <= MAX_INL_SIZE){+ size_t nw = CVALUE_NWORDS - 1 + NWORDS(sz) + (sz == 0 ? 1 : 0);
+ pcv = alloc_words(nw);
+ pcv->type = type;
+ pcv->data = &pcv->_space[0];
+ if(!nofinalize && type->vtable != nil && type->vtable->finalize != nil)
+ add_finalizer(pcv);
+ }else{+ if(FL(malloc_pressure) > ALLOC_LIMIT_TRIGGER)
+ fl_gc(0);
+ pcv = alloc_words(CVALUE_NWORDS);
+ pcv->type = type;
+ pcv->data = MEM_ALLOC(sz);
+ autorelease(pcv);
+ FL(malloc_pressure) += sz;
+ }
+ if(str)
+ ((char*)pcv->data)[--sz] = '\0';
+ pcv->len = sz;
+ return tagptr(pcv, TAG_CVALUE);
+}
+
+// this effectively dereferences a pointer
+// just like *p in C, it only removes a level of indirection from the type,
+// it doesn't copy any data.
+// this method of creating a cvalue only allocates metadata.
+// ptr is user-managed; we don't autorelease it unless the
+// user explicitly calls (autorelease ) on the result of this function.
+// 'parent' is an optional cvalue that this pointer is known to point
+// into; NIL if none.
+value_t
+cvalue_from_ref(fltype_t *type, void *ptr, size_t sz, value_t parent)
+{+ cvalue_t *pcv;
+ value_t cv;
+
+ assert(type != nil);
+ assert(ptr != nil);
+ pcv = alloc_words(CVALUE_NWORDS);
+ pcv->data = ptr;
+ pcv->len = sz;
+ pcv->type = type;
+ if(parent != FL_nil){+ pcv->type = (fltype_t*)(((uintptr_t)pcv->type) | CV_PARENT_BIT);
+ pcv->parent = parent;
+ }
+ cv = tagptr(pcv, TAG_CVALUE);
+ return cv;
+}
+
+value_t
+cvalue_string(size_t sz)
+{+ if(sz == 0)
+ return FL(the_empty_string);
+ return cvalue(FL(stringtype), sz);
+}
+
+value_t
+cvalue_static_cstring(const char *str)
+{+ if(*str == 0)
+ return FL(the_empty_string);
+ return cvalue_from_ref(FL(stringtype), (char*)str, strlen(str), FL_nil);
+}
+
+value_t
+string_from_cstrn(char *str, size_t n)
+{+ value_t v = cvalue_string(n);
+ memcpy(cvalue_data(v), str, n);
+ return v;
+}
+
+value_t
+string_from_cstr(char *str)
+{+ return string_from_cstrn(str, strlen(str));
+}
+
+int
+fl_isstring(value_t v)
+{+ return iscvalue(v) && cv_isstr(ptr(v));
+}
+
+// convert to malloc representation (fixed address)
+void
+cv_pin(cvalue_t *cv)
+{+ if(!isinlined(cv))
+ return;
+ size_t sz = cv_len(cv);
+ if(cv_isstr(cv))
+ sz++;
+ void *data = MEM_ALLOC(sz);
+ memcpy(data, cv_data(cv), sz);
+ cv->data = data;
+ autorelease(cv);
+}
+
+#define num_init(ctype, cnvt, tag) \
+ static int \
+ cvalue_##ctype##_init(fltype_t *type, value_t arg, void *dest) \
+ { \+ ctype n; \
+ USED(type); \
+ if(isfixnum(arg)) \
+ n = (ctype)numval(arg); \
+ else if(iscprim(arg)){ \+ cprim_t *cp = ptr(arg); \
+ void *p = cp_data(cp); \
+ n = (ctype)conv_to_##cnvt(p, cp_numtype(cp)); \
+ }else if(iscvalue(arg) && cp_numtype(ptr(arg)) == T_MPINT){ \+ cvalue_t *cv = ptr(arg); \
+ void *p = cv_data(cv); \
+ n = (ctype)conv_to_##cnvt(p, T_MPINT); \
+ }else \
+ return 1; \
+ *((ctype*)dest) = n; \
+ return 0; \
+ }
+
+num_init(int8_t, int32, T_INT8)
+num_init(uint8_t, uint32, T_UINT8)
+num_init(int16_t, int32, T_INT16)
+num_init(uint16_t, uint32, T_UINT16)
+num_init(int32_t, int32, T_INT32)
+num_init(uint32_t, uint32, T_UINT32)
+num_init(int64_t, int64, T_INT64)
+num_init(uint64_t, uint64, T_UINT64)
+num_init(float, double, T_FLOAT)
+num_init(double, double, T_DOUBLE)
+
+#define num_ctor_init(typenam, ctype, tag) \
+ static \
+ BUILTIN(#typenam, typenam) \
+ { \+ if(nargs == 0){ \+ PUSH(fixnum(0)); \
+ args = &FL(stack)[FL(sp)-1]; \
+ } \
+ value_t cp = cprim(FL(typenam##type), sizeof(ctype)); \
+ if(cvalue_##ctype##_init(FL(typenam##type), args[0], cp_data(ptr(cp)))) \
+ type_error("number", args[0]); \+ return cp; \
+ }
+
+#define num_ctor_ctor(typenam, ctype, tag) \
+ value_t mk_##typenam(ctype n) \
+ { \+ value_t cp = cprim(FL(typenam##type), sizeof(ctype)); \
+ *(ctype*)cp_data(ptr(cp)) = n; \
+ return cp; \
+ }
+
+#define num_ctor(typenam, ctype, tag) \
+ num_ctor_init(typenam, ctype, tag) \
+ num_ctor_ctor(typenam, ctype, tag)
+
+num_ctor_init(int8, int8_t, T_INT8)
+num_ctor_init(uint8, uint8_t, T_UINT8)
+num_ctor_init(int16, int16_t, T_INT16)
+num_ctor_init(uint16, uint16_t, T_UINT16)
+num_ctor(int32, int32_t, T_INT32)
+num_ctor(uint32, uint32_t, T_UINT32)
+num_ctor(int64, int64_t, T_INT64)
+num_ctor(uint64, uint64_t, T_UINT64)
+num_ctor_init(byte, uint8_t, T_UINT8)
+num_ctor(float, float, T_FLOAT)
+num_ctor(double, double, T_DOUBLE)
+num_ctor(rune, uint32_t, T_UINT32)
+
+static int
+cvalue_mpint_init(fltype_t *type, value_t arg, void *dest)
+{+ mpint *n;
+ USED(type);
+ if(isfixnum(arg)){+ n = vtomp(numval(arg), nil);
+ }else if(iscvalue(arg)){+ cvalue_t *cv = ptr(arg);
+ void *p = cv_data(cv);
+ n = conv_to_mpint(p, cp_numtype(cv));
+ }else if(iscprim(arg)){+ cprim_t *cp = ptr(arg);
+ void *p = cp_data(cp);
+ n = conv_to_mpint(p, cp_numtype(cp));
+ }else{+ return 1;
+ }
+ *((mpint**)dest) = n;
+ return 0;
+}
+
+BUILTIN("bignum", bignum)+{+ if(nargs == 0){+ PUSH(fixnum(0));
+ args = &FL(stack)[FL(sp)-1];
+ }
+ value_t cv = cvalue(FL(mpinttype), sizeof(mpint*));
+ if(cvalue_mpint_init(FL(mpinttype), args[0], cvalue_data(cv)))
+ type_error("number", args[0]);+ return cv;
+}
+
+
+value_t
+mk_mpint(mpint *n)
+{+ value_t cv = cvalue(FL(mpinttype), sizeof(mpint*));
+ *(mpint**)cvalue_data(cv) = n;
+ return cv;
+}
+
+static void
+free_mpint(value_t self)
+{+ mpint **s = value2c(mpint**, self);
+ if(*s != mpzero && *s != mpone && *s != mptwo)
+ mpfree(*s);
+}
+
+static cvtable_t mpint_vtable = { nil, nil, free_mpint, nil };+
+value_t
+size_wrap(size_t sz)
+{+ if(sizeof(size_t) == 8)
+ return fits_fixnum(sz) ? fixnum(sz): mk_uint64(sz);
+ else
+ return fits_fixnum(sz) ? fixnum(sz): mk_uint32(sz);
+}
+
+size_t
+tosize(value_t n)
+{+ if(isfixnum(n))
+ return (size_t)numval(n);
+ if(iscprim(n)){+ cprim_t *cp = ptr(n);
+ if(sizeof(size_t) == 8)
+ return conv_to_uint64(cp_data(cp), cp_numtype(cp));
+ return conv_to_uint32(cp_data(cp), cp_numtype(cp));
+ }
+ type_error("number", n);+}
+
+off_t
+tooffset(value_t n)
+{+ if(isfixnum(n))
+ return numval(n);
+ if(iscprim(n)){+ cprim_t *cp = ptr(n);
+ return conv_to_int64(cp_data(cp), cp_numtype(cp));
+ }
+ type_error("number", n);+}
+
+int
+isarray(value_t v)
+{+ return iscvalue(v) && cv_class(ptr(v))->eltype != nil;
+}
+
+static size_t
+predict_arraylen(value_t arg)
+{+ if(isvector(arg))
+ return vector_size(arg);
+ if(iscons(arg))
+ return llength(arg);
+ if(arg == FL_nil)
+ return 0;
+ if(isarray(arg))
+ return cvalue_arraylen(arg);
+ return 1;
+}
+
+int
+cvalue_array_init(fltype_t *ft, value_t arg, void *dest)
+{+ value_t type = ft->type;
+ size_t elsize, i, cnt, sz;
+ fltype_t *eltype = ft->eltype;
+
+ elsize = ft->elsz;
+ cnt = predict_arraylen(arg);
+
+ if(iscons(cdr_(cdr_(type)))){+ size_t tc = tosize(car_(cdr_(cdr_(type))));
+ if(tc != cnt)
+ lerrorf(FL_ArgError, "size mismatch");
+ }
+
+ sz = elsize * cnt;
+
+ if(isvector(arg)){+ assert(cnt <= vector_size(arg));
+ for(i = 0; i < cnt; i++){+ cvalue_init(eltype, vector_elt(arg, i), dest);
+ dest = (char*)dest + elsize;
+ }
+ return 0;
+ }
+ if(iscons(arg) || arg == FL_nil){+ i = 0;
+ while(iscons(arg)){+ if(i == cnt){+ i++;
+ break;
+ } // trigger error
+ cvalue_init(eltype, car_(arg), dest);
+ i++;
+ dest = (char*)dest + elsize;
+ arg = cdr_(arg);
+ }
+ if(i != cnt)
+ lerrorf(FL_ArgError, "size mismatch");
+ return 0;
+ }
+ if(iscvalue(arg)){+ cvalue_t *cv = ptr(arg);
+ if(isarray(arg)){+ fltype_t *aet = cv_class(cv)->eltype;
+ if(aet == eltype){+ if(cv_len(cv) == sz)
+ memcpy(dest, cv_data(cv), sz);
+ else
+ lerrorf(FL_ArgError, "size mismatch");
+ return 0;
+ }else{+ // TODO: initialize array from different type elements
+ lerrorf(FL_ArgError, "element type mismatch");
+ }
+ }
+ }
+ if(cnt == 1)
+ cvalue_init(eltype, arg, dest);
+ type_error("sequence", arg);+}
+
+BUILTIN("array", array)+{+ size_t elsize, cnt, sz;
+ value_t arg;
+
+ if(nargs < 1)
+ argcount(nargs, 1);
+
+ cnt = nargs - 1;
+ fltype_t *type = get_array_type(args[0]);
+ elsize = type->elsz;
+ sz = elsize * cnt;
+
+ value_t cv = cvalue(type, sz);
+ char *dest = cvalue_data(cv);
+ uint32_t i;
+ FOR_ARGS(i, 1, arg, args){+ if(!fl_isnumber(arg))
+ type_error("number", arg);+ cvalue_init(type->eltype, arg, dest);
+ dest += elsize;
+ }
+ return cv;
+}
+
+BUILTIN("array-alloc", array_alloc)+{+ size_t elsize, sz;
+ long i, cnt, a;
+
+ if(nargs < 3)
+ argcount(nargs, 3);
+ cnt = tosize(args[1]);
+ if(cnt < 0)
+ lerrorf(FL_ArgError, "invalid size: %"PRIu64, (uint64_t)cnt);
+
+ fltype_t *type = get_array_type(args[0]);
+ elsize = type->elsz;
+ sz = elsize * cnt;
+
+ value_t cv = cvalue(type, sz);
+ char *dest = cvalue_data(cv);
+ a = 2;
+ for(i = 0; i < cnt; i++){+ value_t arg = args[a];
+ if(!fl_isnumber(arg))
+ type_error("number", arg);+ cvalue_init(type->eltype, arg, dest);
+ dest += elsize;
+ if((a = (a + 1) % nargs) < 2)
+ a = 2;
+ }
+ return cv;
+}
+
+// NOTE: v must be an array
+size_t
+cvalue_arraylen(value_t v)
+{+ cvalue_t *cv = ptr(v);
+ return cv_len(cv)/cv_class(cv)->elsz;
+}
+
+size_t
+ctype_sizeof(value_t type)
+{+ symbol_t *s;
+
+ if(issymbol(type) && (s = ptr(type)) != nil && valid_numtype(s->numtype))
+ return s->size;
+
+ if(iscons(type)){+ value_t hed = car_(type);
+ if(hed == FL_arraysym){+ value_t t = car(cdr_(type));
+ if(!iscons(cdr_(cdr_(type))))
+ lerrorf(FL_ArgError, "incomplete type");
+ value_t n = car_(cdr_(cdr_(type)));
+ size_t sz = tosize(n);
+ return sz * ctype_sizeof(t);
+ }
+ }
+
+ lerrorf(FL_ArgError, "invalid c type");
+}
+
+// get pointer and size for any plain-old-data value
+void
+to_sized_ptr(value_t v, uint8_t **pdata, size_t *psz)
+{+ if(iscvalue(v)){+ cvalue_t *pcv = ptr(v);
+ ios_t *x = value2c(ios_t*, v);
+ if(cv_class(pcv) == FL(iostreamtype) && x->bm == bm_mem){+ *pdata = x->buf;
+ *psz = x->size;
+ return;
+ }
+ if(cv_isPOD(pcv)){+ *pdata = cv_data(pcv);
+ *psz = cv_len(pcv);
+ return;
+ }
+ }
+ if(iscprim(v)){+ cprim_t *pcp = ptr(v);
+ *pdata = cp_data(pcp);
+ *psz = cp_class(pcp)->size;
+ return;
+ }
+ type_error("plain-old-data", v);+}
+
+BUILTIN("sizeof", sizeof)+{+ argcount(nargs, 1);
+ if(issymbol(args[0]) || iscons(args[0]))
+ return size_wrap(ctype_sizeof(args[0]));
+ size_t n;
+ uint8_t *data;
+ to_sized_ptr(args[0], &data, &n);
+ return size_wrap(n);
+}
+
+fl_purefn
+BUILTIN("typeof", typeof)+{+ argcount(nargs, 1);
+ switch(tag(args[0])){+ case TAG_CONS: return FL_conssym;
+ case TAG_NUM1: case TAG_NUM: return FL_fixnumsym;
+ case TAG_SYM: return FL_symbolsym;
+ case TAG_VECTOR: return FL_vectorsym;
+ case TAG_FUNCTION:
+ if(args[0] == FL_t || args[0] == FL_f)
+ return FL_booleansym;
+ if(args[0] == FL_nil)
+ return FL_nullsym;
+ if(args[0] == FL_eof)
+ return FL_eof;
+ if(args[0] == FL_void)
+ return FL_void;
+ if(isbuiltin(args[0]))
+ return FL_builtinsym;
+ return FL_function;
+ }
+ return cv_type(ptr(args[0]));
+}
+
+value_t
+cvalue_relocate(value_t v)
+{+ size_t nw;
+ cvalue_t *cv = ptr(v);
+ cvalue_t *nv;
+ value_t ncv;
+
+ nw = cv_nwords(cv);
+ nv = alloc_words(nw);
+ memcpy(nv, cv, nw*sizeof(value_t));
+ if(isinlined(cv))
+ nv->data = &nv->_space[0];
+ ncv = tagptr(nv, TAG_CVALUE);
+ fltype_t *t = cv_class(cv);
+ if(t->vtable != nil && t->vtable->relocate != nil)
+ t->vtable->relocate(v, ncv);
+ forward(v, ncv);
+ if(FL(exiting))
+ cv_autorelease(ptr(ncv));
+ return ncv;
+}
+
+value_t
+cvalue_copy(value_t v)
+{+ assert(iscvalue(v));
+ PUSH(v);
+ cvalue_t *cv = ptr(v);
+ size_t nw = cv_nwords(cv);
+ cvalue_t *ncv = alloc_words(nw);
+ v = POP();
+ cv = ptr(v);
+ memcpy(ncv, cv, nw * sizeof(value_t));
+ if(!isinlined(cv)){+ size_t len = cv_len(cv);
+ if(cv_isstr(cv))
+ len++;
+ ncv->data = MEM_ALLOC(len);
+ memcpy(ncv->data, cv_data(cv), len);
+ autorelease(ncv);
+ if(hasparent(cv)){+ ncv->type = (fltype_t*)(((uintptr_t)ncv->type) & ~CV_PARENT_BIT);
+ ncv->parent = FL_nil;
+ }
+ }else{+ ncv->data = &ncv->_space[0];
+ }
+
+ return tagptr(ncv, TAG_CVALUE);
+}
+
+BUILTIN("copy", copy)+{+ argcount(nargs, 1);
+ if(iscons(args[0]) || isvector(args[0]))
+ lerrorf(FL_ArgError, "argument must be a leaf atom");
+ if(!iscvalue(args[0]))
+ return args[0];
+ if(!cv_isPOD(ptr(args[0])))
+ lerrorf(FL_ArgError, "argument must be a plain-old-data type");
+ return cvalue_copy(args[0]);
+}
+
+fl_purefn
+BUILTIN("plain-old-data?", plain_old_datap)+{+ argcount(nargs, 1);
+ return (iscprim(args[0]) ||
+ (iscvalue(args[0]) && cv_isPOD(ptr(args[0])))) ?
+ FL_t : FL_f;
+}
+
+static void
+cvalue_init(fltype_t *type, value_t v, void *dest)
+{+ cvinitfunc_t f = type->init;
+ if(f == nil)
+ lerrorf(FL_ArgError, "invalid c type");
+ f(type, v, dest);
+}
+
+// (new type . args)
+// this provides (1) a way to allocate values with a shared type for
+// efficiency, (2) a uniform interface for allocating cvalues of any
+// type, including user-defined.
+BUILTIN("c-value", c_value)+{+ if(nargs < 1 || nargs > 2)
+ argcount(nargs, 2);
+ value_t type = args[0];
+ fltype_t *ft = get_type(type);
+ value_t cv;
+ if(ft->eltype != nil){+ // special case to handle incomplete array types bla[]
+ size_t elsz = ft->elsz;
+ size_t cnt;
+
+ if(iscons(cdr_(cdr_(type))))
+ cnt = tosize(car_(cdr_(cdr_(type))));
+ else if(nargs == 2)
+ cnt = predict_arraylen(args[1]);
+ else
+ cnt = 0;
+ cv = cvalue(ft, elsz * cnt);
+ if(nargs == 2)
+ cvalue_array_init(ft, args[1], cvalue_data(cv));
+ }else{+ cv = cvalue(ft, ft->size);
+ if(nargs == 2)
+ cvalue_init(ft, args[1], cptr(cv));
+ }
+ return cv;
+}
+
+// NOTE: this only compares lexicographically; it ignores numeric formats
+value_t
+cvalue_compare(value_t a, value_t b)
+{+ cvalue_t *ca = ptr(a);
+ cvalue_t *cb = ptr(b);
+ char *adata = cv_data(ca);
+ char *bdata = cv_data(cb);
+ size_t asz = cv_len(ca);
+ size_t bsz = cv_len(cb);
+ size_t minsz = asz < bsz ? asz : bsz;
+ int diff = memcmp(adata, bdata, minsz);
+ if(diff == 0){+ if(asz > bsz)
+ return fixnum(1);
+ if(asz < bsz)
+ return fixnum(-1);
+ }
+ return fixnum(diff);
+}
+
+static void
+check_addr_args(value_t arr, value_t ind, uint8_t **data, int *index)
+{+ int numel;
+ cvalue_t *cv = ptr(arr);
+ *data = cv_data(cv);
+ numel = cv_len(cv)/cv_class(cv)->elsz;
+ *index = tosize(ind);
+ if(*index < 0 || *index >= numel)
+ bounds_error(arr, ind);
+}
+
+value_t
+cvalue_array_aref(value_t *args)
+{+ uint8_t *data;
+ int index;
+ fltype_t *eltype = cv_class(ptr(args[0]))->eltype;
+ value_t el = 0;
+ numerictype_t nt = eltype->numtype;
+ if(nt >= T_INT32)
+ el = cvalue(eltype, eltype->size);
+ check_addr_args(args[0], args[1], &data, &index);
+ if(nt < T_INT32){+ if(nt == T_INT8)
+ return fixnum((int8_t)data[index]);
+ if(nt == T_UINT8)
+ return fixnum((uint8_t)data[index]);
+ if(nt == T_INT16)
+ return fixnum(((int16_t*)data)[index]);
+ return fixnum(((uint16_t*)data)[index]);
+ }
+ uint8_t *dest = cptr(el);
+ size_t sz = eltype->size;
+ if(sz == 1)
+ *dest = data[index];
+ else if(sz == 2)
+ *(int16_t*)dest = ((int16_t*)data)[index];
+ else if(sz == 4)
+ *(int32_t*)dest = ((int32_t*)data)[index];
+ else if(sz == 8)
+ *(int64_t*)dest = ((int64_t*)data)[index];
+ else
+ memcpy(dest, data + index*sz, sz);
+ return el;
+}
+
+value_t
+cvalue_array_aset(value_t *args)
+{+ uint8_t *data; int index;
+ fltype_t *eltype = cv_class(ptr(args[0]))->eltype;
+ check_addr_args(args[0], args[1], &data, &index);
+ uint8_t *dest = data + index*eltype->size;
+ cvalue_init(eltype, args[2], dest);
+ return args[2];
+}
+
+fl_purefn
+BUILTIN("builtin", builtin)+{+ argcount(nargs, 1);
+ symbol_t *s = tosymbol(args[0]);
+ if(!iscbuiltin(s->binding))
+ lerrorf(FL_ArgError, "function \"%s\" not found", s->name);
+ return s->binding;
+}
+
+value_t
+cbuiltin(const char *name, builtin_t f)
+{+ cvalue_t *cv;
+ cv = MEM_CALLOC(CVALUE_NWORDS, sizeof(*cv));
+ assert(cv != nil);
+ cv->type = FL(builtintype);
+ cv->data = &cv->_space[0];
+ cv->len = sizeof(value_t);
+ *(builtin_t*)cv->data = f;
+
+ value_t sym = symbol(name, false);
+ symbol_t *s = ((symbol_t*)ptr(sym));
+ s->binding = tagptr(cv, TAG_CVALUE);
+ ptrhash_put(&FL(reverse_dlsym_lookup_table), cv, (void*)sym);
+
+ return s->binding;
+}
+
+#define cv_intern(tok) \
+ do{ \+ FL_##tok##sym = symbol(#tok, false); \
+ }while(0)
+
+#define ctor_cv_intern(tok, nt, ctype) \
+ do{ \+ symbol_t *s; \
+ cv_intern(tok); \
+ set(FL_##tok##sym, cbuiltin(#tok, fn_builtin_##tok)); \
+ if(valid_numtype(nt)){ \+ s = ptr(FL_##tok##sym); \
+ s->numtype = nt; \
+ s->size = sizeof(ctype); \
+ } \
+ }while(0)
+
+#define mk_primtype(name, ctype) \
+ do{ \+ FL(name##type) = get_type(FL_##name##sym); \
+ FL(name##type)->init = cvalue_##ctype##_init; \
+ }while(0)
+
+#define RETURN_NUM_AS(var, type) return(mk_##type(var))
+
+value_t
+return_from_uint64(uint64_t Uaccum)
+{+ if(fits_fixnum(Uaccum))
+ return fixnum((fixnum_t)Uaccum);
+ if(Uaccum > (uint64_t)INT64_MAX)
+ RETURN_NUM_AS(Uaccum, uint64);
+ if(Uaccum > (uint64_t)UINT32_MAX)
+ RETURN_NUM_AS(Uaccum, int64);
+ if(Uaccum > (uint64_t)INT32_MAX)
+ RETURN_NUM_AS(Uaccum, uint32);
+ RETURN_NUM_AS(Uaccum, int32);
+}
+
+value_t
+return_from_int64(int64_t Saccum)
+{+ if(fits_fixnum(Saccum))
+ return fixnum((fixnum_t)Saccum);
+ RETURN_NUM_AS(vtomp(Saccum, nil), mpint);
+}
+
+#define ACCUM_DEFAULT 0
+#define ARITH_OP(a, b) (a)+(b)
+#define MP_OP mpadd
+#define ARITH_OVERFLOW sadd_overflow_64
+value_t
+fl_add_any(value_t *args, uint32_t nargs)
+{+#include "fl_arith_any.inc"
+}
+
+#define ACCUM_DEFAULT 1
+#define ARITH_OP(a, b) (a)*(b)
+#define MP_OP mpmul
+#define ARITH_OVERFLOW smul_overflow_64
+value_t
+fl_mul_any(value_t *args, uint32_t nargs)
+{+#include "fl_arith_any.inc"
+}
+
+value_t
+fl_neg(value_t n)
+{+ int64_t i64;
+ uint64_t ui64;
+ mpint *mp;
+ numerictype_t pt;
+ fixnum_t pi;
+ void *a;
+
+ if(isfixnum(n)){+ i64 = -(int64_t)numval(n);
+i64neg:
+ return fits_fixnum(i64) ? fixnum(i64) : mk_mpint(vtomp(i64, nil));
+ }
+
+ if(num_to_ptr(n, &pi, &pt, &a)){+ switch(pt){+ case T_DOUBLE: return mk_double(-*(double*)a);
+ case T_FLOAT: return mk_float(-*(float*)a);
+ case T_INT8: return fixnum(-(fixnum_t)*(int8_t*)a);
+ case T_UINT8: return fixnum(-(fixnum_t)*(uint8_t*)a);
+ case T_INT16: return fixnum(-(fixnum_t)*(int16_t*)a);
+ case T_UINT16: return fixnum(-(fixnum_t)*(uint16_t*)a);
+ case T_UINT32:
+ i64 = -(int64_t)*(uint32_t*)a;
+ if(0){+ case T_INT32:
+ i64 = -(int64_t)*(int32_t*)a;
+ }
+ goto i64neg;
+ case T_INT64:
+ i64 = *(int64_t*)a;
+ if(i64 == INT64_MIN)
+ return mk_mpint(uvtomp((uint64_t)INT64_MAX+1, nil));
+ i64 = -i64;
+ goto i64neg;
+ case T_UINT64:
+ ui64 = *(uint64_t*)a;
+ if(ui64 >= (uint64_t)INT64_MAX+1){+ mp = uvtomp(ui64, nil);
+ mp->sign = -1;
+ return mk_mpint(mp);
+ }
+ i64 = -(int64_t)ui64;
+ goto i64neg;
+ case T_MPINT:
+ mp = mpcopy(*(mpint**)a);
+ mp->sign = -mp->sign;
+ return mk_mpint(mp);
+ }
+ }
+
+ type_error("number", n);+}
+
+int
+num_to_ptr(value_t a, fixnum_t *pi, numerictype_t *pt, void **pp)
+{+ cprim_t *cp;
+ cvalue_t *cv;
+ if(isfixnum(a)){+ *pi = numval(a);
+ *pp = pi;
+ *pt = T_FIXNUM;
+ return 1;
+ }else if(iscprim(a)){+ cp = ptr(a);
+ *pp = cp_data(cp);
+ *pt = cp_numtype(cp);
+ return 1;
+ }else if(iscvalue(a)){+ cv = ptr(a);
+ *pp = cv_data(cv);
+ *pt = cv_class(cv)->numtype;
+ return valid_numtype(*pt);
+ }
+ return 0;
+}
+
+/*
+ returns -1, 0, or 1 based on ordering of a and b
+ eq: consider equality only, returning 0 or nonzero
+ eqnans: NaNs considered equal to each other
+ -0.0 not considered equal to 0.0
+ inexact not considered equal to exact
+ typeerr: if not 0, throws type errors, else returns 2 for type errors
+*/
+int
+numeric_compare(value_t a, value_t b, bool eq, bool eqnans, bool typeerr)
+{+ fixnum_t ai, bi;
+ numerictype_t ta, tb;
+ void *aptr, *bptr;
+
+ if(bothfixnums(a, b)){+ if(!eq && numval(a) < numval(b))
+ return -1;
+ if(a == b)
+ return 0;
+ return 1;
+ }
+ if(!num_to_ptr(a, &ai, &ta, &aptr)){+ if(typeerr)
+ type_error("number", a);+ return 2;
+ }
+ if(!num_to_ptr(b, &bi, &tb, &bptr)){+ if(typeerr)
+ type_error("number", b);+ return 2;
+ }
+ if(eq && eqnans && ((ta >= T_FLOAT) != (tb >= T_FLOAT)))
+ return 1;
+ if(cmp_eq(aptr, ta, bptr, tb, eqnans))
+ return 0;
+ if(eq)
+ return 1;
+ if(cmp_lt(aptr, ta, bptr, tb))
+ return -1;
+ return 1;
+}
+
+_Noreturn void
+DivideByZeroError(void)
+{+ lerrorf(FL_DivideError, "/: division by zero");
+}
+
+value_t
+fl_div2(value_t a, value_t b)
+{+ double da, db;
+ fixnum_t ai, bi;
+ numerictype_t ta, tb;
+ void *aptr, *bptr;
+
+ if(!num_to_ptr(a, &ai, &ta, &aptr))
+ type_error("number", a);+ if(!num_to_ptr(b, &bi, &tb, &bptr))
+ type_error("number", b);+
+ da = conv_to_double(aptr, ta);
+ db = conv_to_double(bptr, tb);
+
+ if(db == 0 && tb < T_FLOAT) // exact 0
+ DivideByZeroError();
+
+ da = da/db;
+
+ if(ta < T_FLOAT && tb < T_FLOAT && (double)(int64_t)da == da)
+ return return_from_int64((int64_t)da);
+ return mk_double(da);
+}
+
+value_t
+fl_idiv2(value_t a, value_t b)
+{+ fixnum_t ai, bi;
+ numerictype_t ta, tb;
+ void *aptr, *bptr;
+ int64_t a64, b64;
+ mpint *x;
+
+ if(!num_to_ptr(a, &ai, &ta, &aptr))
+ type_error("number", a);+ if(!num_to_ptr(b, &bi, &tb, &bptr))
+ type_error("number", b);+
+ if(ta == T_MPINT){+ if(tb == T_MPINT){+ if(mpsignif(*(mpint**)bptr) == 0)
+ goto div_error;
+ x = mpnew(0);
+ mpdiv(*(mpint**)aptr, *(mpint**)bptr, x, nil);
+ return mk_mpint(x);
+ }else{+ b64 = conv_to_int64(bptr, tb);
+ if(b64 == 0)
+ goto div_error;
+ x = tb == T_UINT64 ? uvtomp(b64, nil) : vtomp(b64, nil);
+ mpdiv(*(mpint**)aptr, x, x, nil);
+ return mk_mpint(x);
+ }
+ }
+ if(ta == T_UINT64){+ if(tb == T_UINT64){+ if(*(uint64_t*)bptr == 0)
+ goto div_error;
+ return return_from_uint64(*(uint64_t*)aptr / *(uint64_t*)bptr);
+ }
+ b64 = conv_to_int64(bptr, tb);
+ if(b64 < 0)
+ return return_from_int64(-(int64_t)(*(uint64_t*)aptr / (uint64_t)(-b64)));
+ if(b64 == 0)
+ goto div_error;
+ return return_from_uint64(*(uint64_t*)aptr / (uint64_t)b64);
+ }
+ if(tb == T_UINT64){+ if(*(uint64_t*)bptr == 0)
+ goto div_error;
+ a64 = conv_to_int64(aptr, ta);
+ if(a64 < 0)
+ return return_from_int64(-((int64_t)((uint64_t)(-a64) / *(uint64_t*)bptr)));
+ return return_from_uint64((uint64_t)a64 / *(uint64_t*)bptr);
+ }
+
+ b64 = conv_to_int64(bptr, tb);
+ if(b64 == 0)
+ goto div_error;
+
+ return return_from_int64(conv_to_int64(aptr, ta) / b64);
+ div_error:
+ DivideByZeroError();
+}
+
+static value_t
+fl_bitwise_op(value_t a, value_t b, int opcode)
+{+ fixnum_t ai, bi;
+ numerictype_t ta, tb, itmp;
+ void *aptr = nil, *bptr = nil, *ptmp;
+ mpint *bmp = nil, *resmp = nil;
+ int64_t b64;
+
+ if(!num_to_ptr(a, &ai, &ta, &aptr) || ta >= T_FLOAT)
+ type_error("integer", a);+ if(!num_to_ptr(b, &bi, &tb, &bptr) || tb >= T_FLOAT)
+ type_error("integer", b);+
+ if(ta < tb){+ itmp = ta; ta = tb; tb = itmp;
+ ptmp = aptr; aptr = bptr; bptr = ptmp;
+ }
+ // now a's type is larger than or same as b's
+ if(ta == T_MPINT){+ if(tb == T_MPINT){+ bmp = *(mpint**)bptr;
+ resmp = mpnew(0);
+ }else{+ bmp = conv_to_mpint(bptr, tb);
+ resmp = bmp;
+ }
+ b64 = 0;
+ }else
+ b64 = conv_to_int64(bptr, tb);
+ switch(opcode){+ case 0:
+ switch(ta){+ case T_INT8: return fixnum( *(int8_t *)aptr & (int8_t )b64);
+ case T_UINT8: return fixnum( *(uint8_t *)aptr & (uint8_t )b64);
+ case T_INT16: return fixnum( *(int16_t*)aptr & (int16_t )b64);
+ case T_UINT16: return fixnum( *(uint16_t*)aptr & (uint16_t)b64);
+ case T_INT32: return mk_int32( *(int32_t*)aptr & (int32_t )b64);
+ case T_UINT32: return mk_uint32(*(uint32_t*)aptr & (uint32_t)b64);
+ case T_INT64: return mk_int64( *(int64_t*)aptr & (int64_t )b64);
+ case T_UINT64: return mk_uint64(*(uint64_t*)aptr & (uint64_t)b64);
+ case T_MPINT: mpand(*(mpint**)aptr, bmp, resmp); return mk_mpint(resmp);
+ case T_FLOAT:
+ case T_DOUBLE: assert(0);
+ }
+ break;
+ case 1:
+ switch(ta){+ case T_INT8: return fixnum( *(int8_t *)aptr | (int8_t )b64);
+ case T_UINT8: return fixnum( *(uint8_t *)aptr | (uint8_t )b64);
+ case T_INT16: return fixnum( *(int16_t*)aptr | (int16_t )b64);
+ case T_UINT16: return fixnum( *(uint16_t*)aptr | (uint16_t)b64);
+ case T_INT32: return mk_int32( *(int32_t*)aptr | (int32_t )b64);
+ case T_UINT32: return mk_uint32(*(uint32_t*)aptr | (uint32_t)b64);
+ case T_INT64: return mk_int64( *(int64_t*)aptr | (int64_t )b64);
+ case T_UINT64: return mk_uint64(*(uint64_t*)aptr | (uint64_t)b64);
+ case T_MPINT: mpor(*(mpint**)aptr, bmp, resmp); return mk_mpint(resmp);
+ case T_FLOAT:
+ case T_DOUBLE: assert(0);
+ }
+ break;
+ case 2:
+ switch(ta){+ case T_INT8: return fixnum( *(int8_t *)aptr ^ (int8_t )b64);
+ case T_UINT8: return fixnum( *(uint8_t *)aptr ^ (uint8_t )b64);
+ case T_INT16: return fixnum( *(int16_t*)aptr ^ (int16_t )b64);
+ case T_UINT16: return fixnum( *(uint16_t*)aptr ^ (uint16_t)b64);
+ case T_INT32: return mk_int32( *(int32_t*)aptr ^ (int32_t )b64);
+ case T_UINT32: return mk_uint32(*(uint32_t*)aptr ^ (uint32_t)b64);
+ case T_INT64: return mk_int64( *(int64_t*)aptr ^ (int64_t )b64);
+ case T_UINT64: return mk_uint64(*(uint64_t*)aptr ^ (uint64_t)b64);
+ case T_MPINT: mpxor(*(mpint**)aptr, bmp, resmp); return mk_mpint(resmp);
+ case T_FLOAT:
+ case T_DOUBLE: assert(0);
+ }
+ }
+ assert(0);
+ return FL_nil;
+}
+
+BUILTIN("logand", logand)+{+ value_t v, e;
+ if(nargs == 0)
+ return fixnum(-1);
+ v = args[0];
+ uint32_t i;
+ FOR_ARGS(i, 1, e, args){+ if(bothfixnums(v, e))
+ v = v & e;
+ else
+ v = fl_bitwise_op(v, e, 0);
+ }
+ return v;
+}
+
+BUILTIN("logior", logior)+{+ value_t v, e;
+ if(nargs == 0)
+ return fixnum(0);
+ v = args[0];
+ uint32_t i;
+ FOR_ARGS(i, 1, e, args){+ if(bothfixnums(v, e))
+ v = v | e;
+ else
+ v = fl_bitwise_op(v, e, 1);
+ }
+ return v;
+}
+
+BUILTIN("logxor", logxor)+{+ value_t v, e;
+ if(nargs == 0)
+ return fixnum(0);
+ v = args[0];
+ uint32_t i;
+ FOR_ARGS(i, 1, e, args){+ if(bothfixnums(v, e))
+ v = fixnum(numval(v) ^ numval(e));
+ else
+ v = fl_bitwise_op(v, e, 2);
+ }
+ return v;
+}
+
+BUILTIN("lognot", lognot)+{+ argcount(nargs, 1);
+ value_t a = args[0];
+ cprim_t *cp;
+ int ta;
+ void *aptr;
+
+ if(isfixnum(a))
+ return fixnum(~numval(a));
+ if(iscprim(a)){+ cp = ptr(a);
+ ta = cp_numtype(cp);
+ aptr = cp_data(cp);
+ switch(ta){+ case T_INT8: return fixnum(~*(int8_t *)aptr);
+ case T_UINT8: return fixnum(~*(uint8_t *)aptr & 0xff);
+ case T_INT16: return fixnum(~*(int16_t *)aptr);
+ case T_UINT16: return fixnum(~*(uint16_t*)aptr & 0xffff);
+ case T_INT32: return mk_int32(~*(int32_t *)aptr);
+ case T_UINT32: return mk_uint32(~*(uint32_t*)aptr);
+ case T_INT64: return mk_int64(~*(int64_t *)aptr);
+ case T_UINT64: return mk_uint64(~*(uint64_t*)aptr);
+ }
+ }
+ if(iscvalue(a)){+ cvalue_t *cv = ptr(a);
+ ta = cp_numtype(cv);
+ aptr = cv_data(cv);
+ if(ta == T_MPINT){+ mpint *m = mpnew(0);
+ mpnot(*(mpint**)aptr, m);
+ return mk_mpint(m);
+ }
+ }
+ type_error("integer", a);+}
+
+BUILTIN("ash", ash)+{+ fixnum_t n;
+ int64_t accum;
+ cprim_t *cp;
+ int ta;
+ mpint *mp;
+ void *aptr;
+
+ argcount(nargs, 2);
+ value_t a = args[0];
+ n = tofixnum(args[1]);
+ if(isfixnum(a)){+ if(n <= 0)
+ return fixnum(numval(a)>>(-n));
+ accum = ((int64_t)numval(a))<<n;
+ return fits_fixnum(accum) ? fixnum(accum) : return_from_int64(accum);
+ }
+ if(iscprim(a) || iscvalue(a)){+ if(n == 0)
+ return a;
+ cp = ptr(a);
+ ta = cp_numtype(cp);
+ aptr = cp_data(cp);
+ if(n < 0){+ n = -n;
+ switch(ta){+ case T_INT8: return fixnum((*(int8_t *)aptr) >> n);
+ case T_UINT8: return fixnum((*(uint8_t *)aptr) >> n);
+ case T_INT16: return fixnum((*(int16_t *)aptr) >> n);
+ case T_UINT16: return fixnum((*(uint16_t*)aptr) >> n);
+ case T_INT32: return mk_int32((*(int32_t *)aptr) >> n);
+ case T_UINT32: return mk_uint32((*(uint32_t*)aptr) >> n);
+ case T_INT64: return mk_int64((*(int64_t *)aptr) >> n);
+ case T_UINT64: return mk_uint64((*(uint64_t*)aptr) >> n);
+ case T_MPINT:
+ aptr = cv_data(cp);
+ mp = mpnew(0);
+ mpright(*(mpint**)aptr, n, mp);
+ return mk_mpint(mp);
+ }
+ }
+ if(ta == T_MPINT){+ aptr = cv_data(cp);
+ mp = mpnew(0);
+ mpleft(*(mpint**)aptr, n, mp);
+ return mk_mpint(mp);
+ }
+ if(ta == T_UINT64)
+ return return_from_uint64((*(uint64_t*)aptr)<<n);
+ if(ta < T_FLOAT)
+ return return_from_int64(conv_to_int64(aptr, ta)<<n);
+ }
+ type_error("integer", a);+}
+
+void
+cvalues_init(void)
+{+ htable_new(&FL(TypeTable), 256);
+ htable_new(&FL(reverse_dlsym_lookup_table), 256);
+
+ FL(builtintype) = define_opaque_type(FL_builtinsym, sizeof(builtin_t), nil, nil);
+
+ ctor_cv_intern(int8, T_INT8, int8_t);
+ ctor_cv_intern(uint8, T_UINT8, uint8_t);
+ ctor_cv_intern(int16, T_INT16, int16_t);
+ ctor_cv_intern(uint16, T_UINT16, uint16_t);
+ ctor_cv_intern(int32, T_INT32, int32_t);
+ ctor_cv_intern(uint32, T_UINT32, uint32_t);
+ ctor_cv_intern(int64, T_INT64, int64_t);
+ ctor_cv_intern(uint64, T_UINT64, uint64_t);
+ ctor_cv_intern(byte, T_UINT8, uint8_t);
+ ctor_cv_intern(rune, T_UINT32, uint32_t);
+ ctor_cv_intern(float, T_FLOAT, float);
+ ctor_cv_intern(double, T_DOUBLE, double);
+
+ ctor_cv_intern(array, NONNUMERIC, int);
+
+ FL_stringtypesym = symbol("*string-type*", false);+ set(FL_stringtypesym, fl_list2(FL_arraysym, FL_bytesym));
+
+ FL_runestringtypesym = symbol("*runestring-type*", false);+ set(FL_runestringtypesym, fl_list2(FL_arraysym, FL_runesym));
+
+ mk_primtype(int8, int8_t);
+ mk_primtype(uint8, uint8_t);
+ mk_primtype(int16, int16_t);
+ mk_primtype(uint16, uint16_t);
+ mk_primtype(int32, int32_t);
+ mk_primtype(uint32, uint32_t);
+ mk_primtype(int64, int64_t);
+ mk_primtype(uint64, uint64_t);
+ mk_primtype(byte, uint8_t);
+ mk_primtype(rune, uint32_t);
+ mk_primtype(float, float);
+ mk_primtype(double, double);
+
+ ctor_cv_intern(bignum, T_MPINT, mpint*);
+ FL(mpinttype) = get_type(FL_bignumsym);
+ FL(mpinttype)->init = cvalue_mpint_init;
+ FL(mpinttype)->vtable = &mpint_vtable;
+
+ FL(stringtype) = get_type(symbol_value(FL_stringtypesym));
+ FL(the_empty_string) = cvalue_from_ref(FL(stringtype), (char*)"", 0, FL_nil);
+ FL(runestringtype) = get_type(symbol_value(FL_runestringtypesym));
+}
--- /dev/null
+++ b/src/cvalues.h
@@ -1,0 +1,64 @@
+#pragma once
+
+#if defined(BITS64)
+#define NWORDS(sz) (((sz)+7)>>3)
+#else
+#define NWORDS(sz) (((sz)+3)>>2)
+#endif
+#define CVALUE_NWORDS 4
+#define MAX_INL_SIZE 384
+#define CV_OWNED_BIT 0x1
+#define CV_PARENT_BIT 0x2
+#define owned(cv) ((uintptr_t)(cv)->type & CV_OWNED_BIT)
+#define hasparent(cv) ((uintptr_t)(cv)->type & CV_PARENT_BIT)
+#define isinlined(cv) ((cv)->data == &(cv)->_space[0])
+
+void add_finalizer(cvalue_t *cv);
+void sweep_finalizers(void);
+void cv_autorelease(cvalue_t *cv);
+value_t cvalue_(fltype_t *type, size_t sz, bool nofinalizer);
+#define cvalue(type, sz) cvalue_(type, sz, false)
+#define cvalue_nofinalizer(type, sz) cvalue_(type, sz, true)
+value_t cvalue_from_ref(fltype_t *type, void *ptr, size_t sz, value_t parent);
+value_t cvalue_string(size_t sz);
+value_t cvalue_static_cstring(const char *str);
+value_t string_from_cstrn(char *str, size_t n);
+value_t string_from_cstr(char *str);
+int fl_isstring(value_t v) fl_purefn;
+void cv_pin(cvalue_t *cv);
+value_t mk_mpint(mpint *n);
+value_t size_wrap(size_t sz);
+size_t tosize(value_t n);
+off_t tooffset(value_t n);
+int isarray(value_t v) fl_purefn;
+int cvalue_array_init(fltype_t *ft, value_t arg, void *dest);
+size_t cvalue_arraylen(value_t v) fl_purefn;
+size_t ctype_sizeof(value_t type);
+void to_sized_ptr(value_t v, uint8_t **pdata, size_t *psz);
+value_t cvalue_relocate(value_t v);
+value_t cvalue_copy(value_t v);
+value_t cvalue_compare(value_t a, value_t b) fl_purefn;
+value_t cvalue_array_aref(value_t *args);
+value_t cvalue_array_aset(value_t *args);
+value_t cbuiltin(const char *name, builtin_t f);
+value_t return_from_uint64(uint64_t Uaccum);
+value_t return_from_int64(int64_t Saccum);
+value_t fl_add_any(value_t *args, uint32_t nargs);
+value_t fl_neg(value_t n);
+value_t fl_mul_any(value_t *args, uint32_t nargs);
+int num_to_ptr(value_t a, fixnum_t *pi, numerictype_t *pt, void **pp);
+_Noreturn void DivideByZeroError(void);
+value_t fl_div2(value_t a, value_t b);
+value_t fl_idiv2(value_t a, value_t b);
+void cvalues_init(void);
+
+value_t mk_double(double n);
+value_t mk_float(float n);
+value_t mk_int32(int32_t n);
+value_t mk_uint32(uint32_t n);
+value_t mk_int64(int64_t n);
+value_t mk_uint64(uint64_t n);
+value_t mk_rune(Rune n);
+
+/* builtins.c */
+size_t llength(value_t v) fl_purefn;
--- /dev/null
+++ b/src/docs_extra.lsp
@@ -1,0 +1,35 @@
+(define-macro (doc-for term (doc #f))
+ (let* ((sym (or (and (cons? term) (car term)) term))
+ (val (top-level-value sym))
+ (funvars (and (cons? term) (cdr term))))
+ (if (not funvars)
+ (when (function? val)
+ (error "docs: " sym ": no funvars specified"))
+ (unless (function? val)
+ (error "docs: " sym ": funvars set but isn't a function")))
+ `(symbol-set-doc ',sym ',doc ',funvars)))
+
+(doc-for (= a . rest)
+ "Return #t if the arguments are equal.")
+
+(doc-for (nan? x)
+ "Return #t if the argument is NaN, regardless of the sign.")
+
+(doc-for (vm-stats)
+ "Print various VM-related information, such as the number of GC calls
+so far, heap and stack size, etc.")
+
+(doc-for (lz-pack data (level 0))
+ "Return data compressed using Lempel-Ziv.
+The data must be an array, returned value will have the same type.
+The optional level is between 0 and 10. With level 0 a simple LZSS
+using hashing will be performed. Levels between 1 and 9 offer a
+trade-off between time/space and ratio. Level 10 is optimal but very
+slow.")
+
+(doc-for (lz-unpack data :to destination))
+(doc-for (lz-unpack data :size decompressed-bytes)
+ "Return decompressed data previously compressed using lz-pack.
+Either destination for the decompressed data or the expected size of
+the decompressed data must be specified. In the latter case a new
+array is allocated.")
--- /dev/null
+++ b/src/dos/platform.h
@@ -1,0 +1,56 @@
+#pragma once
+
+#define _XOPEN_SOURCE 700
+#include <assert.h>
+#include <ctype.h>
+#include <machine/endian.h>
+#include <errno.h>
+#include <fcntl.h>
+#include <float.h>
+#include <inttypes.h>
+#include <limits.h>
+#include <locale.h>
+#include <math.h>
+#include <setjmp.h>
+#include <stdbool.h>
+#include <stdarg.h>
+#include <stdio.h>
+#include <stddef.h>
+#include <stdint.h>
+#include <stdlib.h>
+#include <string.h>
+#include <strings.h>
+#include <sys/stat.h>
+#include <sys/time.h>
+#include <time.h>
+#include <unistd.h>
+#include <wctype.h>
+#include <wchar.h>
+
+#define __os_name__ "dos"
+
+#define nil NULL
+#define USED(x) ((void)(x))
+#define nelem(x) (int)(sizeof(x)/sizeof((x)[0]))
+
+#define PATHSEP '\\'
+#define PATHSEPSTRING "\\"
+#define PATHLISTSEP ':'
+#define PATHLISTSEPSTRING ":"
+#define ISPATHSEP(c) ((c) == '\\')
+
+#if !defined(INITIAL_HEAP_SIZE)
+#define INITIAL_HEAP_SIZE 4*1024*1024
+#endif
+#if !defined(ALLOC_LIMIT_TRIGGER)
+#define ALLOC_LIMIT_TRIGGER INITIAL_HEAP_SIZE
+#endif
+
+#define MEM_UNALIGNED_ACCESS
+
+#include "cc.h"
+#include "mem.h"
+#include "mp.h"
+#include "utf.h"
+
+int wcwidth(Rune c) fl_constfn;
--- /dev/null
+++ b/src/dos/sys.c
@@ -1,0 +1,52 @@
+#include "flisp.h"
+#include "timefuncs.h"
+
+double
+sec_realtime(void)
+{+ return 0.0;
+}
+
+uint64_t
+nanosec_monotonic(void)
+{+ return 0;
+}
+
+void
+timestring(double s, char *buf, int sz)
+{+ time_t tme = (time_t)s;
+ struct tm tm;
+
+ localtime_r(&tme, &tm);
+ strftime(buf, sz, "%c", &tm);
+}
+
+double
+parsetime(const char *s)
+{+ return -1;
+}
+
+void
+sleep_ms(int ms)
+{+ if(ms != 0){+ struct timeval timeout;
+ timeout.tv_sec = ms/1000;
+ timeout.tv_usec = (ms % 1000) * 1000;
+ select(0, nil, nil, nil, &timeout);
+ }
+}
+
+static const uint8_t boot[] = {+#include "flisp.boot.h"
+};
+
+int
+main(int argc, char **argv)
+{+ setlocale(LC_NUMERIC, "C");
+ flmain(boot, sizeof(boot), argc, argv);
+}
--- /dev/null
+++ b/src/equal.c
@@ -1,0 +1,422 @@
+#include "flisp.h"
+#include "operators.h"
+#include "cvalues.h"
+#include "equal.h"
+#include "hashing.h"
+
+#define BOUNDED_COMPARE_BOUND 128
+#define BOUNDED_HASH_BOUND 16384
+
+#if defined(BITS64)
+#define MIX(a, b) inthash((value_t)(a) ^ (value_t)(b));
+#define doublehash(a) inthash(a)
+#else
+#define MIX(a, b) int64to32hash((uint64_t)(a)<<32 | (uint64_t)(b));
+#define doublehash(a) int64to32hash(a)
+#endif
+
+// comparable tag
+#define cmptag(v) (isfixnum(v) ? TAG_NUM : tag(v))
+
+static value_t
+eq_class(htable_t *table, value_t key)
+{+ value_t c = (value_t)ptrhash_get(table, (void*)key);
+ if(c == (value_t)HT_NOTFOUND)
+ return FL_nil;
+ if(c == key)
+ return c;
+ return eq_class(table, c);
+}
+
+static void
+eq_union(htable_t *table, value_t a, value_t b, value_t c, value_t cb)
+{+ value_t ca = c == FL_nil ? a : c;
+ if(cb != FL_nil)
+ ptrhash_put(table, (void*)cb, (void*)ca);
+ ptrhash_put(table, (void*)a, (void*)ca);
+ ptrhash_put(table, (void*)b, (void*)ca);
+}
+
+static value_t bounded_compare(value_t a, value_t b, int bound, bool eq);
+static value_t cyc_compare(value_t a, value_t b, htable_t *table, bool eq);
+
+static value_t
+bounded_vector_compare(value_t a, value_t b, int bound, bool eq)
+{+ size_t la = vector_size(a);
+ size_t lb = vector_size(b);
+ size_t m, i;
+ if(eq && la != lb)
+ return fixnum(1);
+ m = la < lb ? la : lb;
+ for(i = 0; i < m; i++){+ value_t d = bounded_compare(vector_elt(a, i), vector_elt(b, i), bound-1, eq);
+ if(d == FL_nil || numval(d) != 0)
+ return d;
+ }
+ if(la < lb)
+ return fixnum(-1);
+ if(la > lb)
+ return fixnum(1);
+ return fixnum(0);
+}
+
+// strange comparisons are resolved arbitrarily but consistently.
+// ordering: number < cprim < function < vector < cvalue < symbol < cons
+static value_t
+bounded_compare(value_t a, value_t b, int bound, bool eq)
+{+ value_t d;
+ cvalue_t *cv;
+
+compare_top:
+ if(a == b)
+ return fixnum(0);
+ if(bound <= 0)
+ return FL_nil;
+ int taga = tag(a);
+ int tagb = cmptag(b);
+ int c;
+ switch(taga){+ case TAG_NUM :
+ case TAG_NUM1:
+ if(isfixnum(b))
+ return (fixnum_t)a < (fixnum_t)b ? fixnum(-1) : fixnum(1);
+ if(iscprim(b)){+ if(cp_class(ptr(b)) == FL(runetype))
+ return fixnum(1);
+ return fixnum(numeric_compare(a, b, eq, true, false));
+ }
+ if(iscvalue(b)){+ cv = ptr(b);
+ if(valid_numtype(cv_class(cv)->numtype))
+ return fixnum(numeric_compare(a, b, eq, true, false));
+ }
+ return fixnum(-1);
+ case TAG_SYM:
+ if(eq || tagb < TAG_SYM)
+ return fixnum(1);
+ if(tagb > TAG_SYM)
+ return fixnum(-1);
+ return fixnum(strcmp(symbol_name(a), symbol_name(b)));
+ case TAG_VECTOR:
+ if(isvector(b))
+ return bounded_vector_compare(a, b, bound, eq);
+ break;
+ case TAG_CPRIM:
+ if(cp_class(ptr(a)) == FL(runetype)){+ if(!iscprim(b) || cp_class(ptr(b)) != FL(runetype))
+ return fixnum(-1);
+ }else if(iscprim(b) && cp_class(ptr(b)) == FL(runetype))
+ return fixnum(1);
+ c = numeric_compare(a, b, eq, true, false);
+ if(c != 2)
+ return fixnum(c);
+ break;
+ case TAG_CVALUE:
+ cv = ptr(a);
+ if(valid_numtype(cv_class(cv)->numtype)){+ if((c = numeric_compare(a, b, eq, true, false)) != 2)
+ return fixnum(c);
+ }
+ if(iscvalue(b)){+ if(cv_isPOD(ptr(a)) && cv_isPOD(ptr(b)))
+ return cvalue_compare(a, b);
+ return fixnum(1);
+ }
+ break;
+ case TAG_FUNCTION:
+ if(tagb == TAG_FUNCTION){+ if(uintval(a) > N_BUILTINS && uintval(b) > N_BUILTINS){+ function_t *fa = ptr(a);
+ function_t *fb = ptr(b);
+ d = bounded_compare(fa->bcode, fb->bcode, bound-1, eq);
+ if(d == FL_nil || numval(d) != 0)
+ return d;
+ d = bounded_compare(fa->vals, fb->vals, bound-1, eq);
+ if(d == FL_nil || numval(d) != 0)
+ return d;
+ d = bounded_compare(fa->env, fb->env, bound-1, eq);
+ if(d == FL_nil || numval(d) != 0)
+ return d;
+ return fixnum(0);
+ }
+ return uintval(a) < uintval(b) ? fixnum(-1) : fixnum(1);
+ }
+ break;
+ case TAG_CONS:
+ if(tagb < TAG_CONS)
+ return fixnum(1);
+ d = bounded_compare(car_(a), car_(b), bound-1, eq);
+ if(d == FL_nil || numval(d) != 0)
+ return d;
+ a = cdr_(a); b = cdr_(b);
+ bound--;
+ goto compare_top;
+ }
+ return taga < tagb ? fixnum(-1) : fixnum(1);
+}
+
+static value_t
+cyc_vector_compare(value_t a, value_t b, htable_t *table, bool eq)
+{+ size_t la = vector_size(a);
+ size_t lb = vector_size(b);
+ size_t m, i;
+ value_t d, xa, xb, ca, cb;
+
+ // first try to prove them different with no recursion
+ if(eq && la != lb)
+ return fixnum(1);
+ m = la < lb ? la : lb;
+ for(i = 0; i < m; i++){+ xa = vector_elt(a, i);
+ xb = vector_elt(b, i);
+ if(leafp(xa) || leafp(xb)){+ d = bounded_compare(xa, xb, 1, eq);
+ if(d != FL_nil && numval(d) != 0)
+ return d;
+ }else if(tag(xa) < tag(xb))
+ return fixnum(-1);
+ else if(tag(xa) > tag(xb))
+ return fixnum(1);
+ }
+
+ ca = eq_class(table, a);
+ cb = eq_class(table, b);
+ if(ca != FL_nil && ca == cb)
+ return fixnum(0);
+
+ eq_union(table, a, b, ca, cb);
+
+ for(i = 0; i < m; i++){+ xa = vector_elt(a, i);
+ xb = vector_elt(b, i);
+ if(!leafp(xa) || tag(xa) == TAG_FUNCTION){+ d = cyc_compare(xa, xb, table, eq);
+ if(numval(d) != 0)
+ return d;
+ }
+ }
+
+ if(la < lb)
+ return fixnum(-1);
+ if(la > lb)
+ return fixnum(1);
+ return fixnum(0);
+}
+
+static value_t
+cyc_compare(value_t a, value_t b, htable_t *table, bool eq)
+{+ value_t d, ca, cb;
+cyc_compare_top:
+ if(a == b)
+ return fixnum(0);
+ if(iscons(a)){+ if(iscons(b)){+ value_t aa = car_(a);
+ value_t da = cdr_(a);
+ value_t ab = car_(b);
+ value_t db = cdr_(b);
+ int tagaa = tag(aa);
+ int tagda = tag(da);
+ int tagab = tag(ab);
+ int tagdb = tag(db);
+ if(leafp(aa) || leafp(ab)){+ d = bounded_compare(aa, ab, 1, eq);
+ if(d != FL_nil && numval(d) != 0)
+ return d;
+ }
+ if(tagaa < tagab)
+ return fixnum(-1);
+ if(tagaa > tagab)
+ return fixnum(1);
+ if(leafp(da) || leafp(db)){+ d = bounded_compare(da, db, 1, eq);
+ if(d != FL_nil && numval(d) != 0)
+ return d;
+ }
+ if(tagda < tagdb)
+ return fixnum(-1);
+ if(tagda > tagdb)
+ return fixnum(1);
+
+ ca = eq_class(table, a);
+ cb = eq_class(table, b);
+ if(ca != FL_nil && ca == cb)
+ return fixnum(0);
+
+ eq_union(table, a, b, ca, cb);
+ d = cyc_compare(aa, ab, table, eq);
+ if(numval(d) != 0)
+ return d;
+ a = da;
+ b = db;
+ goto cyc_compare_top;
+ }else{+ return fixnum(1);
+ }
+ }
+ if(isvector(a) && isvector(b))
+ return cyc_vector_compare(a, b, table, eq);
+ if(isclosure(a) && isclosure(b)){+ function_t *fa = (function_t*)ptr(a);
+ function_t *fb = (function_t*)ptr(b);
+ d = bounded_compare(fa->bcode, fb->bcode, 1, eq);
+ if(numval(d) != 0)
+ return d;
+
+ ca = eq_class(table, a);
+ cb = eq_class(table, b);
+ if(ca != FL_nil && ca == cb)
+ return fixnum(0);
+
+ eq_union(table, a, b, ca, cb);
+ d = cyc_compare(fa->vals, fb->vals, table, eq);
+ if(numval(d) != 0)
+ return d;
+ a = fa->env;
+ b = fb->env;
+ goto cyc_compare_top;
+ }
+ return bounded_compare(a, b, 1, eq);
+}
+
+static htable_t equal_eq_hashtable;
+
+void
+comparehash_init(void)
+{+ htable_new(&equal_eq_hashtable, 512);
+}
+
+// 'eq' means unordered comparison is sufficient
+value_t
+fl_compare(value_t a, value_t b, bool eq)
+{+ value_t guess = bounded_compare(a, b, BOUNDED_COMPARE_BOUND, eq);
+ if(guess == FL_nil){+ guess = cyc_compare(a, b, &equal_eq_hashtable, eq);
+ htable_reset(&equal_eq_hashtable, 512);
+ }
+ return guess;
+}
+
+/*
+ optimizations:
+ - use hash updates instead of calling lookup then insert. i.e. get the
+ bp once and use it twice.
+ * preallocate hash table and call reset() instead of new/free
+ * less redundant tag checking, 3-bit tags
+*/
+
+// *oob: output argument, means we hit the limit specified by 'bound'
+static uintptr_t
+bounded_hash(value_t a, int bound, int *oob)
+{+ *oob = 0;
+ union {+ double d;
+ int64_t i64;
+ }u;
+ numerictype_t nt;
+ size_t i, len;
+ cvalue_t *cv;
+ cprim_t *cp;
+ void *data;
+ uintptr_t h = 0;
+ int oob2, tg = tag(a);
+
+ switch(tg){+ case TAG_NUM :
+ case TAG_NUM1:
+ u.d = (double)numval(a);
+ return doublehash(u.i64);
+ case TAG_FUNCTION:
+ if(uintval(a) > N_BUILTINS)
+ return bounded_hash(((function_t*)ptr(a))->bcode, bound, oob);
+ return inthash(a);
+ case TAG_SYM:
+ return ((symbol_t*)ptr(a))->hash;
+ case TAG_CPRIM:
+ cp = ptr(a);
+ data = cp_data(cp);
+ if(cp_class(cp) == FL(runetype))
+ return inthash(*(Rune*)data);
+ nt = cp_numtype(cp);
+ u.d = conv_to_double(data, nt);
+ return doublehash(u.i64);
+ case TAG_CVALUE:
+ cv = ptr(a);
+ data = cv_data(cv);
+ if(cv->type == FL(mpinttype)){+ len = mptobe(*(mpint**)data, nil, 0, (uint8_t**)&data);
+ h = memhash(data, len);
+ MEM_FREE(data);
+ }else{+ h = memhash(data, cv_len(cv));
+ }
+ return h;
+
+ case TAG_VECTOR:
+ if(bound <= 0){+ *oob = 1;
+ return 1;
+ }
+ len = vector_size(a);
+ for(i = 0; i < len; i++){+ h = MIX(h, bounded_hash(vector_elt(a, i), bound/2, &oob2)^1);
+ if(oob2)
+ bound /= 2;
+ *oob = *oob || oob2;
+ }
+ return h;
+
+ case TAG_CONS:
+ do{+ if(bound <= 0){+ *oob = 1;
+ return h;
+ }
+ h = MIX(h, bounded_hash(car_(a), bound/2, &oob2));
+ // bounds balancing: try to share the bounds efficiently
+ // so we can hash better when a list is cdr-deep (a common case)
+ if(oob2)
+ bound /= 2;
+ else
+ bound--;
+ // recursive OOB propagation. otherwise this case is slow:
+ // (hash '#2=((#0=(#1=(#1#) . #0#)) . #2#))
+ *oob = *oob || oob2;
+ a = cdr_(a);
+ }while(iscons(a));
+ h = MIX(h, bounded_hash(a, bound-1, &oob2)^2);
+ *oob = *oob || oob2;
+ return h;
+ }
+ return 0;
+}
+
+int
+equal_lispvalue(value_t a, value_t b)
+{+ if(eq_comparable(a, b))
+ return a == b;
+ return numval(fl_compare(a, b, true)) == 0;
+}
+
+uintptr_t
+hash_lispvalue(value_t a)
+{+ int oob = 0;
+ return bounded_hash(a, BOUNDED_HASH_BOUND, &oob);
+}
+
+BUILTIN("hash", hash)+{+ argcount(nargs, 1);
+ return fixnum(hash_lispvalue(args[0]));
+}
--- /dev/null
+++ b/src/equal.h
@@ -1,0 +1,11 @@
+#pragma once
+
+// comparable with ==
+#define eq_comparable(a, b) (!(((a)|(b))&1))
+#define eq_comparablep(a) (!((a)&1)) /* mag: UNUSED? */
+
+int equal_lispvalue(value_t a, value_t b);
+uintptr_t hash_lispvalue(value_t a);
+value_t fl_compare(value_t a, value_t b, bool eq);
+int numeric_compare(value_t a, value_t b, bool eq, bool eqnans, bool typeerr);
+void comparehash_init(void);
--- /dev/null
+++ b/src/equalhash.c
@@ -1,0 +1,9 @@
+#include "flisp.h"
+#include "equalhash.h"
+#include "equal.h"
+
+#define HTNAME(suffix) equalhash##suffix
+#define HFUNC(v) hash_lispvalue((value_t)(v))
+#define EQFUNC(x, y) equal_lispvalue((value_t)(x), (value_t)(y))
+
+#include "htable.inc"
--- /dev/null
+++ b/src/equalhash.h
@@ -1,0 +1,2 @@
+#include "htableh.inc"
+HTPROT(equalhash)
--- /dev/null
+++ b/src/fl_arith_any.inc
@@ -1,0 +1,158 @@
+//value_t
+//fl_*_any(value_t *args, uint32_t nargs)
+// input: ACCUM_DEFAULT ARITH_OP(a,b) MP_OP ARITH_OVERFLOW
+// add: 0 a+b mpadd sadd_overflow_64
+// mul: 1 a*b mpmul smul_overflow_64
+
+ mpint *Maccum = nil, *m = nil;
+ int64_t Saccum = ACCUM_DEFAULT, x;
+ uint64_t u64;
+ double Faccum = ACCUM_DEFAULT;
+ bool inexact = false;
+ value_t arg;
+ numerictype_t pt;
+ void *a;
+ cprim_t *cp;
+ cvalue_t *cv;
+
+ uint32_t i, j;
+ FOR_ARGS(i, 0, arg, args){+ if(isfixnum(arg))
+ x = numval(arg);
+ else{+ if(iscprim(arg)){+ cp = ptr(arg);
+ a = cp_data(cp);
+ pt = cp_numtype(cp);
+ }else if(iscvalue(arg)){+ cv = ptr(arg);
+ a = cv_data(cv);
+ pt = cv_class(cv)->numtype;
+ }else{+typeerr:
+ mpfree(Maccum);
+ mpfree(m);
+ type_error("number", arg);+ }
+ switch(pt){+ case T_DOUBLE: Faccum = ARITH_OP(Faccum, *(double*)a); inexact = true; continue;
+ case T_FLOAT: Faccum = ARITH_OP(Faccum, *(float*)a); inexact = true; continue;
+ case T_INT8: x = *(int8_t*)a; break;
+ case T_UINT8: x = *(uint8_t*)a; break;
+ case T_INT16: x = *(int16_t*)a; break;
+ case T_UINT16: x = *(uint16_t*)a; break;
+ case T_INT32: x = *(int32_t*)a; break;
+ case T_UINT32: x = *(uint32_t*)a; break;
+ case T_INT64: x = *(int64_t*)a; break;
+ case T_UINT64:
+ u64 = *(uint64_t*)a;
+ if(u64 > INT64_MAX){+ x = ACCUM_DEFAULT;
+ goto overflow;
+ }
+ x = u64;
+ break;
+ case T_MPINT:
+ x = ACCUM_DEFAULT;
+ u64 = ACCUM_DEFAULT;
+ m = mpcopy(*(mpint**)a);
+ goto overflow;
+ default:
+ goto typeerr;
+ }
+ }
+
+ int64_t accu;
+ if(ARITH_OVERFLOW(Saccum, x, &accu)){+ u64 = ACCUM_DEFAULT;
+ goto overflow;
+ }
+ Saccum = accu;
+ }
+
+ if(inexact)
+ return mk_double(ARITH_OP(Faccum, Saccum));
+ if(fits_fixnum(Saccum))
+ return fixnum((fixnum_t)Saccum);
+ u64 = ACCUM_DEFAULT;
+ x = ACCUM_DEFAULT;
+
+overflow:
+ i++;
+ if(Maccum == nil)
+ Maccum = vtomp(Saccum, nil);
+ if(m == nil)
+ m = u64 != ACCUM_DEFAULT ? uvtomp(u64, nil) : vtomp(x, nil);
+
+ MP_OP(Maccum, m, Maccum);
+
+ FOR_ARGS(j, i, arg, args){+ if(isfixnum(arg)){+ vtomp(numval(arg), m);
+ MP_OP(Maccum, m, Maccum);
+ continue;
+ }
+
+ if(iscprim(arg)){+ cp = ptr(arg);
+ a = cp_data(cp);
+ pt = cp_numtype(cp);
+ }else if(iscvalue(arg)){+ cv = ptr(arg);
+ a = cv_data(cv);
+ pt = cv_class(cv)->numtype;
+ }else{+ goto typeerr;
+ }
+ switch(pt){+ case T_DOUBLE: Faccum = ARITH_OP(Faccum, *(double*)a); inexact = true; continue;
+ case T_FLOAT: Faccum = ARITH_OP(Faccum, *(float*)a); inexact = true; continue;
+ case T_INT8: x = *(int8_t*)a; break;
+ case T_UINT8: x = *(uint8_t*)a; break;
+ case T_INT16: x = *(int16_t*)a; break;
+ case T_UINT16: x = *(uint16_t*)a; break;
+ case T_INT32: x = *(int32_t*)a; break;
+ case T_UINT32: x = *(uint32_t*)a; break;
+ case T_INT64: x = *(int64_t*)a; break;
+ case T_UINT64:
+ uvtomp(*(uint64_t*)a, m);
+ MP_OP(Maccum, m, Maccum);
+ continue;
+ case T_MPINT:
+ MP_OP(Maccum, *(mpint**)a, Maccum);
+ continue;
+ default:
+ goto typeerr;
+ }
+ vtomp(x, m);
+ MP_OP(Maccum, m, Maccum);
+ }
+
+ int n = mpsignif(Maccum);
+ if(n >= FIXNUM_BITS){+ if(inexact){+ dtomp(Faccum, m);
+ MP_OP(Maccum, m, Maccum);
+ n = mpsignif(Maccum);
+ if(n < FIXNUM_BITS){+ inexact = false;
+ goto down;
+ }
+ }
+ mpfree(m);
+ return mk_mpint(Maccum);
+ }
+
+down:
+ mpfree(m);
+ Saccum = mptov(Maccum);
+ mpfree(Maccum);
+ if(inexact)
+ return mk_double(ARITH_OP(Faccum, Saccum));
+ assert(fits_fixnum(Saccum));
+ return fixnum((fixnum_t)Saccum);
+
+#undef ACCUM_DEFAULT
+#undef ARITH_OP
+#undef MP_OP
+#undef ARITH_OVERFLOW
--- /dev/null
+++ b/src/flisp.c
@@ -1,0 +1,1448 @@
+/*
+ femtoLisp
+
+ by Jeff Bezanson (C) 2009
+ Distributed under the BSD License
+*/
+
+#include "flisp.h"
+#include "operators.h"
+#include "cvalues.h"
+#include "types.h"
+#include "print.h"
+#include "read.h"
+#include "timefuncs.h"
+#include "equal.h"
+#include "hashing.h"
+#include "table.h"
+#include "iostream.h"
+#include "compress.h"
+
+value_t FL_builtins_table_sym, FL_quote, FL_lambda, FL_function, FL_comma, FL_commaat;
+value_t FL_commadot, FL_trycatch, FL_backquote;
+value_t FL_conssym, FL_symbolsym, FL_fixnumsym, FL_vectorsym, FL_builtinsym, FL_vu8sym;
+value_t FL_definesym, FL_defmacrosym, FL_forsym, FL_setqsym;
+value_t FL_tsym, FL_Tsym, FL_fsym, FL_Fsym, FL_booleansym, FL_nullsym, FL_evalsym, FL_fnsym;
+value_t FL_nulsym, FL_alarmsym, FL_backspacesym, FL_tabsym, FL_linefeedsym, FL_newlinesym;
+value_t FL_vtabsym, FL_pagesym, FL_returnsym, FL_escsym, FL_spacesym, FL_deletesym;
+value_t FL_IOError, FL_ParseError, FL_TypeError, FL_ArgError, FL_MemoryError;
+value_t FL_DivideError, FL_BoundsError, FL_Error, FL_KeyError, FL_EnumerationError;
+value_t FL_UnboundError;
+value_t FL_sizesym, FL_tosym;
+
+value_t FL_printwidthsym, FL_printreadablysym, FL_printprettysym, FL_printlengthsym;
+value_t FL_printlevelsym;
+value_t FL_tablesym, FL_arraysym;
+value_t FL_iostreamsym, FL_rdsym, FL_wrsym, FL_apsym, FL_crsym, FL_truncsym;
+value_t FL_instrsym, FL_outstrsym;
+value_t FL_int8sym, FL_uint8sym, FL_int16sym, FL_uint16sym, FL_int32sym, FL_uint32sym;
+value_t FL_int64sym, FL_uint64sym, FL_bignumsym;
+value_t FL_bytesym, FL_runesym, FL_floatsym, FL_doublesym;
+value_t FL_stringtypesym, FL_runestringtypesym;
+
+fl_thread(Fl *fl);
+
+typedef struct {+ const char *name;
+ builtin_t fptr;
+}builtinspec_t;
+
+bool
+isbuiltin(value_t x)
+{+ uint32_t i;
+ return tag(x) == TAG_FUNCTION && (i = uintval(x)) < nelem(builtins) && builtins[i].name != nil;
+}
+
+static value_t apply_cl(uint32_t nargs) fl_hotfn;
+
+// error utilities ------------------------------------------------------------
+
+void
+free_readstate(fl_readstate_t *rs)
+{+ htable_free(&rs->backrefs);
+ htable_free(&rs->gensyms);
+}
+
+_Noreturn void
+fl_exit(int status)
+{+ FL(exiting) = true;
+ fl_gc(0);
+ exit(status);
+}
+
+#define FL_TRY \
+ fl_exception_context_t _ctx; int l__tr, l__ca; \
+ _ctx.sp = FL(sp); _ctx.frame = FL(curr_frame); _ctx.rdst = FL(readstate); _ctx.prev = FL(exctx); \
+ _ctx.ngchnd = FL(ngchandles); FL(exctx) = &_ctx; \
+ if(!setjmp(_ctx.buf)) \
+ for(l__tr = 1; l__tr; l__tr = 0, (void)(FL(exctx) = FL(exctx)->prev))
+
+#define FL_CATCH_INC \
+ l__ca = 0, FL(lasterror) = FL_nil, FL(throwing_frame) = 0, FL(sp) = _ctx.sp, FL(curr_frame) = _ctx.frame
+
+#define FL_CATCH \
+ else \
+ for(l__ca = 1; l__ca; FL_CATCH_INC)
+
+#define FL_CATCH_NO_INC \
+ else \
+ for(l__ca = 1; l__ca;)
+
+void
+fl_savestate(fl_exception_context_t *_ctx)
+{+ _ctx->sp = FL(sp);
+ _ctx->frame = FL(curr_frame);
+ _ctx->rdst = FL(readstate);
+ _ctx->prev = FL(exctx);
+ _ctx->ngchnd = FL(ngchandles);
+}
+
+void
+fl_restorestate(fl_exception_context_t *_ctx)
+{+ FL(lasterror) = FL_nil;
+ FL(throwing_frame) = 0;
+ FL(sp) = _ctx->sp;
+ FL(curr_frame) = _ctx->frame;
+}
+
+_Noreturn void
+fl_raise(value_t e)
+{+ ios_flush(ios_stdout);
+ ios_flush(ios_stderr);
+
+ FL(lasterror) = e;
+ // unwind read state
+ while(FL(readstate) != FL(exctx)->rdst){+ free_readstate(FL(readstate));
+ FL(readstate) = FL(readstate)->prev;
+ }
+ if(FL(throwing_frame) == 0)
+ FL(throwing_frame) = FL(curr_frame);
+ FL(ngchandles) = FL(exctx)->ngchnd;
+ fl_exception_context_t *thisctx = FL(exctx);
+ if(FL(exctx)->prev) // don't throw past toplevel
+ FL(exctx) = FL(exctx)->prev;
+ longjmp(thisctx->buf, 1);
+}
+
+_Noreturn void
+lerrorf(value_t e, const char *format, ...)
+{+ char msgbuf[256];
+ va_list args;
+
+ PUSH(e);
+ va_start(args, format);
+ vsnprintf(msgbuf, sizeof(msgbuf), format, args);
+ value_t msg = string_from_cstr(msgbuf);
+ va_end(args);
+
+ e = POP();
+ fl_raise(fl_list2(e, msg));
+}
+
+_Noreturn void
+type_error(const char *expected, value_t got)
+{+ fl_raise(fl_listn(3, FL_TypeError, symbol(expected, false), got));
+}
+
+_Noreturn void
+bounds_error(value_t arr, value_t ind)
+{+ fl_raise(fl_listn(3, FL_BoundsError, arr, ind));
+}
+
+_Noreturn void
+unbound_error(value_t sym)
+{+ fl_raise(fl_listn(2, FL_UnboundError, sym));
+}
+
+// safe cast operators --------------------------------------------------------
+
+#define isstring fl_isstring
+#define SAFECAST_OP(type, ctype, cnvt) \
+ ctype to##type(value_t v) \
+ { \+ if(fl_likely(is##type(v))) \
+ return (ctype)cnvt(v); \
+ type_error(#type, v); \
+ }
+SAFECAST_OP(cons, cons_t*, ptr)
+SAFECAST_OP(symbol, symbol_t*, ptr)
+SAFECAST_OP(fixnum, fixnum_t, numval)
+//SAFECAST_OP(cvalue, cvalue_t*, ptr)
+SAFECAST_OP(string, char*, cvalue_data)
+#undef isstring
+
+// symbol table ---------------------------------------------------------------
+
+static symbol_t *
+mk_symbol(const char *str, int len, bool copy)
+{+ symbol_t *sym = MEM_ALLOC(sizeof(*sym) + (copy ? len+1 : 0));
+ sym->numtype = NONNUMERIC;
+ if(str[0] == ':' && str[1] != 0){+ value_t s = tagptr(sym, TAG_SYM);
+ sym->flags = FLAG_KEYWORD;
+ setc(s, s);
+ }else{+ sym->binding = UNBOUND;
+ sym->flags = 0;
+ }
+ sym->type = nil;
+ sym->hash = memhash32(str, len)^0xAAAAAAAA;
+ if(copy){+ memcpy((char*)(sym+1), str, len+1);
+ sym->name = (const char*)(sym+1);
+ }else{+ sym->name = str;
+ }
+ sym->size = 0;
+ return sym;
+}
+
+value_t
+symbol(const char *str, bool copy)
+{+ int len = strlen(str);
+ symbol_t *v;
+ const char *k;
+ if(!Tgetkv(FL(symtab), str, len, &k, (void**)&v)){+ v = mk_symbol(str, len, copy);
+ FL(symtab) = Tsetl(FL(symtab), v->name, len, v);
+ }
+ return tagptr(v, TAG_SYM);
+}
+
+BUILTIN("gensym", gensym)+{+ argcount(nargs, 0);
+ USED(args);
+ gensym_t *gs = alloc_words(sizeof(gensym_t)/sizeof(value_t));
+ gs->id = FL(gensym_ctr)++;
+ gs->binding = UNBOUND;
+ gs->type = nil;
+ return tagptr(gs, TAG_SYM);
+}
+
+value_t
+gensym(void)
+{+ return fn_builtin_gensym(nil, 0);
+}
+
+fl_purefn
+BUILTIN("gensym?", gensymp)+{+ argcount(nargs, 1);
+ return isgensym(args[0]) ? FL_t : FL_f;
+}
+
+char *
+uint2str(char *dest, size_t len, uint64_t num, uint32_t base)
+{+ int i = len-1;
+ uint64_t b = (uint64_t)base;
+ char ch;
+ dest[i--] = '\0';
+ while(i >= 0){+ ch = (char)(num % b);
+ if(ch < 10)
+ ch += '0';
+ else
+ ch = ch-10+'a';
+ dest[i--] = ch;
+ num /= b;
+ if(num == 0)
+ break;
+ }
+ return &dest[i+1];
+}
+
+const char *
+symbol_name(value_t v)
+{+ if(ismanaged(v)){+ gensym_t *gs = (gensym_t*)ptr(v);
+ FL(gsnameno) = 1-FL(gsnameno);
+ char *n = uint2str(FL(gsname)[FL(gsnameno)]+1, sizeof(FL(gsname)[0])-1, gs->id, 10);
+ *(--n) = 'g';
+ return n;
+ }
+ return ((symbol_t*)ptr(v))->name;
+}
+
+// conses ---------------------------------------------------------------------
+
+value_t
+mk_cons(void)
+{+ cons_t *c;
+
+ if(fl_unlikely(FL(curheap) > FL(lim)))
+ fl_gc(0);
+ c = (cons_t*)FL(curheap);
+ FL(curheap) += sizeof(cons_t);
+ return tagptr(c, TAG_CONS);
+}
+
+void *
+alloc_words(uint32_t n)
+{+ value_t *first;
+
+ assert(n > 0);
+ n = ALIGNED(n, 2); // only allocate multiples of 2 words
+ if(fl_unlikely((value_t*)FL(curheap) > (value_t*)FL(lim)+2-n)){+ fl_gc(0);
+ while((value_t*)FL(curheap) > ((value_t*)FL(lim))+2-n)
+ fl_gc(1);
+ }
+ first = (value_t*)FL(curheap);
+ FL(curheap) += n*sizeof(value_t);
+ return first;
+}
+
+value_t
+alloc_vector(size_t n, int init)
+{+ if(n == 0)
+ return FL(the_empty_vector);
+ value_t *c = alloc_words(n+1);
+ value_t v = tagptr(c, TAG_VECTOR);
+ vector_setsize(v, n);
+ if(init){+ unsigned int i;
+ for(i = 0; i < n; i++)
+ vector_elt(v, i) = FL_void;
+ }
+ return v;
+}
+
+// collector ------------------------------------------------------------------
+
+void
+fl_gc_handle(value_t *pv)
+{+ if(fl_unlikely(FL(ngchandles) >= N_GC_HANDLES))
+ lerrorf(FL_MemoryError, "out of gc handles");
+ FL(gchandles)[FL(ngchandles)++] = pv;
+}
+
+void
+fl_free_gc_handles(uint32_t n)
+{+ assert(FL(ngchandles) >= n);
+ FL(ngchandles) -= n;
+}
+
+value_t
+relocate(value_t v)
+{+ value_t a, d, nc, first, *pcdr;
+
+ if(isfixnum(v))
+ return v;
+
+ uintptr_t t = tag(v);
+ if(t == TAG_CONS){+ // iterative implementation allows arbitrarily long cons chains
+ pcdr = &first;
+ do{+ if((a = car_(v)) == TAG_FWD){+ *pcdr = cdr_(v);
+ return first;
+ }
+ car_(v) = TAG_FWD;
+ d = cdr_(v);
+ *pcdr = nc = tagptr((cons_t*)FL(curheap), TAG_CONS);
+ FL(curheap) += sizeof(cons_t);
+ cdr_(v) = nc;
+ car_(nc) = relocate(a);
+ pcdr = &cdr_(nc);
+ v = d;
+ }while(iscons(v));
+ *pcdr = d == FL_nil ? FL_nil : relocate(d);
+ return first;
+ }
+
+ if(!ismanaged(v))
+ return v;
+ if(isforwarded(v))
+ return forwardloc(v);
+
+ if(t == TAG_CVALUE)
+ return cvalue_relocate(v);
+ if(t == TAG_CPRIM){+ cprim_t *pcp = ptr(v);
+ size_t nw = CPRIM_NWORDS-1+NWORDS(cp_class(pcp)->size);
+ cprim_t *ncp = alloc_words(nw);
+ while(nw--)
+ ((value_t*)ncp)[nw] = ((value_t*)pcp)[nw];
+ nc = tagptr(ncp, TAG_CPRIM);
+ forward(v, nc);
+ return nc;
+ }
+ if(t == TAG_FUNCTION){+ function_t *fn = ptr(v);
+ function_t *nfn = alloc_words(4);
+ nfn->bcode = fn->bcode;
+ nfn->vals = fn->vals;
+ nc = tagptr(nfn, TAG_FUNCTION);
+ forward(v, nc);
+ nfn->env = relocate(fn->env);
+ nfn->vals = relocate(nfn->vals);
+ nfn->bcode = relocate(nfn->bcode);
+ assert(!ismanaged(fn->name));
+ nfn->name = fn->name;
+ return nc;
+ }
+ if(t == TAG_VECTOR){+ // N.B.: 0-length vectors secretly have space for a first element
+ size_t i, sz = vector_size(v);
+ if(vector_elt(v, -1) & 0x1){+ // grown vector
+ nc = relocate(vector_elt(v, 0));
+ forward(v, nc);
+ }else{+ nc = tagptr(alloc_words(sz+1), TAG_VECTOR);
+ vector_setsize(nc, sz);
+ a = vector_elt(v, 0);
+ forward(v, nc);
+ if(sz > 0){+ vector_elt(nc, 0) = relocate(a);
+ for(i = 1; i < sz; i++)
+ vector_elt(nc, i) = relocate(vector_elt(v, i));
+ }
+ }
+ return nc;
+ }
+ if(t == TAG_SYM){+ gensym_t *gs = ptr(v);
+ gensym_t *ng = alloc_words(sizeof(gensym_t)/sizeof(value_t));
+ ng->id = gs->id;
+ ng->binding = gs->binding;
+ nc = tagptr(ng, TAG_SYM);
+ forward(v, nc);
+ if(fl_likely(ng->binding != UNBOUND))
+ ng->binding = relocate(ng->binding);
+ return nc;
+ }
+ return v;
+}
+
+static void
+trace_globals(void)
+{+ const char *k = nil;
+ symbol_t *v;
+ while(Tnext(FL(symtab), &k, (void**)&v)){+ if(v->binding != UNBOUND)
+ v->binding = relocate(v->binding);
+ }
+}
+
+void
+fl_gc(int mustgrow)
+{+ void *temp;
+ uint32_t i, f, top;
+ fl_readstate_t *rs;
+
+ FL(gccalls)++;
+ FL(curheap) = FL(tospace);
+ if(FL(grew))
+ FL(lim) = FL(curheap)+FL(heapsize)*2-sizeof(cons_t);
+ else
+ FL(lim) = FL(curheap)+FL(heapsize)-sizeof(cons_t);
+
+ if(FL(throwing_frame) > FL(curr_frame)){+ top = FL(throwing_frame) - 3;
+ f = FL(stack)[FL(throwing_frame)-3];
+ }else{+ top = FL(sp);
+ f = FL(curr_frame);
+ }
+ while(1){+ for(i = f; i < top; i++)
+ FL(stack)[i] = relocate(FL(stack)[i]);
+ if(f == 0)
+ break;
+ top = f - 3;
+ f = FL(stack)[f-3];
+ }
+ for(i = 0; i < FL(ngchandles); i++)
+ *FL(gchandles)[i] = relocate(*FL(gchandles)[i]);
+ trace_globals();
+ relocate_typetable();
+ rs = FL(readstate);
+ while(rs){+ value_t ent;
+ for(i = 0; i < rs->backrefs.size; i++){+ ent = (value_t)rs->backrefs.table[i];
+ if(ent != (value_t)HT_NOTFOUND)
+ rs->backrefs.table[i] = (void*)relocate(ent);
+ }
+ for(i = 0; i < rs->gensyms.size; i++){+ ent = (value_t)rs->gensyms.table[i];
+ if(ent != (value_t)HT_NOTFOUND)
+ rs->gensyms.table[i] = (void*)relocate(ent);
+ }
+ rs->source = relocate(rs->source);
+ rs = rs->prev;
+ }
+ FL(lasterror) = relocate(FL(lasterror));
+ FL(memory_exception_value) = relocate(FL(memory_exception_value));
+ FL(the_empty_vector) = relocate(FL(the_empty_vector));
+ FL(the_empty_string) = relocate(FL(the_empty_string));
+
+ sweep_finalizers();
+
+#if defined(VERBOSEGC)
+ printf("GC: found %d/%d live conses\n",+ (FL(curheap)-FL(tospace))/sizeof(cons_t), FL(heapsize)/sizeof(cons_t));
+#endif
+ temp = FL(tospace);
+ FL(tospace) = FL(fromspace);
+ FL(fromspace) = temp;
+
+ // if we're using > 80% of the space, resize tospace so we have
+ // more space to fill next time. if we grew tospace last time,
+ // grow the other half of the heap this time to catch up.
+ if(FL(grew) || ((intptr_t)(FL(lim)-FL(curheap)) < (intptr_t)FL(heapsize)/5) || mustgrow){+ temp = MEM_REALLOC(FL(tospace), FL(heapsize)*2);
+ if(fl_unlikely(temp == nil))
+ fl_raise(FL(memory_exception_value));
+ FL(tospace) = temp;
+ if(FL(grew)){+ FL(heapsize) *= 2;
+ temp = bitvector_resize(FL(consflags), 0, FL(heapsize)/sizeof(cons_t), 1);
+ if(fl_unlikely(temp == nil))
+ fl_raise(FL(memory_exception_value));
+ FL(consflags) = (uint32_t*)temp;
+ }
+ FL(grew) = !FL(grew);
+ }
+ if(fl_unlikely((value_t*)FL(curheap) > (value_t*)FL(lim)-2)){+ // all data was live; gc again and grow heap.
+ // but also always leave at least 4 words available, so a closure
+ // can be allocated without an extra check.
+ fl_gc(0);
+ }
+}
+
+void
+fl_grow_stack(void)
+{+ size_t newsz = FL(nstack) * 2;
+ value_t *ns = MEM_REALLOC(FL(stack), newsz*sizeof(value_t));
+ if(fl_unlikely(ns == nil))
+ lerrorf(FL_MemoryError, "stack overflow");
+ FL(stack) = ns;
+ FL(nstack) = newsz;
+}
+
+// utils ----------------------------------------------------------------------
+
+// apply function with n args on the stack
+fl_hotfn
+static value_t
+_applyn(uint32_t n)
+{+ value_t f = FL(stack)[FL(sp)-n-1];
+ uint32_t saveSP = FL(sp);
+ value_t v;
+ if(iscbuiltin(f))
+ v = ((builtin_t*)ptr(f))[3](&FL(stack)[FL(sp)-n], n);
+ else if(isfunction(f))
+ v = apply_cl(n);
+ else if(fl_likely(isbuiltin(f))){+ value_t tab = symbol_value(FL_builtins_table_sym);
+ if(fl_unlikely(ptr(tab) == nil))
+ unbound_error(tab);
+ FL(stack)[FL(sp)-n-1] = vector_elt(tab, uintval(f));
+ v = apply_cl(n);
+ }else{+ type_error("function", f);+ }
+ FL(sp) = saveSP;
+ return v;
+}
+
+value_t
+fl_apply(value_t f, value_t l)
+{+ value_t v = l;
+ uint32_t n = FL(sp);
+
+ PUSH(f);
+ while(iscons(v)){+ PUSHSAFE(car_(v));
+ v = cdr_(v);
+ }
+ if(v != FL_nil)
+ lerrorf(FL_ArgError, "apply: last argument: not a list");
+ n = FL(sp) - n - 1;
+ v = _applyn(n);
+ POPN(n+1);
+ return v;
+}
+
+value_t
+fl_applyn(uint32_t n, value_t f, ...)
+{+ va_list ap;
+ va_start(ap, f);
+ size_t i;
+
+ PUSH(f);
+ while(FL(sp)+n >= FL(nstack))
+ fl_grow_stack();
+ for(i = 0; i < n; i++){+ value_t a = va_arg(ap, value_t);
+ PUSH(a);
+ }
+ value_t v = _applyn(n);
+ POPN(n+1);
+ va_end(ap);
+ return v;
+}
+
+value_t
+fl_listn(size_t n, ...)
+{+ va_list ap;
+ va_start(ap, n);
+ uint32_t si = FL(sp);
+ size_t i;
+
+ while(FL(sp)+n >= FL(nstack))
+ fl_grow_stack();
+ for(i = 0; i < n; i++){+ value_t a = va_arg(ap, value_t);
+ PUSH(a);
+ }
+ cons_t *c = alloc_words(n*2);
+ cons_t *l = c;
+ for(i = 0; i < n; i++){+ c->car = FL(stack)[si++];
+ c->cdr = tagptr(c+1, TAG_CONS);
+ c++;
+ }
+ c[-1].cdr = FL_nil;
+
+ POPN(n);
+ va_end(ap);
+ return tagptr(l, TAG_CONS);
+}
+
+value_t
+fl_list2(value_t a, value_t b)
+{+ PUSH(a);
+ PUSH(b);
+ cons_t *c = alloc_words(4);
+ b = POP();
+ a = POP();
+ c[0].car = a;
+ c[0].cdr = tagptr(c+1, TAG_CONS);
+ c[1].car = b;
+ c[1].cdr = FL_nil;
+ return tagptr(c, TAG_CONS);
+}
+
+value_t
+fl_cons(value_t a, value_t b)
+{+ PUSH(a);
+ PUSH(b);
+ value_t c = mk_cons();
+ cdr_(c) = POP();
+ car_(c) = POP();
+ return c;
+}
+
+bool
+fl_isnumber(value_t v)
+{+ if(isfixnum(v))
+ return true;
+ if(iscprim(v)){+ cprim_t *c = ptr(v);
+ return c->type != FL(runetype) && valid_numtype(c->type->numtype);
+ }
+ if(iscvalue(v)){+ cvalue_t *c = ptr(v);
+ return valid_numtype(cp_numtype(c));
+ }
+ return false;
+}
+
+// eval -----------------------------------------------------------------------
+
+fl_hotfn
+static value_t
+list(value_t *args, uint32_t nargs, int star)
+{+ cons_t *c;
+ uint32_t i;
+ value_t v;
+ v = cons_reserve(nargs);
+ c = ptr(v);
+ for(i = 0; i < nargs; i++){+ c->car = args[i];
+ c->cdr = tagptr(c+1, TAG_CONS);
+ c++;
+ }
+ if(star)
+ c[-2].cdr = c[-1].car;
+ else
+ c[-1].cdr = FL_nil;
+ return v;
+}
+
+static value_t
+copy_list(value_t L)
+{+ if(!iscons(L))
+ return FL_nil;
+ PUSH(FL_nil);
+ PUSH(L);
+ value_t *plcons = &FL(stack)[FL(sp)-2];
+ value_t *pL = &FL(stack)[FL(sp)-1];
+ value_t c;
+ c = mk_cons(); PUSH(c); // save first cons
+ car_(c) = car_(*pL);
+ cdr_(c) = FL_nil;
+ *plcons = c;
+ *pL = cdr_(*pL);
+ while(iscons(*pL)){+ c = mk_cons();
+ car_(c) = car_(*pL);
+ cdr_(c) = FL_nil;
+ cdr_(*plcons) = c;
+ *plcons = c;
+ *pL = cdr_(*pL);
+ }
+ c = POP(); // first cons
+ POPN(2);
+ return c;
+}
+
+static value_t
+do_trycatch(void)
+{+ uint32_t saveSP = FL(sp);
+ value_t v = FL_nil;
+ value_t thunk = FL(stack)[FL(sp)-2];
+ FL(stack)[FL(sp)-2] = FL(stack)[FL(sp)-1];
+ FL(stack)[FL(sp)-1] = thunk;
+
+ FL_TRY{+ v = apply_cl(0);
+ }
+ FL_CATCH{+ v = FL(stack)[saveSP-2];
+ PUSH(v);
+ PUSH(FL(lasterror));
+ v = apply_cl(1);
+ }
+ FL(sp) = saveSP;
+ return v;
+}
+
+/*
+ argument layout on stack is
+ |--required args--|--opt args--|--kw args--|--rest args...
+*/
+static uint32_t
+process_keys(value_t kwtable, uint32_t nreq, uint32_t nkw, uint32_t nopt, uint32_t bp, uint32_t nargs, int va)
+{+ uint32_t extr = nopt+nkw;
+ uint32_t ntot = nreq+extr;
+ value_t args[64], v = FL_nil;
+ uint32_t i, a = 0, nrestargs;
+ value_t s1 = FL(stack)[FL(sp)-1];
+ value_t s3 = FL(stack)[FL(sp)-3];
+ value_t s4 = FL(stack)[FL(sp)-4];
+ if(fl_unlikely(nargs < nreq))
+ lerrorf(FL_ArgError, "too few arguments");
+ if(fl_unlikely(extr > nelem(args)))
+ lerrorf(FL_ArgError, "too many arguments");
+ for(i = 0; i < extr; i++)
+ args[i] = UNBOUND;
+ for(i = nreq; i < nargs; i++){+ v = FL(stack)[bp+i];
+ if(issymbol(v) && iskeyword((symbol_t*)ptr(v)))
+ break;
+ if(a >= nopt)
+ goto no_kw;
+ args[a++] = v;
+ }
+ if(i >= nargs)
+ goto no_kw;
+ // now process keywords
+ uintptr_t n = vector_size(kwtable)/2;
+ do{+ i++;
+ if(fl_unlikely(i >= nargs))
+ lerrorf(FL_ArgError, "keyword %s requires an argument", symbol_name(v));
+ value_t hv = fixnum(((symbol_t*)ptr(v))->hash);
+ fixnum_t lx = numval(hv);
+ uintptr_t x = 2*((lx < 0 ? -lx : lx) % n);
+ if(fl_likely(vector_elt(kwtable, x) == v)){+ uintptr_t idx = numval(vector_elt(kwtable, x+1));
+ assert(idx < nkw);
+ idx += nopt;
+ if(args[idx] == UNBOUND){+ // if duplicate key, keep first value
+ args[idx] = FL(stack)[bp+i];
+ }
+ }else{+ lerrorf(FL_ArgError, "unsupported keyword %s", symbol_name(v));
+ }
+ i++;
+ if(i >= nargs)
+ break;
+ v = FL(stack)[bp+i];
+ }while(issymbol(v) && iskeyword((symbol_t*)ptr(v)));
+no_kw:
+ nrestargs = nargs - i;
+ if(fl_unlikely(!va && nrestargs > 0))
+ lerrorf(FL_ArgError, "too many arguments");
+ nargs = ntot + nrestargs;
+ if(nrestargs)
+ memmove(&FL(stack)[bp+ntot], &FL(stack)[bp+i], nrestargs*sizeof(value_t));
+ memmove(&FL(stack)[bp+nreq], args, extr*sizeof(value_t));
+ FL(sp) = bp + nargs;
+ assert(FL(sp) < FL(nstack)-4);
+ PUSH(s4);
+ PUSH(s3);
+ PUSH(nargs);
+ PUSH(s1);
+ FL(curr_frame) = FL(sp);
+ return nargs;
+}
+
+#if BYTE_ORDER == LITTLE_ENDIAN && defined(MEM_UNALIGNED_ACCESS)
+#define GET_INT32(a) *(const int32_t*)(a)
+#define GET_INT16(a) *(const int16_t*)(a)
+#define PUT_INT32(a, i) \
+ do{ \+ *(uint32_t*)(a) = (uint32_t)(i); \
+ }while(0)
+#else
+#define GET_INT32(a) (int32_t)((a)[0]<<0 | (a)[1]<<8 | (a)[2]<<16 | (uint32_t)(a)[3]<<24)
+#define GET_INT16(a) (int16_t)((a)[0]<<0 | (a)[1]<<8)
+#define PUT_INT32(a, i) \
+ do{ \+ ((uint8_t*)(a))[0] = (uint32_t)(i)>>0; \
+ ((uint8_t*)(a))[1] = (uint32_t)(i)>>8; \
+ ((uint8_t*)(a))[2] = (uint32_t)(i)>>16; \
+ ((uint8_t*)(a))[3] = (uint32_t)(i)>>24; \
+ }while(0)
+#endif
+
+/*
+ stack on entry: <func> <nargs args...>
+ caller's responsibility:
+ - put the stack in this state
+ - provide arg count
+ - respect tail position
+ - restore SP
+
+ callee's responsibility:
+ - check arg counts
+ - allocate vararg array
+ - push closed env, set up new environment
+*/
+static value_t
+apply_cl(uint32_t nargs)
+{+ uint32_t top_frame = FL(curr_frame);
+ uint32_t n, bp;
+ const uint8_t *ip;
+ fixnum_t s, hi;
+ bool tail;
+
+ // temporary variables (not necessary to preserve across calls)
+ size_t isz;
+ uint32_t i, ipd;
+ symbol_t *sym;
+ cons_t *c;
+ value_t *pv;
+ value_t func, v, e;
+ int x;
+
+ n = 0;
+ v = 0;
+ USED(n);
+ USED(v);
+apply_cl_top:
+ bp = FL(sp)-nargs;
+ func = FL(stack)[bp-1];
+ ip = cvalue_data(fn_bcode(func));
+ assert(!ismanaged((uintptr_t)ip));
+ i = FL(sp)+GET_INT32(ip);
+ while(i >= FL(nstack))
+ fl_grow_stack();
+ ip += 4;
+
+ PUSH(fn_env(func));
+ PUSH(FL(curr_frame));
+ PUSH(nargs);
+ ipd = FL(sp);
+ FL(sp)++; // ip
+ FL(curr_frame) = FL(sp);
+
+#if defined(COMPUTED_GOTO)
+#pragma GCC diagnostic push
+#pragma GCC diagnostic ignored "-Wpedantic"
+ static const void * const ops[] = {+#define GOTO_OP_OFFSET(op) [op] = &&op_##op
+#include "vm_goto.inc"
+#undef GOTO_OP_OFFSET
+ };
+#define NEXT_OP goto *ops[*ip++]
+#define LABEL(x) x
+#define OP(x) op_##x:
+ NEXT_OP;
+#include "vm.inc"
+#undef OP
+#undef LABEL
+#undef NEXT_OP
+#pragma GCC diagnostic pop
+#else /* just a usual (portable) switch/case */
+ uint8_t op = *ip++;
+ while(1){+ switch(op){+#define NEXT_OP break
+#define LABEL(x) x
+#define OP(x) case x:
+#include "vm.inc"
+#undef OP
+#undef LABEL
+#undef NEXT_OP
+ }
+ op = *ip++;
+ }
+#endif
+}
+
+#define SWAP_INT32(a)
+#define SWAP_INT16(a)
+#include "maxstack.inc"
+
+#if BYTE_ORDER == BIG_ENDIAN
+#undef SWAP_INT32
+#undef SWAP_INT16
+#define SWAP_INT32(a) \
+ do{ \+ uint8_t *x = (void*)a, y; \
+ y = x[0]; x[0] = x[3]; x[3] = y; \
+ y = x[1]; x[1] = x[2]; x[2] = y; \
+ }while(0)
+#define SWAP_INT16(a) \
+ do{ \+ uint8_t *x = (void*)a, y; \
+ y = x[0]; x[0] = x[1]; x[1] = y; \
+ }while(0)
+#define compute_maxstack compute_maxstack_swap
+#include "maxstack.inc"
+#undef compute_maxstack
+#else
+#endif
+
+// top = top frame pointer to start at
+static value_t
+_stacktrace(uint32_t top)
+{+ value_t lst = FL_nil;
+
+ fl_gc_handle(&lst);
+ while(top > 0){+ const uint8_t *ip1 = (void*)FL(stack)[top-1];
+ uint32_t sz = FL(stack)[top-2]+1;
+ uint32_t bp = top-4-sz;
+ value_t func = FL(stack)[bp];
+ const uint8_t *ip0 = cvalue_data(fn_bcode(func));
+ intptr_t ip = ip1 - ip0 - 1; /* -1: ip1 is *after* the one that was being executed */
+ value_t v = alloc_vector(sz+1, 0);
+ vector_elt(v, 0) = fixnum(ip);
+ vector_elt(v, 1) = func;
+ for(uint32_t i = 1; i < sz; i++){+ value_t si = FL(stack)[bp+i];
+ // if there's an error evaluating argument defaults some slots
+ // might be left set to UNBOUND
+ vector_elt(v, i+1) = si == UNBOUND ? FL_void : si;
+ }
+ lst = fl_cons(v, lst);
+ top = FL(stack)[top-3];
+ }
+ fl_free_gc_handles(1);
+ return lst;
+}
+
+// builtins -------------------------------------------------------------------
+
+BUILTIN("gc", gc)+{+ USED(args);
+ argcount(nargs, 0);
+ fl_gc(0);
+ return FL_void;
+}
+
+BUILTIN("function", function)+{+ if(nargs == 1 && issymbol(args[0]))
+ return fn_builtin_builtin(args, nargs);
+ if(nargs < 2 || nargs > 4)
+ argcount(nargs, 2);
+ if(fl_unlikely(!fl_isstring(args[0])))
+ type_error("string", args[0]);+ if(fl_unlikely(!isvector(args[1])))
+ type_error("vector", args[1]);+ cvalue_t *arr = ptr(args[0]);
+ cv_pin(arr);
+ char *data = cv_data(arr);
+ int ms;
+ if((uint8_t)data[4] >= N_OPCODES){+ // read syntax, shifted 48 for compact text representation
+ size_t i, sz = cv_len(arr);
+ for(i = 0; i < sz; i++)
+ data[i] -= 48;
+#if BYTE_ORDER == BIG_ENDIAN
+ ms = compute_maxstack((uint8_t*)data, cv_len(arr));
+ }else{+ ms = compute_maxstack_swap((uint8_t*)data, cv_len(arr));
+ }
+#else
+ }
+ ms = compute_maxstack((uint8_t*)data, cv_len(arr));
+#endif
+ if(ms < 0)
+ lerrorf(FL_ArgError, "invalid bytecode");
+ PUT_INT32(data, ms);
+ function_t *fn = alloc_words(4);
+ value_t fv = tagptr(fn, TAG_FUNCTION);
+ fn->bcode = args[0];
+ fn->vals = args[1];
+ fn->env = FL_nil;
+ fn->name = FL_lambda;
+ if(nargs > 2){+ if(issymbol(args[2])){+ fn->name = args[2];
+ if(nargs > 3)
+ fn->env = args[3];
+ }else{+ fn->env = args[2];
+ if(nargs > 3){+ if(fl_unlikely(!issymbol(args[3])))
+ type_error("symbol", args[3]);+ fn->name = args[3];
+ }
+ }
+ if(fl_unlikely(isgensym(fn->name)))
+ lerrorf(FL_ArgError, "name should not be a gensym");
+ }
+ return fv;
+}
+
+fl_purefn
+BUILTIN("function:code", function_code)+{+ argcount(nargs, 1);
+ value_t v = args[0];
+ if(fl_unlikely(!isclosure(v)))
+ type_error("function", v);+ return fn_bcode(v);
+}
+
+fl_purefn
+BUILTIN("function:vals", function_vals)+{+ argcount(nargs, 1);
+ value_t v = args[0];
+ if(fl_unlikely(!isclosure(v)))
+ type_error("function", v);+ return fn_vals(v);
+}
+
+fl_purefn
+BUILTIN("function:env", function_env)+{+ argcount(nargs, 1);
+ value_t v = args[0];
+ if(fl_unlikely(!isclosure(v)))
+ type_error("function", v);+ return fn_env(v);
+}
+
+BUILTIN("function:name", function_name)+{+ argcount(nargs, 1);
+ value_t v = args[0];
+ if(isclosure(v))
+ return fn_name(v);
+ if(isbuiltin(v))
+ return symbol(builtins[uintval(v)].name, false);
+ if(iscbuiltin(v)){+ v = (value_t)ptrhash_get(&FL(reverse_dlsym_lookup_table), ptr(v));
+ if(v == (value_t)HT_NOTFOUND)
+ return FL_f;
+ return v;
+ }
+ type_error("function", v);+}
+
+BUILTIN("copy-list", copy_list)+{+ argcount(nargs, 1);
+ return copy_list(args[0]);
+}
+
+BUILTIN("append", append)+{+ value_t first = FL_nil, lst, lastcons = FL_nil;
+ uint32_t i;
+ if(nargs == 0)
+ return FL_nil;
+ fl_gc_handle(&first);
+ fl_gc_handle(&lastcons);
+ for(i = 0; i < nargs; i++){+ lst = args[i];
+ if(iscons(lst)){+ lst = copy_list(lst);
+ if(first == FL_nil)
+ first = lst;
+ else
+ cdr_(lastcons) = lst;
+ lastcons = tagptr((((cons_t*)FL(curheap))-1), TAG_CONS);
+ }else if(lst != FL_nil){+ type_error("cons", lst);+ }
+ }
+ fl_free_gc_handles(2);
+ return first;
+}
+
+BUILTIN("list*", liststar)+{+ if(nargs == 1)
+ return args[0];
+ if(nargs == 0)
+ argcount(nargs, 1);
+ return list(args, nargs, 1);
+}
+
+BUILTIN("stacktrace", stacktrace)+{+ USED(args);
+ argcount(nargs, 0);
+ return _stacktrace(FL(throwing_frame) ? FL(throwing_frame) : FL(curr_frame));
+}
+
+BUILTIN("map", map)+{+ if(fl_unlikely(nargs < 2))
+ lerrorf(FL_ArgError, "too few arguments");
+ intptr_t argSP = args-FL(stack);
+ assert(argSP >= 0 && argSP < (intptr_t)FL(nstack));
+ while(FL(sp)+2+1+nargs >= FL(nstack))
+ fl_grow_stack();
+ uint32_t k = FL(sp);
+ PUSH(FL_nil);
+ PUSH(FL_nil);
+ for(bool first = true;;){+ PUSH(FL(stack)[argSP]);
+ for(uint32_t i = 1; i < nargs; i++){+ if(!iscons(FL(stack)[argSP+i])){+ POPN(2+i);
+ return FL(stack)[k+1];
+ }
+ PUSH(car(FL(stack)[argSP+i]));
+ FL(stack)[argSP+i] = cdr_(FL(stack)[argSP+i]);
+ }
+ value_t v = _applyn(nargs-1);
+ POPN(nargs);
+ PUSH(v);
+ value_t c = mk_cons();
+ car_(c) = POP(); cdr_(c) = FL_nil;
+ if(first)
+ FL(stack)[k+1] = c;
+ else
+ cdr_(FL(stack)[k]) = c;
+ FL(stack)[k] = c;
+ first = false;
+ }
+}
+
+BUILTIN("for-each", for_each)+{+ if(fl_unlikely(nargs < 2))
+ lerrorf(FL_ArgError, "too few arguments");
+ intptr_t argSP = args-FL(stack);
+ assert(argSP >= 0 && argSP < (intptr_t)FL(nstack));
+ if(FL(sp)+1+2*nargs >= FL(nstack))
+ fl_grow_stack();
+ for(size_t n = 0;; n++){+ PUSH(FL(stack)[argSP]);
+ uint32_t pargs = 0;
+ for(uint32_t i = 1; i < nargs; i++, pargs++){+ value_t v = FL(stack)[argSP+i];
+ if(iscons(v)){+ PUSH(car_(v));
+ FL(stack)[argSP+i] = cdr_(v);
+ continue;
+ }
+ if(isvector(v)){+ size_t sz = vector_size(v);
+ if(n < sz){+ PUSH(vector_elt(v, n));
+ continue;
+ }
+ }
+ if(isarray(v)){+ size_t sz = cvalue_arraylen(v);
+ if(n < sz){+ value_t a[2];
+ a[0] = v;
+ a[1] = fixnum(n);
+ PUSH(cvalue_array_aref(a));
+ continue;
+ }
+ }
+ if(ishashtable(v)){+ htable_t *h = totable(v);
+ assert(n != 0 || h->i == 0);
+ void **table = h->table;
+ for(; h->i < h->size; h->i += 2){+ if(table[h->i+1] != HT_NOTFOUND)
+ break;
+ }
+ if(h->i < h->size){+ PUSH((value_t)table[h->i]);
+ pargs++;
+ PUSH((value_t)table[h->i+1]);
+ h->i += 2;
+ continue;
+ }
+ h->i = 0;
+ }
+ POPN(pargs+1);
+ return FL_void;
+ }
+ _applyn(pargs);
+ POPN(pargs+1);
+ }
+}
+
+BUILTIN("sleep", fl_sleep)+{+ if(nargs > 1)
+ argcount(nargs, 1);
+ double s = nargs > 0 ? todouble(args[0]) : 0;
+ sleep_ms(s * 1000.0);
+ return FL_void;
+}
+
+BUILTIN("vm-stats", vm_stats)+{+ USED(args);
+ argcount(nargs, 0);
+ ios_printf(ios_stderr, "heap total %10"PRIuPTR"\n", FL(heapsize));
+ ios_printf(ios_stderr, "heap free %10"PRIuPTR"\n", (uintptr_t)(FL(lim)-FL(curheap)));
+ ios_printf(ios_stderr, "heap used %10"PRIuPTR"\n", (uintptr_t)(FL(curheap)-FL(fromspace)));
+ ios_printf(ios_stderr, "stack %10"PRIu64"\n", (uint64_t)FL(nstack)*sizeof(value_t));
+ ios_printf(ios_stderr, "gc calls %10"PRIu64"\n", (uint64_t)FL(gccalls));
+ ios_printf(ios_stderr, "max finalizers %10"PRIu32"\n", (uint32_t)FL(maxfinalizers));
+ ios_printf(ios_stderr, "opcodes %10d\n", N_OPCODES);
+ return FL_void;
+}
+
+static const builtinspec_t builtin_fns[] = {+#define BUILTIN_FN(l, c, attr){l, (builtin_t)fn_builtin_##c},+#include "builtin_fns.h"
+#undef BUILTIN_FN
+};
+
+// initialization -------------------------------------------------------------
+
+int
+fl_init(size_t initial_heapsize)
+{+ int i;
+
+ if((fl = MEM_CALLOC(1, sizeof(*fl))) == nil)
+ return -1;
+ FL(scr_width) = 100;
+
+ FL(heapsize) = initial_heapsize;
+
+ if((FL(fromspace) = MEM_ALLOC(FL(heapsize))) == nil){+failed:
+ MEM_FREE(FL(fromspace));
+ MEM_FREE(FL(tospace));
+ MEM_FREE(FL(consflags));
+ MEM_FREE(FL(stack));
+ htable_free(&FL(printconses));
+ MEM_FREE(fl);
+ return -1;
+ }
+ if((FL(tospace) = MEM_ALLOC(FL(heapsize))) == nil)
+ goto failed;
+ if((FL(consflags) = bitvector_new(FL(heapsize)/sizeof(cons_t), 1)) == nil)
+ goto failed;
+ if((htable_new(&FL(printconses), 32)) == nil)
+ goto failed;
+ FL(curheap) = FL(fromspace);
+ FL(lim) = FL(curheap)+FL(heapsize)-sizeof(cons_t);
+ FL(nstack) = 4096;
+ if((FL(stack) = MEM_ALLOC(FL(nstack)*sizeof(value_t))) == nil)
+ goto failed;
+ comparehash_init();
+
+ FL_lambda = symbol("λ", false);+ FL_function = symbol("function", false);+ FL_quote = symbol("quote", false);+ FL_trycatch = symbol("trycatch", false);+ FL_backquote = symbol("quasiquote", false);+ FL_comma = symbol("unquote", false);+ FL_commaat = symbol("unquote-splicing", false);+ FL_commadot = symbol("unquote-nsplicing", false);+ FL_IOError = symbol("io-error", false);+ FL_ParseError = symbol("parse-error", false);+ FL_TypeError = symbol("type-error", false);+ FL_ArgError = symbol("arg-error", false);+ FL_UnboundError = symbol("unbound-error", false);+ FL_KeyError = symbol("key-error", false);+ FL_MemoryError = symbol("memory-error", false);+ FL_BoundsError = symbol("bounds-error", false);+ FL_DivideError = symbol("divide-error", false);+ FL_EnumerationError = symbol("enumeration-error", false);+ FL_Error = symbol("error", false);+ FL_conssym = symbol("cons", false);+ FL_symbolsym = symbol("symbol", false);+ FL_fixnumsym = symbol("fixnum", false);+ FL_vectorsym = symbol("vector", false);+ FL_builtinsym = symbol("builtin", false);+ FL_booleansym = symbol("boolean", false);+ FL_nullsym = symbol("null", false);+ FL_definesym = symbol("define", false);+ FL_defmacrosym = symbol("define-macro", false);+ FL_forsym = symbol("for", false);+ FL_setqsym = symbol("set!", false);+ FL_evalsym = symbol("eval", false);+ FL_vu8sym = symbol("vu8", false);+ FL_fnsym = symbol("fn", false);+ FL_nulsym = symbol("nul", false);+ FL_alarmsym = symbol("alarm", false);+ FL_backspacesym = symbol("backspace", false);+ FL_tabsym = symbol("tab", false);+ FL_linefeedsym = symbol("linefeed", false);+ FL_vtabsym = symbol("vtab", false);+ FL_pagesym = symbol("page", false);+ FL_returnsym = symbol("return", false);+ FL_escsym = symbol("esc", false);+ FL_spacesym = symbol("space", false);+ FL_deletesym = symbol("delete", false);+ FL_newlinesym = symbol("newline", false);+ FL_tsym = symbol("t", false);+ FL_Tsym = symbol("T", false);+ FL_fsym = symbol("f", false);+ FL_Fsym = symbol("F", false);+ FL_builtins_table_sym = symbol("*builtins*", false);+
+ set(FL_printprettysym = symbol("*print-pretty*", false), FL_t);+ set(FL_printreadablysym = symbol("*print-readably*", false), FL_t);+ set(FL_printwidthsym = symbol("*print-width*", false), fixnum(FL(scr_width)));+ set(FL_printlengthsym = symbol("*print-length*", false), FL_f);+ set(FL_printlevelsym = symbol("*print-level*", false), FL_f);+ FL(lasterror) = FL_nil;
+
+ for(i = 0; i < nelem(builtins); i++){+ if(builtins[i].name)
+ set(symbol(builtins[i].name, false), builtin(i));
+ }
+ set(symbol("procedure?", false), builtin(OP_FUNCTIONP));+ set(symbol("top-level-bound?", false), builtin(OP_BOUNDP));+
+ FL(the_empty_vector) = tagptr(alloc_words(1), TAG_VECTOR);
+ vector_setsize(FL(the_empty_vector), 0);
+
+ cvalues_init();
+
+ set(symbol("*os-name*", false), cvalue_static_cstring(__os_name__));+#if defined(__os_version__)
+ set(symbol("*os-version*", false), cvalue_static_cstring(__os_version__));+#endif
+ FL(memory_exception_value) = fl_list2(FL_MemoryError, cvalue_static_cstring("out of memory"));+
+ const builtinspec_t *b;
+ for(i = 0, b = builtin_fns; i < nelem(builtin_fns); i++, b++)
+ set(symbol(b->name, false), cbuiltin(b->name, b->fptr));
+ table_init();
+ iostream_init();
+ compress_init();
+ return 0;
+}
+
+// top level ------------------------------------------------------------------
+
+value_t
+fl_toplevel_eval(value_t expr)
+{+ return fl_applyn(1, symbol_value(FL_evalsym), expr);
+}
+
+int
+fl_load_system_image(value_t sys_image_iostream)
+{+ value_t e;
+ uint32_t saveSP;
+ symbol_t *sym;
+
+ PUSH(sys_image_iostream);
+ saveSP = FL(sp);
+ FL_TRY{+ while(1){+ e = fl_read_sexpr(FL(stack)[FL(sp)-1]);
+ if(ios_eof(value2c(ios_t*, FL(stack)[FL(sp)-1])))
+ break;
+ if(isfunction(e)){+ // stage 0 format: series of thunks
+ PUSH(e);
+ (void)_applyn(0);
+ FL(sp) = saveSP;
+ }else{+ // stage 1 format: list alternating symbol/value
+ while(iscons(e)){+ sym = tosymbol(car_(e));
+ e = cdr_(e);
+ (void)tocons(e);
+ sym->binding = car_(e);
+ e = cdr_(e);
+ }
+ break;
+ }
+ }
+ }
+ FL_CATCH_NO_INC{+ ios_puts(ios_stderr, "fatal error during bootstrap: ");
+ fl_print(ios_stderr, FL(lasterror));
+ ios_putc(ios_stderr, '\n');
+ return 1;
+ }
+ ios_close(value2c(ios_t*, FL(stack)[FL(sp)-1]));
+ POPN(1);
+ return 0;
+}
--- /dev/null
+++ b/src/flisp.h
@@ -1,0 +1,452 @@
+#pragma once
+
+#include "platform.h"
+#include "utf8.h"
+#include "ios.h"
+#include "tbl.h"
+#include "bitvector.h"
+#include "htableh.inc"
+HTPROT(ptrhash)
+
+typedef struct fltype_t fltype_t;
+
+enum {+ TAG_NUM,
+ TAG_CPRIM,
+ TAG_FUNCTION,
+ TAG_VECTOR,
+ TAG_NUM1,
+ TAG_CVALUE,
+ TAG_SYM,
+ TAG_CONS,
+
+ /* those were set to 7 and 3 strategically on purpose */
+ TAG_NONLEAF_MASK = TAG_CONS & TAG_VECTOR,
+};
+
+enum {+ FLAG_CONST = 1<<0,
+ FLAG_KEYWORD = 1<<1,
+};
+
+typedef enum {+ T_INT8, T_UINT8,
+ T_INT16, T_UINT16,
+ T_INT32, T_UINT32,
+ T_INT64, T_UINT64,
+ T_MPINT,
+ T_FLOAT,
+ T_DOUBLE,
+}numerictype_t;
+
+typedef uintptr_t value_t;
+
+#ifdef BITS64
+typedef int64_t fixnum_t;
+#define FIXNUM_BITS 62
+#define TOP_BIT (1ULL<<63)
+#define T_FIXNUM T_INT64
+#define PRIdFIXNUM PRId64
+#else
+typedef int32_t fixnum_t;
+#define FIXNUM_BITS 30
+#define TOP_BIT (1U<<31)
+#define T_FIXNUM T_INT32
+#define PRIdFIXNUM PRId32
+#endif
+
+#define ALIGNED(x, sz) (((x) + (sz-1)) & (-sz))
+
+typedef struct {+ value_t car;
+ value_t cdr;
+}fl_aligned(8) cons_t;
+
+// NOTE: symbol_t MUST have the same fields as gensym_t first
+// there are places where gensyms are treated as normal symbols
+typedef struct {+ fltype_t *type;
+ value_t binding; // global value binding
+ uint32_t hash;
+ uint8_t numtype;
+ uint8_t size;
+ uint8_t flags;
+ uint8_t _dummy;
+ const char *name;
+}fl_aligned(8) symbol_t;
+
+typedef struct {+ fltype_t *type;
+ value_t binding;
+ uint32_t id;
+}fl_aligned(8) gensym_t;
+
+typedef struct Builtin Builtin;
+
+struct Builtin {+ const char *name;
+ int nargs;
+};
+
+typedef value_t (*builtin_t)(value_t*, uint32_t);
+
+#define fits_bits(x, b) (((x)>>(b-1)) == 0 || (~((x)>>(b-1))) == 0)
+#define fits_fixnum(x) fits_bits(x, FIXNUM_BITS)
+
+#define ANYARGS -10000
+#define NONNUMERIC (0xff)
+#define valid_numtype(v) ((v) <= T_DOUBLE)
+#define UNBOUND ((value_t)1) // an invalid value
+#define TAG_FWD UNBOUND
+#define tag(x) ((x) & 7)
+#define ptr(x) ((void*)((uintptr_t)(x) & (~(uintptr_t)7)))
+#define tagptr(p, t) ((value_t)(p) | (t))
+#define fixnum(x) ((value_t)(x)<<2)
+#define numval(x) ((fixnum_t)(x)>>2)
+#define uintval(x) (((unsigned int)(x))>>3)
+#define builtin(n) tagptr(((value_t)n<<3), TAG_FUNCTION)
+#define iscons(x) (tag(x) == TAG_CONS)
+#define issymbol(x) (tag(x) == TAG_SYM)
+#define isfixnum(x) (((x)&3) == TAG_NUM)
+#define bothfixnums(x, y) ((((x)|(y)) & 3) == TAG_NUM)
+#define isvector(x) (tag(x) == TAG_VECTOR)
+#define iscvalue(x) (tag(x) == TAG_CVALUE)
+#define iscprim(x) (tag(x) == TAG_CPRIM)
+// doesn't lead to other values
+#define leafp(a) (((a)&TAG_NONLEAF_MASK) != TAG_NONLEAF_MASK)
+
+// allocate n consecutive conses
+#define cons_reserve(n) tagptr(alloc_words((n)*2), TAG_CONS)
+#define cons_index(c) (((cons_t*)ptr(c))-((cons_t*)FL(fromspace)))
+#define ismarked(c) bitvector_get(FL(consflags), cons_index(c))
+#define mark_cons(c) bitvector_set(FL(consflags), cons_index(c))
+#define unmark_cons(c) bitvector_reset(FL(consflags), cons_index(c))
+
+#define isforwarded(v) (((value_t*)ptr(v))[0] == TAG_FWD)
+#define forwardloc(v) (((value_t*)ptr(v))[1])
+#define forward(v, to) \
+ do{ \+ (((value_t*)ptr(v))[0] = TAG_FWD); \
+ (((value_t*)ptr(v))[1] = to); \
+ }while (0)
+
+#define vector_size(v) (((size_t*)ptr(v))[0]>>2)
+#define vector_setsize(v, n) (((size_t*)ptr(v))[0] = ((n)<<2))
+#define vector_elt(v, i) (((value_t*)ptr(v))[1+(i)])
+#define vector_grow_amt(x) ((x)<8 ? 5 : 6*((x)>>3))
+// functions ending in _ are unsafe, faster versions
+#define car_(v) (((cons_t*)ptr(v))->car)
+#define cdr_(v) (((cons_t*)ptr(v))->cdr)
+#define car(v) (tocons((v))->car)
+#define cdr(v) (tocons((v))->cdr)
+#define fn_bcode(f) (((value_t*)ptr(f))[0])
+#define fn_vals(f) (((value_t*)ptr(f))[1])
+#define fn_env(f) (((value_t*)ptr(f))[2])
+#define fn_name(f) (((value_t*)ptr(f))[3])
+#define set(s, v) (((symbol_t*)ptr(s))->binding = (v))
+#define setc(s, v) \
+ do{ \+ ((symbol_t*)ptr(s))->flags |= FLAG_CONST; \
+ ((symbol_t*)ptr(s))->binding = (v); \
+ }while (0)
+#define isconstant(s) ((s)->flags & FLAG_CONST)
+#define iskeyword(s) ((s)->flags & FLAG_KEYWORD)
+#define symbol_value(s) (((symbol_t*)ptr(s))->binding)
+#define sym_to_numtype(s) (((symbol_t*)ptr(s))->numtype)
+#define ismanaged(v) ((((uint8_t*)ptr(v)) >= FL(fromspace)) && (((uint8_t*)ptr(v)) < FL(fromspace)+FL(heapsize)))
+#define isgensym(x) (issymbol(x) && ismanaged(x))
+#define isfunction(x) (tag(x) == TAG_FUNCTION && (x) > (N_BUILTINS<<3))
+#define isclosure(x) isfunction(x)
+#define iscbuiltin(x) (iscvalue(x) && cv_class(ptr(x)) == FL(builtintype))
+// utility for iterating over all arguments in a builtin
+// i=index, i0=start index, arg = var for each arg, args = arg array
+// assumes "nargs" is the argument count
+#define FOR_ARGS(i, i0, arg, args) for(i=i0; i<nargs && ((arg=args[i]) || 1); i++)
+#define N_BUILTINS ((int)N_OPCODES)
+
+#define PUSH(v) \
+ do{ \+ FL(stack)[FL(sp)++] = (v); \
+ }while(0)
+#define PUSHSAFE(v) \
+ do{ \+ if(FL(sp) >= FL(nstack)) \
+ fl_grow_stack(); \
+ PUSH(v); \
+ }while(0)
+#define POPN(n) \
+ do{ \+ FL(sp) -= (n); \
+ }while(0)
+#define POP() (FL(stack)[--FL(sp)])
+
+bool isbuiltin(value_t x) fl_constfn fl_hotfn;
+int fl_init(size_t initial_heapsize);
+int fl_load_system_image(value_t ios);
+
+_Noreturn void fl_exit(int status);
+
+/* collector */
+value_t relocate(value_t v) fl_hotfn;
+void fl_gc(int mustgrow);
+void fl_grow_stack(void);
+void fl_gc_handle(value_t *pv);
+void fl_free_gc_handles(uint32_t n);
+
+/* symbol table */
+value_t gensym(void);
+value_t symbol(const char *str, bool copy) fl_hotfn;
+const char *symbol_name(value_t v);
+
+/* read, eval, print main entry points */
+value_t fl_toplevel_eval(value_t expr);
+value_t fl_apply(value_t f, value_t l);
+value_t fl_applyn(uint32_t n, value_t f, ...);
+
+/* object model manipulation */
+value_t fl_cons(value_t a, value_t b);
+value_t fl_list2(value_t a, value_t b);
+value_t fl_listn(size_t n, ...);
+bool fl_isnumber(value_t v) fl_purefn;
+value_t alloc_vector(size_t n, int init);
+
+/* safe casts */
+cons_t *tocons(value_t v) fl_purefn;
+symbol_t *tosymbol(value_t v) fl_purefn;
+fixnum_t tofixnum(value_t v) fl_purefn;
+char *tostring(value_t v) fl_purefn;
+double todouble(value_t a) fl_purefn;
+
+/* conses */
+value_t mk_cons(void) fl_hotfn;
+void *alloc_words(uint32_t n) fl_hotfn;
+
+char *uint2str(char *dest, size_t len, uint64_t num, uint32_t base);
+
+/* error handling */
+typedef struct _fl_readstate_t {+ htable_t backrefs;
+ htable_t gensyms;
+ value_t source;
+ struct _fl_readstate_t *prev;
+}fl_readstate_t;
+
+typedef struct _ectx_t {+ fl_readstate_t *rdst;
+ struct _ectx_t *prev;
+ jmp_buf buf;
+ uint32_t sp;
+ uint32_t frame;
+ uint32_t ngchnd;
+}fl_exception_context_t;
+
+void free_readstate(fl_readstate_t *rs);
+
+#define FL_TRY_EXTERN \
+ fl_exception_context_t _ctx; int l__tr, l__ca; \
+ fl_savestate(&_ctx); FL(exctx) = &_ctx; \
+ if(!setjmp(_ctx.buf)) \
+ for(l__tr=1; l__tr; l__tr=0, (void)(FL(exctx) = FL(exctx)->prev))
+
+#define FL_CATCH_EXTERN_NO_RESTORE \
+ else \
+ for(l__ca=1; l__ca;)
+
+#define FL_CATCH_EXTERN \
+ else \
+ for(l__ca=1; l__ca; l__ca=0, fl_restorestate(&_ctx))
+
+_Noreturn void lerrorf(value_t e, const char *format, ...) fl_printfmt(2, 3);
+void fl_savestate(fl_exception_context_t *_ctx);
+void fl_restorestate(fl_exception_context_t *_ctx);
+_Noreturn void fl_raise(value_t e);
+_Noreturn void type_error(const char *expected, value_t got);
+_Noreturn void bounds_error(value_t arr, value_t ind);
+_Noreturn void unbound_error(value_t sym);
+
+#define argcount(nargs, c) \
+ do{ \+ if(fl_unlikely(nargs != c)) \
+ lerrorf(FL_ArgError, "arity mismatch: wanted %"PRIu32", got %"PRIu32, (uint32_t)c, nargs); \
+ }while(0)
+
+typedef struct {+ void (*print)(value_t self, ios_t *f);
+ void (*relocate)(value_t oldv, value_t newv);
+ void (*finalize)(value_t self);
+ void (*print_traverse)(value_t self);
+} cvtable_t;
+
+typedef int (*cvinitfunc_t)(fltype_t*, value_t, void*);
+
+struct fltype_t {+ value_t type;
+ cvtable_t *vtable;
+ fltype_t *eltype; // for arrays
+ fltype_t *artype; // (array this)
+ cvinitfunc_t init;
+ size_t size;
+ size_t elsz;
+ numerictype_t numtype;
+};
+
+typedef struct {+ fltype_t *type;
+ void *data;
+ size_t len; // length of *data in bytes
+ union {+ value_t parent; // optional
+ uint8_t _space[1]; // variable size
+ };
+}fl_aligned(8) cvalue_t;
+
+typedef struct {+ fltype_t *type;
+ uint8_t _space[];
+}fl_aligned(8) cprim_t;
+
+typedef struct {+ value_t bcode;
+ value_t vals;
+ value_t env;
+ value_t name;
+}fl_aligned(8) function_t;
+
+#define CPRIM_NWORDS 2
+#define cv_class(cv) ((fltype_t*)(((uintptr_t)((cvalue_t*)cv)->type)&~(uintptr_t)3))
+#define cv_len(cv) (((cvalue_t*)(cv))->len)
+#define cv_type(cv) (cv_class(cv)->type)
+#define cv_data(cv) (((cvalue_t*)(cv))->data)
+#define cv_isstr(cv) (cv_class(cv)->eltype == FL(bytetype))
+#define cv_isPOD(cv) (cv_class(cv)->init != nil)
+#define cvalue_data(v) cv_data((cvalue_t*)ptr(v))
+#define cvalue_len(v) cv_len((cvalue_t*)ptr(v))
+#define value2c(type, v) ((type)cvalue_data(v))
+#define cp_class(cp) (((cprim_t*)(cp))->type)
+#define cp_type(cp) (cp_class(cp)->type)
+#define cp_numtype(cp) (cp_class(cp)->numtype)
+#define cp_data(cp) (&((cprim_t*)(cp))->_space[0])
+// WARNING: multiple evaluation!
+#define cptr(v) (iscprim(v) ? cp_data(ptr(v)) : cvalue_data(v))
+
+#define BUILTIN(lname, cname) \
+ value_t fn_builtin_##cname(value_t *args, uint32_t nargs)
+
+#define BUILTIN_FN(l, c, attr) attr BUILTIN(l, c);
+#include "builtin_fns.h"
+#undef BUILTIN_FN
+
+#include "opcodes.h"
+
+enum {+ FL_nil = builtin(OP_LOADNIL),
+ FL_t = builtin(OP_LOADT),
+ FL_f = builtin(OP_LOADF),
+ FL_void = builtin(OP_LOADVOID),
+ FL_eof = builtin(OP_EOF_OBJECT),
+};
+
+#define N_GC_HANDLES 1024
+
+typedef struct Fl Fl;
+
+struct Fl {+ value_t *stack;
+ uint32_t sp;
+ uint32_t nstack;
+ uintptr_t heapsize;//bytes
+ uint8_t *fromspace;
+ uint32_t curr_frame;
+
+ uint8_t *tospace;
+ uint8_t *curheap;
+ uint8_t *lim;
+
+ size_t malloc_pressure;
+
+ cvalue_t **finalizers;
+ size_t nfinalizers;
+ size_t maxfinalizers;
+
+ fl_readstate_t *readstate;
+ Tbl *symtab;
+
+ // saved execution state for an unwind target
+ fl_exception_context_t *exctx;
+ uint32_t throwing_frame; // active frame when exception was thrown
+ value_t lasterror;
+
+ fltype_t *tabletype;
+
+ fltype_t *iostreamtype;
+
+ value_t the_empty_vector;
+ value_t the_empty_string;
+ value_t memory_exception_value;
+
+ fltype_t *mpinttype;
+ fltype_t *int8type, *uint8type;
+ fltype_t *int16type, *uint16type;
+ fltype_t *int32type, *uint32type;
+ fltype_t *int64type, *uint64type;
+ fltype_t *longtype, *ulongtype;
+ fltype_t *floattype, *doubletype;
+ fltype_t *bytetype, *runetype;
+ fltype_t *stringtype, *runestringtype;
+ fltype_t *builtintype;
+
+ uint32_t gensym_ctr;
+ // two static buffers for gensym printing so there can be two
+ // gensym names available at a time, mostly for compare()
+ char gsname[2][16];
+ int gsnameno;
+
+ bool exiting;
+ bool grew;
+
+ uint32_t *consflags;
+ size_t gccalls;
+
+ htable_t printconses;
+ uint32_t printlabel;
+ int print_pretty;
+ int print_princ;
+ fixnum_t print_length;
+ fixnum_t print_level;
+ fixnum_t p_level;
+ int scr_width;
+ int hpos, vpos;
+
+ htable_t reverse_dlsym_lookup_table;
+ htable_t TypeTable;
+ uint32_t ngchandles;
+ value_t *gchandles[N_GC_HANDLES];
+};
+
+extern fl_thread(Fl *fl);
+#define FL(f) fl->f
+
+extern value_t FL_builtins_table_sym, FL_quote, FL_lambda, FL_function, FL_comma, FL_commaat;
+extern value_t FL_commadot, FL_trycatch, FL_backquote;
+extern value_t FL_conssym, FL_symbolsym, FL_fixnumsym, FL_vectorsym, FL_builtinsym, FL_vu8sym;
+extern value_t FL_definesym, FL_defmacrosym, FL_forsym, FL_setqsym;
+extern value_t FL_tsym, FL_Tsym, FL_fsym, FL_Fsym, FL_booleansym, FL_nullsym, FL_evalsym, FL_fnsym;
+extern value_t FL_nulsym, FL_alarmsym, FL_backspacesym, FL_tabsym, FL_linefeedsym, FL_newlinesym;
+extern value_t FL_vtabsym, FL_pagesym, FL_returnsym, FL_escsym, FL_spacesym, FL_deletesym;
+extern value_t FL_IOError, FL_ParseError, FL_TypeError, FL_ArgError, FL_MemoryError;
+extern value_t FL_DivideError, FL_BoundsError, FL_Error, FL_KeyError, FL_EnumerationError;
+extern value_t FL_UnboundError;
+extern value_t FL_sizesym, FL_tosym;
+extern value_t FL_fsosym;
+
+extern value_t FL_printwidthsym, FL_printreadablysym, FL_printprettysym, FL_printlengthsym;
+extern value_t FL_printlevelsym;
+extern value_t FL_tablesym, FL_arraysym;
+extern value_t FL_iostreamsym, FL_rdsym, FL_wrsym, FL_apsym, FL_crsym, FL_truncsym;
+extern value_t FL_instrsym, FL_outstrsym;
+extern value_t FL_int8sym, FL_uint8sym, FL_int16sym, FL_uint16sym, FL_int32sym, FL_uint32sym;
+extern value_t FL_int64sym, FL_uint64sym, FL_bignumsym;
+extern value_t FL_bytesym, FL_runesym, FL_floatsym, FL_doublesym;
+extern value_t FL_stringtypesym, FL_runestringtypesym;
+
+_Noreturn void flmain(const uint8_t *boot, int bootsz, int argc, char **argv);
--- /dev/null
+++ b/src/flmain.c
@@ -1,0 +1,71 @@
+#include "flisp.h"
+#include "cvalues.h"
+#include "print.h"
+#include "iostream.h"
+#include "random.h"
+#include "brieflz.h"
+#include "nan.h"
+
+static value_t
+argv_list(int argc, char *argv[])
+{+ int i;
+ value_t lst = FL_nil, temp;
+ fl_gc_handle(&lst);
+ fl_gc_handle(&temp);
+ for(i = argc-1; i >= 0; i--){+ temp = cvalue_static_cstring(argv[i]);
+ lst = fl_cons(temp, lst);
+ }
+ fl_free_gc_handles(2);
+ return lst;
+}
+
+_Noreturn void
+flmain(const uint8_t *boot, int bootsz, int argc, char **argv)
+{+ nan_init();
+ randomize();
+ ios_init_stdstreams();
+ mpsetminbits(sizeof(fixnum_t)*8);
+
+ if(fl_init(INITIAL_HEAP_SIZE) != 0)
+ exit(1);
+
+ value_t f = cvalue(FL(iostreamtype), (int)sizeof(ios_t));
+ ios_t *s = value2c(ios_t*, f);
+ uint8_t *unpacked = nil;
+ if(boot[0] == 0){+ uint32_t unpackedsz =
+ boot[1]<<0 |
+ boot[2]<<8 |
+ boot[3]<<16|
+ boot[4]<<24;
+ unpacked = MEM_ALLOC(unpackedsz);
+ unsigned long n = blz_depack_safe(boot+5, bootsz-5, unpacked, unpackedsz);
+ if(n == BLZ_ERROR){+ ios_puts(ios_stderr, "failed to unpack boot image\n");
+ fl_exit(1);
+ }
+ boot = unpacked;
+ bootsz = n;
+ }
+ ios_static_buffer(s, boot, bootsz);
+
+ int r = 1;
+ FL_TRY_EXTERN{+ if(fl_load_system_image(f) == 0){+ MEM_FREE(unpacked);
+ ios_close(s);
+ fl_applyn(1, symbol_value(symbol("__start", false)), argv_list(argc, argv));+ r = 0;
+ }
+ }
+ FL_CATCH_EXTERN_NO_RESTORE{+ ios_puts(ios_stderr, "fatal error:\n");
+ fl_print(ios_stderr, FL(lasterror));
+ ios_putc(ios_stderr, '\n');
+ break;
+ }
+ fl_exit(r);
+}
--- /dev/null
+++ b/src/hashing.c
@@ -1,0 +1,68 @@
+#include "flisp.h"
+#include "hashing.h"
+#include "spooky.h"
+
+value_t
+nextipow2(value_t i)
+{+ if(i == 0)
+ return 1;
+ i |= i >> 1;
+ i |= i >> 2;
+ i |= i >> 4;
+ i |= i >> 8;
+ i |= i >> 16;
+#if defined(BITS64)
+ i |= i >> 32;
+#endif
+ i++;
+ return i ? i : TOP_BIT;
+}
+
+value_t
+inthash(value_t a)
+{+#if defined(BITS64)
+ a = (~a) + (a << 21); // a = (a << 21) - a - 1;
+ a = a ^ (a >> 24);
+ a = (a + (a << 3)) + (a << 8); // a * 265
+ a = a ^ (a >> 14);
+ a = (a + (a << 2)) + (a << 4); // a * 21
+ a = a ^ (a >> 28);
+ a = a + (a << 31);
+ return a;
+}
+#else
+ a = (a+0x7ed55d16) + (a<<12);
+ a = (a^0xc761c23c) ^ (a>>19);
+ a = (a+0x165667b1) + (a<<5);
+ a = (a+0xd3a2646c) ^ (a<<9);
+ a = (a+0xfd7046c5) + (a<<3);
+ a = (a^0xb55a4f09) ^ (a>>16);
+ return a;
+}
+
+uint32_t
+int64to32hash(uint64_t key)
+{+ key = (~key) + (key << 18); // key = (key << 18) - key - 1;
+ key = key ^ (key >> 31);
+ key = key * 21; // key = (key + (key << 2)) + (key << 4);
+ key = key ^ (key >> 11);
+ key = key + (key << 6);
+ key = key ^ (key >> 22);
+ return (uint32_t)key;
+}
+#endif
+
+uint64_t
+memhash(const char *buf, size_t n)
+{+ return spooky_hash64(buf, n, 0xcafe8881);
+}
+
+uint32_t
+memhash32(const char *buf, size_t n)
+{+ return spooky_hash32(buf, n, 0xcafe8881);
+}
--- /dev/null
+++ b/src/hashing.h
@@ -1,0 +1,7 @@
+#pragma once
+
+value_t nextipow2(value_t i) fl_constfn;
+value_t inthash(value_t a) fl_constfn;
+uint32_t int64to32hash(uint64_t key) fl_constfn;
+uint64_t memhash(const char* buf, size_t n);
+uint32_t memhash32(const char* buf, size_t n);
--- /dev/null
+++ b/src/htable.c
@@ -1,0 +1,48 @@
+/*
+ functions common to all hash table instantiations
+*/
+
+#include "flisp.h"
+#include "htable.h"
+#include "hashing.h"
+
+htable_t *
+htable_new(htable_t *h, size_t size)
+{+ if(size <= HT_N_INLINE/2){+ size = HT_N_INLINE;
+ h->table = &h->_space[0];
+ }else{+ size = nextipow2(size);
+ size *= 2; // 2 pointers per key/value pair
+ size *= 2; // aim for 50% occupancy
+ if((h->table = MEM_ALLOC(size * sizeof(*h->table))) == nil)
+ return nil;
+ }
+ h->size = size;
+ h->i = 0;
+ for(size_t i = 0; i < size; i++)
+ h->table[i] = HT_NOTFOUND;
+ return h;
+}
+
+void
+htable_free(htable_t *h)
+{+ if(h->table != &h->_space[0])
+ MEM_FREE(h->table);
+}
+
+// empty and reduce size
+void
+htable_reset(htable_t *h, size_t sz)
+{+ sz = nextipow2(sz);
+ if(h->size > sz*4 && h->table != &h->_space[0]){+ MEM_FREE(h->table);
+ htable_new(h, sz);
+ }else{+ for(size_t i = 0, hsz = h->size; i < hsz; i++)
+ h->table[i] = HT_NOTFOUND;
+ }
+}
--- /dev/null
+++ b/src/htable.h
@@ -1,0 +1,22 @@
+#pragma once
+
+#define HT_N_INLINE 32
+
+typedef struct {+ void **table;
+ uint32_t size;
+ // this is to skip over non-items in for-each
+ // FIXME(sigrid): in a multithreaded environment this isn't enough
+ uint32_t i;
+ void *_space[HT_N_INLINE];
+}fl_aligned(8) htable_t;
+
+// define this to be an invalid key/value
+#define HT_NOTFOUND ((void*)1)
+
+// initialize and free
+htable_t *htable_new(htable_t *h, size_t size);
+void htable_free(htable_t *h);
+
+// clear and (possibly) change size
+void htable_reset(htable_t *h, size_t sz);
--- /dev/null
+++ b/src/htable.inc
@@ -1,0 +1,136 @@
+//-*- mode:c -*-
+
+// define HTNAME, HFUNC and EQFUNC, then include this header
+
+#define hash_size(h) ((h)->size/2)
+
+// compute empirical max-probe for a given size
+#define max_probe(size) ((size) <= (HT_N_INLINE*2) ? (HT_N_INLINE/2) : (size)>>3)
+
+static void **
+HTNAME(_lookup_bp)(htable_t *h, void *key)
+{+ value_t hv;
+ size_t i, orig, index, iter;
+ size_t newsz, sz = hash_size(h);
+ size_t maxprobe = max_probe(sz);
+ void **tab = h->table;
+ void **ol;
+
+ hv = HFUNC(key);
+retry_bp:
+ iter = 0;
+ index = (hv & (sz-1)) * 2;
+ sz *= 2;
+ orig = index;
+
+ do{+ if(tab[index+1] == HT_NOTFOUND){+ tab[index] = key;
+ return &tab[index+1];
+ }
+ if(EQFUNC(key, tab[index]))
+ return &tab[index+1];
+ index = (index+2) & (sz-1);
+ iter++;
+ if(iter > maxprobe)
+ break;
+ }while(index != orig);
+
+ /* table full */
+ /* quadruple size, rehash, retry the insert */
+ /* it's important to grow the table really fast; otherwise we waste */
+ /* lots of time rehashing all the keys over and over. */
+ sz = h->size;
+ ol = h->table;
+ if(sz >= (1<<19) || (sz <= (1<<8)))
+ newsz = sz<<1;
+ else if(sz <= HT_N_INLINE)
+ newsz = HT_N_INLINE;
+ else
+ newsz = sz<<2;
+ tab = (void**)MEM_ALLOC(newsz*sizeof(void*));
+ if(tab == nil)
+ return nil;
+ for(i = 0; i < newsz; i++)
+ tab[i] = HT_NOTFOUND;
+ h->table = tab;
+ h->size = newsz;
+ for(i = 0; i < sz; i += 2) {+ if(ol[i+1] != HT_NOTFOUND)
+ (*HTNAME(_lookup_bp)(h, ol[i])) = ol[i+1];
+ }
+ if(ol != &h->_space[0])
+ MEM_FREE(ol);
+ sz = hash_size(h);
+ maxprobe = max_probe(sz);
+ tab = h->table;
+ goto retry_bp;
+}
+
+void
+HTNAME(_put)(htable_t *h, void *key, void *val)
+{+ void **bp = HTNAME(_lookup_bp)(h, key);
+ *bp = val;
+}
+
+void **
+HTNAME(_bp)(htable_t *h, void *key)
+{+ return HTNAME(_lookup_bp)(h, key);
+}
+
+/* returns bp if key is in hash, otherwise nil */
+/* if return is non-nil and *bp == HT_NOTFOUND then key was deleted */
+static void **
+HTNAME(_peek_bp)(htable_t *h, void *key)
+{+ size_t sz = hash_size(h);
+ size_t maxprobe = max_probe(sz);
+ void **tab = h->table;
+ size_t index = (HFUNC(key) & (sz-1)) * 2;
+ sz *= 2;
+ size_t orig = index;
+ size_t iter = 0;
+
+ do {+ if(tab[index] == HT_NOTFOUND)
+ return nil;
+ if(EQFUNC(key, tab[index]))
+ return &tab[index+1];
+
+ index = (index+2) & (sz-1);
+ iter++;
+ if(iter > maxprobe)
+ break;
+ }while(index != orig);
+
+ return nil;
+}
+
+void *
+HTNAME(_get)(htable_t *h, void *key)
+{+ void **bp = HTNAME(_peek_bp)(h, key);
+ if(bp == nil)
+ return HT_NOTFOUND;
+ return *bp;
+}
+
+int
+HTNAME(_has)(htable_t *h, void *key)
+{+ return HTNAME(_get)(h, key) != HT_NOTFOUND;
+}
+
+int
+HTNAME(_remove)(htable_t *h, void *key)
+{+ void **bp = HTNAME(_peek_bp)(h, key);
+ if(bp != nil){+ *bp = HT_NOTFOUND;
+ return 1;
+ }
+ return 0;
+}
--- /dev/null
+++ b/src/htableh.inc
@@ -1,0 +1,29 @@
+//-*- mode:c -*-
+
+#include "htable.h"
+
+#define HTPROT(HTNAME) \
+void *HTNAME##_get(htable_t *h, void *key) fl_purefn; \
+void HTNAME##_put(htable_t *h, void *key, void *val); \
+int HTNAME##_has(htable_t *h, void *key) fl_purefn; \
+int HTNAME##_remove(htable_t *h, void *key); \
+void **HTNAME##_bp(htable_t *h, void *key);
+
+// return value, or HT_NOTFOUND if key not found
+
+// add key/value binding
+
+// add binding iff key is unbound
+
+// does key exist?
+
+// logically remove key
+
+// get a pointer to the location of the value for the given key.
+// creates the location if it doesn't exist. only returns nil
+// if memory allocation fails.
+// this should be used for updates, for example:
+// void **bp = ptrhash_bp(h, key);
+// *bp = f(*bp);
+// do not reuse bp if there might be intervening calls to ptrhash_put,
+// ptrhash_bp, ptrhash_reset, or ptrhash_free.
--- /dev/null
+++ b/src/ieee754.h
@@ -1,0 +1,21 @@
+#pragma once
+
+union ieee754_double {+ double d;
+
+ struct {+#if BYTE_ORDER == BIG_ENDIAN
+ unsigned int negative:1;
+ unsigned int exponent:11;
+ unsigned int mantissa0:20;
+ unsigned int mantissa1:32;
+#else
+ unsigned int mantissa1:32;
+ unsigned int mantissa0:20;
+ unsigned int exponent:11;
+ unsigned int negative:1;
+#endif
+ }ieee;
+};
+
+#define IEEE754_DOUBLE_BIAS 0x3ff
--- /dev/null
+++ b/src/ios.c
@@ -1,0 +1,1002 @@
+#include "flisp.h"
+#include "timefuncs.h"
+
+#define MOST_OF(x) ((x) - ((x)>>4))
+
+static char emptystr[] = "";
+
+ios_t *ios_stdin = nil;
+ios_t *ios_stdout = nil;
+ios_t *ios_stderr = nil;
+
+/* OS-level primitive wrappers */
+
+void *
+llt_memrchr(const void *s, int c, size_t n)
+{+ const uint8_t *src = (const uint8_t*)s + n;
+ uint8_t uc = c;
+ while(--src >= (const uint8_t*)s)
+ if(*src == uc)
+ return (void *)src;
+ return nil;
+}
+
+#if !defined(__plan9__) && !defined(__macos__) && !defined(__dos__)
+static int
+_enonfatal(int err)
+{+ return err == 0 || err == EAGAIN || err == EINPROGRESS || err == EINTR || err == EWOULDBLOCK;
+}
+#define SLEEP_TIME 5//ms
+#endif
+
+// return error code, #bytes read in *nread
+// these wrappers retry operations until success or a fatal error
+static int
+_os_read(int fd, uint8_t *buf, size_t n, size_t *nread)
+{+ ssize_t r;
+
+ while(1){+#if !defined(__plan9__) && !defined(__macos__) && !defined(__dos__)
+ errno = 0;
+#endif
+ r = read(fd, buf, n);
+ if(r > -1){+ *nread = (size_t)r;
+ break;
+ }
+#if defined(__plan9__) || defined(__macos__) || defined(__dos__)
+ return r;
+#else
+ if(!_enonfatal(errno)){+ *nread = 0;
+ return errno;
+ }
+ sleep_ms(SLEEP_TIME);
+#endif
+ }
+ return 0;
+}
+
+static int
+_os_read_all(int fd, uint8_t *buf, size_t n, size_t *nread)
+{+ size_t got;
+
+ *nread = 0;
+
+ while(n > 0){+ int err = _os_read(fd, buf, n, &got);
+ n -= got;
+ *nread += got;
+ buf += got;
+ if(err || got == 0)
+ return err;
+ }
+ return 0;
+}
+
+static int
+_os_write(int fd, const void *buf, size_t n, size_t *nwritten)
+{+ ssize_t r;
+
+ while(1){+#if !defined(__plan9__) && !defined(__macos__) && !defined(__dos__)
+ errno = 0;
+#endif
+ r = write(fd, buf, n);
+ if(r > -1){+ *nwritten = (size_t)r;
+ break;
+ }
+#if defined(__plan9__) || defined(__macos__) || defined(__dos__)
+ return r;
+#else
+ if(!_enonfatal(errno)){+ *nwritten = 0;
+ return errno;
+ }
+ sleep_ms(SLEEP_TIME);
+#endif
+ }
+ return 0;
+}
+
+static int
+_os_write_all(int fd, const uint8_t *buf, size_t n, size_t *nwritten)
+{+ size_t wrote;
+
+ *nwritten = 0;
+ while(n > 0){+ wrote = 0;
+ int err = _os_write(fd, buf, n, &wrote);
+ n -= wrote;
+ *nwritten += wrote;
+ buf += wrote;
+ if(err)
+ return err;
+ }
+ return 0;
+}
+
+
+/* internal utility functions */
+
+static uint8_t *
+_buf_realloc(ios_t *s, size_t sz)
+{+ uint8_t *temp;
+
+ if((s->buf == nil || s->buf == &s->local[0]) && sz <= IOS_INLSIZE){+ /* TODO: if we want to allow shrinking, see if the buffer shrank
+ down to this size, in which case we need to copy. */
+ s->buf = &s->local[0];
+ s->maxsize = IOS_INLSIZE;
+ s->ownbuf = 1;
+ return s->buf;
+ }
+
+ if(sz <= s->maxsize)
+ return s->buf;
+
+ if(s->ownbuf && s->buf != &s->local[0]){+ // if we own the buffer we're free to resize it
+ // always allocate 1 bigger in case user wants to add a NUL
+ // terminator after taking over the buffer
+ temp = MEM_REALLOC(s->buf, sz);
+ if(temp == nil)
+ return nil;
+ }else{+ temp = MEM_ALLOC(sz);
+ if(temp == nil)
+ return nil;
+ s->ownbuf = 1;
+ if(s->buf != nil)
+ memcpy(temp, s->buf, s->size);
+ }
+
+ s->buf = temp;
+ s->maxsize = sz;
+ return s->buf;
+}
+
+// write a block of data into the buffer at the current position, resizing
+// if necessary. returns # written.
+static size_t
+_write_grow(ios_t *s, const void *data, size_t n)
+{+ size_t amt;
+ size_t newsize;
+
+ if(n == 0)
+ return 0;
+
+ if(s->bpos + n > s->size){+ if(s->bpos + n > s->maxsize){+ /* TODO: here you might want to add a mechanism for limiting
+ the growth of the stream. */
+ newsize = s->maxsize ? s->maxsize * 2 : 8;
+ while(s->bpos + n > newsize)
+ newsize *= 2;
+ if(_buf_realloc(s, newsize) == nil){+ /* no more space; write as much as we can */
+ amt = s->maxsize - s->bpos;
+ if(amt > 0)
+ memcpy(&s->buf[s->bpos], data, amt);
+ s->bpos += amt;
+ s->size = s->maxsize;
+ return amt;
+ }
+ }
+ s->size = s->bpos + n;
+ }
+ memcpy(s->buf + s->bpos, data, n);
+ s->bpos += n;
+
+ return n;
+}
+
+
+/* interface functions, low level */
+
+static size_t
+_ios_read(ios_t *s, uint8_t *dest, size_t n, int all)
+{+ size_t tot = 0;
+ size_t got, avail;
+
+ if(s->state == bst_closed)
+ return 0;
+
+ while(n > 0){+ avail = s->size - s->bpos;
+
+ if(avail > 0){+ size_t ncopy = avail >= n ? n : avail;
+ memcpy(dest, s->buf + s->bpos, ncopy);
+ s->bpos += ncopy;
+ if(ncopy >= n){+ s->state = bst_rd;
+ return tot+ncopy;
+ }
+ }
+ if(s->bm == bm_mem || s->fd == -1){+ // can't get any more data
+ s->state = bst_rd;
+ if(avail == 0)
+ s->_eof = 1;
+ return avail;
+ }
+
+ dest += avail;
+ n -= avail;
+ tot += avail;
+
+ ios_flush(s);
+ s->bpos = s->size = 0;
+ s->state = bst_rd;
+
+ s->fpos = -1;
+ got = 0;
+ if(n > MOST_OF(s->maxsize)){+ // doesn't fit comfortably in buffer; go direct
+ if(all)
+ _os_read_all(s->fd, dest, n, &got);
+ else
+ _os_read(s->fd, dest, n, &got);
+ tot += got;
+ if(got == 0)
+ s->_eof = 1;
+ return tot;
+ }else{+ // refill buffer
+ if(_os_read(s->fd, s->buf, s->maxsize, &got)){+ s->_eof = 1;
+ return tot;
+ }
+ if(got == 0){+ s->_eof = 1;
+ return tot;
+ }
+ s->size = got;
+ }
+ }
+
+ return tot;
+}
+
+size_t
+ios_read(ios_t *s, void *dest, size_t n)
+{+ return _ios_read(s, dest, n, 0);
+}
+
+// ensure at least n bytes are buffered if possible. returns # available.
+static size_t
+ios_readprep(ios_t *s, size_t n)
+{+ if(s->state == bst_wr && s->bm != bm_mem){+ ios_flush(s);
+ s->bpos = s->size = 0;
+ }
+ size_t space = s->size - s->bpos;
+ s->state = bst_rd;
+ if(space >= n || s->bm == bm_mem || s->fd == -1)
+ return space;
+ if(s->maxsize < s->bpos+n){+ // it won't fit. grow buffer or move data back.
+ if(n <= s->maxsize && space <= ((s->maxsize)>>2)){+ if(space)
+ memmove(s->buf, s->buf+s->bpos, space);
+ s->size -= s->bpos;
+ s->bpos = 0;
+ }
+ else {+ if(_buf_realloc(s, s->bpos + n) == nil)
+ return space;
+ }
+ }
+ size_t got;
+ int result = _os_read(s->fd, s->buf+s->size, s->maxsize - s->size, &got);
+ if(result)
+ return space;
+ s->size += got;
+ return s->size - s->bpos;
+}
+
+static void
+_write_update_pos(ios_t *s)
+{+ if(s->bpos > s->ndirty)
+ s->ndirty = s->bpos;
+ if(s->bpos > s->size)
+ s->size = s->bpos;
+}
+
+size_t
+ios_write(ios_t *s, const void *data, size_t n)
+{+ if(s->readonly || s->state == bst_closed || n == 0)
+ return 0;
+ size_t space;
+ size_t wrote = 0;
+
+ if(s->state == bst_none)
+ s->state = bst_wr;
+ if(s->state == bst_rd){+ if(!s->rereadable){+ s->size = 0;
+ s->bpos = 0;
+ }
+ space = s->size - s->bpos;
+ }else{+ space = s->maxsize - s->bpos;
+ }
+
+ if(s->bm == bm_mem){+ wrote = _write_grow(s, data, n);
+ }else if(s->bm == bm_none){+ s->fpos = -1;
+ _os_write_all(s->fd, data, n, &wrote);
+ return wrote;
+ }else if(n <= space){+ if(s->bm == bm_line){+ const char *nl;
+ if((nl = llt_memrchr(data, '\n', n)) != nil){+ size_t linesz = nl-(const char*)data+1;
+ s->bm = bm_block;
+ wrote += ios_write(s, data, linesz);
+ ios_flush(s);
+ s->bm = bm_line;
+ n -= linesz;
+ data = (const char*)data + linesz;
+ }
+ }
+ memcpy(s->buf + s->bpos, data, n);
+ s->bpos += n;
+ wrote += n;
+ }else{+ s->state = bst_wr;
+ ios_flush(s);
+ if(n > MOST_OF(s->maxsize)){+ _os_write_all(s->fd, data, n, &wrote);
+ return wrote;
+ }
+ return ios_write(s, data, n);
+ }
+ _write_update_pos(s);
+ return wrote;
+}
+
+off_t
+ios_seek(ios_t *s, off_t pos)
+{+ if(s->state == bst_closed)
+ return 0;
+ s->_eof = 0;
+ if(s->bm == bm_mem){+ if((size_t)pos > s->size)
+ return -1;
+ s->bpos = pos;
+ }else{+ ios_flush(s);
+ off_t fdpos = lseek(s->fd, pos, SEEK_SET);
+ if(fdpos == (off_t)-1)
+ return fdpos;
+ s->bpos = s->size = 0;
+ }
+ return 0;
+}
+
+off_t
+ios_seek_end(ios_t *s)
+{+ if(s->state == bst_closed)
+ return 0;
+ s->_eof = 1;
+ if(s->bm == bm_mem){+ s->bpos = s->size;
+ }else{+ ios_flush(s);
+ off_t fdpos = lseek(s->fd, 0, SEEK_END);
+ if(fdpos == (off_t)-1)
+ return fdpos;
+ s->bpos = s->size = 0;
+ }
+ return 0;
+}
+
+off_t
+ios_skip(ios_t *s, off_t offs)
+{+ if(s->state == bst_closed)
+ return 0;
+ if(offs != 0){+ if(offs > 0){+ if(offs <= (off_t)(s->size-s->bpos)){+ s->bpos += offs;
+ return 0;
+ }else if(s->bm == bm_mem){+ // TODO: maybe grow buffer
+ return -1;
+ }
+ }else if(offs < 0){+ if(-offs <= (off_t)s->bpos){+ s->bpos += offs;
+ s->_eof = 0;
+ return 0;
+ }else if(s->bm == bm_mem){+ return -1;
+ }
+ }
+ ios_flush(s);
+ if(s->state == bst_wr)
+ offs += s->bpos;
+ else if(s->state == bst_rd)
+ offs -= s->size - s->bpos;
+ off_t fdpos = lseek(s->fd, offs, SEEK_CUR);
+ if(fdpos == (off_t)-1)
+ return fdpos;
+ s->bpos = s->size = 0;
+ s->_eof = 0;
+ }
+ return 0;
+}
+
+off_t
+ios_pos(ios_t *s)
+{+ if(s->state == bst_closed)
+ return 0;
+ if(s->bm == bm_mem)
+ return (off_t)s->bpos;
+
+ off_t fdpos = s->fpos;
+ if(fdpos == (off_t)-1){+ fdpos = lseek(s->fd, 0, SEEK_CUR);
+ if(fdpos == (off_t)-1)
+ return fdpos;
+ s->fpos = fdpos;
+ }
+
+ if(s->state == bst_wr)
+ fdpos += s->bpos;
+ else if(s->state == bst_rd)
+ fdpos -= s->size - s->bpos;
+ return fdpos;
+}
+
+int
+ios_trunc(ios_t *s, off_t size)
+{+ if(s->state == bst_closed || s->readonly || size < 0)
+ return -1;
+ if(s->bm == bm_mem){+ if((size_t)size == s->size)
+ return 0;
+ if((size_t)size < s->size){+ if(s->bpos > (size_t)size)
+ s->bpos = size;
+ }else if(_buf_realloc(s, size) == nil)
+ return -1;
+ s->size = size;
+ return 0;
+ }
+ return ios_flush(s) == 0 ? ftruncate(s->fd, size) : -1;
+}
+
+bool
+ios_eof(ios_t *s)
+{+ if(s->state == bst_closed)
+ return true;
+ if(s->bm == bm_mem)
+ return s->_eof;
+ return s->fd == -1 || s->_eof;
+}
+
+int
+ios_flush(ios_t *s)
+{+ if(s->ndirty == 0 || s->bm == bm_mem || s->buf == nil)
+ return 0;
+ if(s->fd == -1)
+ return -1;
+
+ if(s->state == bst_rd){+ if(lseek(s->fd, -(off_t)s->size, SEEK_CUR) == (off_t)-1){+ // FIXME eh?
+ }
+ }
+
+ size_t nw, ntowrite = s->ndirty;
+ s->fpos = -1;
+ int err = _os_write_all(s->fd, s->buf, ntowrite, &nw);
+ // todo: try recovering from some kinds of errors (e.g. retry)
+
+ if(s->state == bst_rd){+ if(lseek(s->fd, s->size - nw, SEEK_CUR) == (off_t)-1){+ // FIXME eh?
+ }
+ }else if(s->state == bst_wr){+ if(s->bpos != nw && lseek(s->fd, (off_t)s->bpos - (off_t)nw, SEEK_CUR) == (off_t)-1){+ // FIXME eh?
+ }
+ // now preserve the invariant that data to write
+ // begins at the beginning of the buffer, and s->size refers
+ // to how much valid file data is stored in the buffer.
+ if(s->size > s->ndirty){+ size_t delta = s->size - s->ndirty;
+ memmove(s->buf, s->buf + s->ndirty, delta);
+ }
+ s->size -= s->ndirty;
+ s->bpos = 0;
+ }
+
+ s->ndirty = 0;
+
+ if(err)
+ return err;
+ if(nw < ntowrite)
+ return -1;
+ return 0;
+}
+
+void
+ios_close(ios_t *s)
+{+ if(s->state == bst_closed)
+ return;
+ ios_flush(s);
+ if(s->fd != -1 && s->ownfd)
+ close(s->fd);
+ s->fd = -1;
+ if(s->buf != nil && s->ownbuf && s->buf != &s->local[0])
+ MEM_FREE(s->buf);
+ s->buf = nil;
+ s->size = s->maxsize = s->bpos = 0;
+ s->state = bst_closed;
+}
+
+void
+ios_free(ios_t *s)
+{+ if(s->loc.filename != emptystr){+ MEM_FREE(s->loc.filename);
+ s->loc.filename = emptystr;
+ }
+}
+
+static void
+_buf_init(ios_t *s, bufmode_t bm)
+{+ s->bm = bm;
+ if(s->bm == bm_mem || s->bm == bm_none){+ s->buf = &s->local[0];
+ s->maxsize = IOS_INLSIZE;
+ }else{+ s->buf = nil;
+ _buf_realloc(s, IOS_BUFSIZE);
+ }
+ s->size = s->bpos = 0;
+}
+
+uint8_t *
+ios_takebuf(ios_t *s, size_t *psize)
+{+ uint8_t *buf;
+
+ ios_flush(s);
+
+ if(s->buf == &s->local[0] || s->buf == nil || (!s->ownbuf && s->size == s->maxsize)){+ buf = MEM_ALLOC(s->size+1);
+ if(buf == nil)
+ return nil;
+ if(s->buf != nil)
+ memcpy(buf, s->buf, s->size);
+ }else if(s->size == s->maxsize){+ buf = MEM_REALLOC(s->buf, s->size + 1);
+ if(buf == nil)
+ return nil;
+ }else{+ buf = s->buf;
+ }
+ buf[s->size] = '\0';
+ *psize = s->size + 1;
+
+ /* empty stream and reinitialize */
+ _buf_init(s, s->bm);
+
+ return buf;
+}
+
+int
+ios_setbuf(ios_t *s, uint8_t *buf, size_t size, int own)
+{+ ios_flush(s);
+ size_t nvalid;
+
+ nvalid = size < s->size ? size : s->size;
+ if(nvalid > 0)
+ memcpy(buf, s->buf, nvalid);
+ if(s->bpos > nvalid){+ // truncated
+ s->bpos = nvalid;
+ }
+ s->size = nvalid;
+
+ if(s->buf != nil && s->ownbuf && s->buf != &s->local[0])
+ MEM_FREE(s->buf);
+ s->buf = buf;
+ s->maxsize = size;
+ s->ownbuf = own;
+ return 0;
+}
+
+int
+ios_bufmode(ios_t *s, bufmode_t mode)
+{+ // no fd; can only do mem-only buffering
+ if(s->fd == -1 && mode != bm_mem)
+ return -1;
+ s->bm = mode;
+ return 0;
+}
+
+void
+ios_set_readonly(ios_t *s)
+{+ if(s->readonly)
+ return;
+ ios_flush(s);
+ s->state = bst_none;
+ s->readonly = 1;
+}
+
+static size_t
+ios_copy_(ios_t *to, ios_t *from, size_t nbytes, int all)
+{+ size_t total = 0, avail;
+ if(!ios_eof(from)){+ do{+ avail = ios_readprep(from, IOS_BUFSIZE/2);
+ if(avail == 0){+ from->_eof = 1;
+ break;
+ }
+ size_t written, ntowrite;
+ ntowrite = (avail <= nbytes || all) ? avail : nbytes;
+ written = ios_write(to, from->buf+from->bpos, ntowrite);
+ // TODO: should this be +=written instead?
+ from->bpos += ntowrite;
+ total += written;
+ if(!all){+ nbytes -= written;
+ if(nbytes == 0)
+ break;
+ }
+ if(written < ntowrite)
+ break;
+ }while(!ios_eof(from));
+ }
+ return total;
+}
+
+size_t
+ios_copy(ios_t *to, ios_t *from, size_t nbytes)
+{+ return ios_copy_(to, from, nbytes, 0);
+}
+
+size_t
+ios_copyall(ios_t *to, ios_t *from)
+{+ return ios_copy_(to, from, 0, 1);
+}
+
+#define LINE_CHUNK_SIZE 160
+
+size_t
+ios_copyuntil(ios_t *to, ios_t *from, uint8_t delim)
+{+ size_t total = 0, avail = from->size - from->bpos;
+ int first = 1;
+ if(!ios_eof(from)){+ do{+ if(avail == 0){+ first = 0;
+ avail = ios_readprep(from, LINE_CHUNK_SIZE);
+ }
+ size_t written;
+ uint8_t *pd = memchr(from->buf+from->bpos, delim, avail);
+ if(pd == nil){+ written = ios_write(to, from->buf+from->bpos, avail);
+ from->bpos += avail;
+ total += written;
+ avail = 0;
+ }else{+ size_t ntowrite = pd - (from->buf+from->bpos) + 1;
+ written = ios_write(to, from->buf+from->bpos, ntowrite);
+ from->bpos += ntowrite;
+ total += written;
+ return total;
+ }
+ }while(!ios_eof(from) && (first || avail >= LINE_CHUNK_SIZE));
+ }
+ from->_eof = 1;
+ return total;
+}
+
+static void
+_ios_init(ios_t *s)
+{+ // put all fields in a sane initial state
+ memset(s, 0, sizeof(*s));
+ s->bm = bm_block;
+ s->state = bst_none;
+ s->fpos = -1;
+ s->fd = -1;
+ s->ownbuf = 1;
+ s->loc.lineno = 1;
+}
+
+/* stream object initializers. we do no allocation. */
+
+ios_t *
+ios_file(ios_t *s, char *fname, int rd, int wr, int creat, int trunc)
+{+ int fd;
+ if(!(rd || wr)) // must specify read and/or write
+ goto open_file_err;
+ int flags = wr ? (rd ? O_RDWR : O_WRONLY) : O_RDONLY;
+ if(trunc)
+ flags |= O_TRUNC;
+#if defined(__plan9__)
+ fd = creat ? create(fname, flags, 0644) : open(fname, flags);
+#else
+ if(creat)
+ flags |= O_CREAT;
+ fd = open(fname, flags, 0644);
+#endif
+ s = ios_fd(s, fd, 1, 1);
+ if(fd < 0)
+ goto open_file_err;
+ if(!wr)
+ s->readonly = 1;
+ s->loc.filename = MEM_STRDUP(fname);
+ return s;
+open_file_err:
+ s->fd = -1;
+ return nil;
+}
+
+ios_t *
+ios_mem(ios_t *s, size_t initsize)
+{+ _ios_init(s);
+ s->bm = bm_mem;
+ s->loc.filename = emptystr;
+ _buf_realloc(s, initsize);
+ return s;
+}
+
+ios_t *
+ios_static_buffer(ios_t *s, const uint8_t *buf, size_t sz)
+{+ ios_mem(s, 0);
+ ios_setbuf(s, (uint8_t*)buf, sz, 0);
+ s->size = sz;
+ ios_set_readonly(s);
+ return s;
+}
+
+ios_t *
+ios_fd(ios_t *s, int fd, int isfile, int own)
+{+ _ios_init(s);
+ s->fd = fd;
+ if(isfile)
+ s->rereadable = 1;
+ _buf_init(s, bm_block);
+ s->ownfd = own;
+ if(fd == STDERR_FILENO)
+ s->bm = bm_none;
+ return s;
+}
+
+void
+ios_init_stdstreams(void)
+{+ ios_stdin = MEM_ALLOC(sizeof(ios_t));
+ ios_fd(ios_stdin, STDIN_FILENO, 0, 0);
+ ios_stdin->loc.filename = MEM_STRDUP("*stdin*");+
+ ios_stdout = MEM_ALLOC(sizeof(ios_t));
+ ios_fd(ios_stdout, STDOUT_FILENO, 0, 0);
+ ios_stdout->bm = bm_line;
+ ios_stdout->loc.filename = MEM_STRDUP("*stdout*");+
+ ios_stderr = MEM_ALLOC(sizeof(ios_t));
+ ios_fd(ios_stderr, STDERR_FILENO, 0, 0);
+ ios_stderr->bm = bm_none;
+ ios_stderr->loc.filename = MEM_STRDUP("*stderr*");+}
+
+/* higher level interface */
+
+int
+ios_putc(ios_t *s, int c)
+{+ char ch = c;
+
+ if(s->state == bst_wr && s->bpos < s->maxsize && s->bm != bm_none){+ s->buf[s->bpos++] = ch;
+ _write_update_pos(s);
+ if(s->bm == bm_line && ch == '\n')
+ ios_flush(s);
+ return 1;
+ }
+ return ios_write(s, &ch, 1);
+}
+
+static void
+ios_loc(ios_t *s, uint8_t ch)
+{+ if(ch == '\n'){+ s->loc.lineno++;
+ s->loc.colno = 0;
+ s->colnowait = 0;
+ }else if(s->colnowait > 0){+ s->colnowait--;
+ }else{+ s->loc.colno++;
+ if(ch & 0x80){+ if((ch & 0xe0) == 0xc0)
+ s->colnowait = 1;
+ else if((ch & 0xf0) == 0xe0)
+ s->colnowait = 2;
+ else
+ s->colnowait = 3;
+ }
+ }
+}
+
+int
+ios_getc(ios_t *s)
+{+ uint8_t ch;
+ if(s->state == bst_rd && s->bpos < s->size)
+ ch = s->buf[s->bpos++];
+ else if(s->_eof || ios_read(s, &ch, 1) < 1)
+ return IOS_EOF;
+ ios_loc(s, ch);
+ return ch;
+}
+
+int
+ios_peekc(ios_t *s)
+{+ if(s->bpos < s->size)
+ return (uint8_t)s->buf[s->bpos];
+ if(s->_eof)
+ return IOS_EOF;
+ size_t n = ios_readprep(s, 1);
+ if(n == 0)
+ return IOS_EOF;
+ return (uint8_t)s->buf[s->bpos];
+}
+
+int
+ios_wait(ios_t *s, double ws)
+{+ if(s->bpos < s->size)
+ return 1;
+ if(s->_eof)
+ return IOS_EOF;
+#if defined(__plan9__) || defined(__macos__)
+ USED(ws);
+ return 1; // FIXME(sigrid): wait for input, but not too much
+#else
+ struct timeval t, *pt = nil;
+ if(ws >= 0){+ t.tv_sec = ws;
+ t.tv_usec = (long)((ws - t.tv_sec) * 1000000.0) % 1000000;
+ pt = &t;
+ }
+ fd_set f;
+ FD_ZERO(&f);
+ FD_SET(s->fd, &f);
+ int r;
+ while((r = select(s->fd+1, &f, nil, nil, pt)) == EINTR);
+ return r && FD_ISSET(s->fd, &f);
+#endif
+}
+
+int
+ios_getutf8(ios_t *s, Rune *r)
+{+ int c;
+ size_t i;
+ char buf[UTFmax];
+
+ for(i = 0; i < sizeof(buf); i++){+ if((c = ios_getc(s)) == IOS_EOF){+ s->_eof = 1;
+ return IOS_EOF;
+ }
+ buf[i] = c;
+ if(fullrune(buf, i+1))
+ break;
+ }
+ chartorune(r, buf);
+ if(*r == Runeerror)
+ return 0;
+ if(*r == '\n')
+ s->loc.colno = 0;
+ else
+ s->loc.colno++;
+ return 1;
+}
+
+int
+ios_pututf8(ios_t *s, Rune r)
+{+ char buf[UTFmax];
+ return ios_write(s, buf, runetochar(buf, &r));
+}
+
+void
+ios_purge(ios_t *s)
+{+ if(s->state == bst_rd){+ for(; s->bpos < s->size; s->bpos++)
+ ios_loc(s, s->buf[s->bpos]);
+ }
+}
+
+int
+ios_vprintf(ios_t *s, const char *format, va_list args)
+{+ char buf[256];
+ char *str;
+ int c;
+
+ if(s->state == bst_closed)
+ return -1;
+ /* skip allocations if no buffering needed */
+ if(s->bm == bm_none && (s->state == bst_none || s->state == bst_wr))
+ return vdprintf(s->fd, format, args);
+
+ if((c = vsnprintf(buf, sizeof(buf), format, args)) < nelem(buf))
+ str = buf;
+ else if(s->state == bst_none || s->state == bst_wr){+ /* doesn't fit? prefer no allocations */
+ ios_flush(s);
+ return vdprintf(s->fd, format, args);
+ }else{+ str = MEM_ALLOC(c+1);
+ c = vsnprintf(str, sizeof(c+1), format, args);
+ }
+ if(c > 0)
+ c = ios_write(s, str, c);
+ if(str != buf)
+ MEM_FREE(str);
+
+ return c;
+}
+
+int
+ios_printf(ios_t *s, const char *format, ...)
+{+ va_list args;
+ int c;
+
+ va_start(args, format);
+ c = ios_vprintf(s, format, args);
+ va_end(args);
+ return c;
+}
--- /dev/null
+++ b/src/ios.h
@@ -1,0 +1,191 @@
+// this flag controls when data actually moves out to the underlying I/O
+// channel. memory streams are a special case of this where the data
+// never moves out.
+typedef enum {+ bm_none,
+ bm_line,
+ bm_block,
+ bm_mem,
+}bufmode_t;
+
+typedef enum {+ bst_none,
+ bst_rd,
+ bst_wr,
+ bst_closed,
+}bufstate_t;
+
+#define IOS_INLSIZE 128
+#define IOS_BUFSIZE 32768
+
+typedef struct {+ char *filename;
+ uint32_t lineno;
+ uint32_t colno;
+}ios_loc_t;
+
+typedef struct {+ uint8_t *buf; // start of buffer
+ size_t maxsize; // space allocated to buffer
+ size_t size; // length of valid data in buf, >=ndirty
+ size_t bpos; // current position in buffer
+ size_t ndirty; // # bytes at &buf[0] that need to be written
+ off_t fpos; // cached file pos
+ ios_loc_t loc;
+ bufmode_t bm;
+ int colnowait;
+
+ // the state only indicates where the underlying file position is relative
+ // to the buffer. reading: at the end. writing: at the beginning.
+ // in general, you can do any operation in any state.
+ bufstate_t state;
+
+ int fd;
+
+ uint8_t readonly:1;
+ uint8_t ownbuf:1;
+ uint8_t ownfd:1;
+ uint8_t _eof:1;
+
+ // this means you can read, seek back, then read the same data
+ // again any number of times. usually only true for files and strings.
+ uint8_t rereadable:1;
+
+ // this enables "stenciled writes". you can alternately write and
+ // seek without flushing in between. this performs read-before-write
+ // to populate the buffer, so "rereadable" capability is required.
+ // this is off by default.
+ //uint8_t stenciled:1;
+
+ // request durable writes (fsync)
+ // uint8_t durable:1;
+
+ // todo: mutex
+ uint8_t local[IOS_INLSIZE];
+}ios_t;
+
+void *llt_memrchr(const void *s, int c, size_t n) fl_purefn;
+
+/* low-level interface functions */
+size_t ios_read(ios_t *s, void *dest, size_t n);
+size_t ios_write(ios_t *s, const void *data, size_t n);
+off_t ios_seek(ios_t *s, off_t pos); // absolute seek
+off_t ios_seek_end(ios_t *s);
+off_t ios_skip(ios_t *s, off_t offs); // relative seek
+off_t ios_pos(ios_t *s); // get current position
+int ios_trunc(ios_t *s, off_t size);
+bool ios_eof(ios_t *s) fl_purefn;
+int ios_flush(ios_t *s);
+void ios_close(ios_t *s);
+void ios_free(ios_t *s);
+uint8_t *ios_takebuf(ios_t *s, size_t *psize); // null-terminate and release buffer to caller
+// set buffer space to use
+int ios_setbuf(ios_t *s, uint8_t *buf, size_t size, int own);
+int ios_bufmode(ios_t *s, bufmode_t mode);
+void ios_set_readonly(ios_t *s);
+size_t ios_copy(ios_t *to, ios_t *from, size_t nbytes);
+size_t ios_copyall(ios_t *to, ios_t *from);
+size_t ios_copyuntil(ios_t *to, ios_t *from, uint8_t delim);
+
+int ios_wait(ios_t *s, double ws);
+
+/* stream creation */
+ios_t *ios_file(ios_t *s, char *fname, int rd, int wr, int create, int trunc);
+ios_t *ios_mem(ios_t *s, size_t initsize);
+ios_t *ios_static_buffer(ios_t *s, const uint8_t *buf, size_t sz);
+ios_t *ios_fd(ios_t *s, int fd, int isfile, int own);
+// todo: ios_socket
+extern ios_t *ios_stdin;
+extern ios_t *ios_stdout;
+extern ios_t *ios_stderr;
+void ios_init_stdstreams(void);
+
+/* high-level functions - output */
+int ios_pututf8(ios_t *s, Rune r);
+int ios_printf(ios_t *s, const char *format, ...) fl_printfmt(2, 3);
+int ios_vprintf(ios_t *s, const char *format, va_list args) fl_printfmt(2, 0);
+
+void hexdump(ios_t *dest, const uint8_t *buffer, size_t len, size_t startoffs);
+
+/* high-level stream functions - input */
+int ios_getutf8(ios_t *s, Rune *r);
+
+// discard data buffered for reading
+void ios_purge(ios_t *s);
+
+/* stdio-style functions */
+#define IOS_EOF (-1)
+int ios_putc(ios_t *s, int c);
+int ios_getc(ios_t *s);
+int ios_peekc(ios_t *s);
+#define ios_puts(s, str) ios_write(s, str, strlen(str))
+
+/*
+ With memory streams, mixed reads and writes are equivalent to performing
+ sequences of *p++, as either an lvalue or rvalue. File streams behave
+ similarly, but other streams might not support this. Using unbuffered
+ mode makes this more predictable.
+
+ Note on "unget" functions:
+ There are two kinds of functions here: those that operate on sized
+ blocks of bytes and those that operate on logical units like "character"
+ or "integer". The "unget" functions only work on logical units. There
+ is no "unget n bytes". You can only do an unget after a matching get.
+ However, data pushed back by an unget is available to all read operations.
+ The reason for this is that unget is defined in terms of its effect on
+ the underlying buffer (namely, it rebuffers data as if it had been
+ buffered but not read yet). IOS reserves the right to perform large block
+ operations directly, bypassing the buffer. In such a case data was
+ never buffered, so "rebuffering" has no meaning (i.e. there is no
+ correspondence between the buffer and the physical stream).
+
+ Single-bit I/O is able to write partial bytes ONLY IF the stream supports
+ seeking. Also, line buffering is not well-defined in the context of
+ single-bit I/O, so it might not do what you expect.
+
+ implementation notes:
+ in order to know where we are in a file, we must ensure the buffer
+ is only populated from the underlying stream starting with p==buf.
+
+ to switch from writing to reading: flush, set p=buf, cnt=0
+ to switch from reading to writing: seek backwards cnt bytes, p=buf, cnt=0
+
+ when writing: buf starts at curr. physical stream pos, p - buf is how
+ many bytes we've written logically. cnt==0
+
+ dirty == (bitpos>0 && state==iost_wr), EXCEPT right after switching from
+ reading to writing, where we might be in the middle of a byte without
+ having changed it.
+
+ to write a bit: if !dirty, read up to maxsize-(p-buf) into buffer, then
+ seek back by the same amount (undo it). write onto those bits. now set
+ the dirty bit. in this state, we can bit-read up to the end of the byte,
+ then formally switch to the read state using flush.
+
+ design points:
+ - data-source independence, including memory streams
+ - expose buffer to user, allow user-owned buffers
+ - allow direct I/O, don't always go through buffer
+ - buffer-internal seeking. makes seeking back 1-2 bytes very fast,
+ and makes it possible for sockets where it otherwise wouldn't be
+ - tries to allow switching between reading and writing
+ - support 64-bit and large files
+ - efficient, low-latency buffering
+ - special support for utf8
+ - type-aware functions with byte-order swapping service
+ - position counter for meaningful data offsets with sockets
+
+ theory of operation:
+
+ the buffer is a view of part of a file/stream. you can seek, read, and
+ write around in it as much as you like, as if it were just a string.
+
+ we keep track of the part of the buffer that's invalid (written to).
+ we remember whether the position of the underlying stream is aligned
+ with the end of the buffer (reading mode) or the beginning (writing mode).
+
+ based on this info, we might have to seek back before doing a flush.
+
+ as optimizations, we do no writing if the buffer isn't "dirty", and we
+ do no reading if the data will only be overwritten.
+*/
--- /dev/null
+++ b/src/iostream.c
@@ -1,0 +1,449 @@
+#include "flisp.h"
+#include "cvalues.h"
+#include "types.h"
+#include "print.h"
+#include "read.h"
+#include "iostream.h"
+
+static void
+print_iostream(value_t v, ios_t *f)
+{+ ios_t *s = value2c(ios_t*, v);
+ fl_print_str(f, "#<io stream");
+ if(*s->loc.filename){+ fl_print_chr(f, ' ');
+ fl_print_str(f, s->loc.filename);
+ }
+ fl_print_chr(f, '>');
+}
+
+static void
+free_iostream(value_t self)
+{+ ios_t *s = value2c(ios_t*, self);
+ ios_close(s);
+ ios_free(s);
+}
+
+static void
+relocate_iostream(value_t oldv, value_t newv)
+{+ ios_t *olds = value2c(ios_t*, oldv);
+ ios_t *news = value2c(ios_t*, newv);
+ if(news->buf == &olds->local[0])
+ news->buf = &news->local[0];
+}
+
+static cvtable_t iostream_vtable = {+ print_iostream,
+ relocate_iostream,
+ free_iostream,
+ nil
+};
+
+static int
+isiostream(value_t v)
+{+ return iscvalue(v) && cv_class(ptr(v)) == FL(iostreamtype);
+}
+
+fl_purefn
+BUILTIN("iostream?", iostreamp)+{+ argcount(nargs, 1);
+ return isiostream(args[0]) ? FL_t : FL_f;
+}
+
+fl_purefn
+BUILTIN("eof-object?", eof_objectp)+{+ argcount(nargs, 1);
+ return args[0] == FL_eof ? FL_t : FL_f;
+}
+
+fl_purefn
+ios_t *
+toiostream(value_t v)
+{+ if(fl_unlikely(!isiostream(v)))
+ type_error("iostream", v);+ return value2c(ios_t*, v);
+}
+
+BUILTIN("file", file)+{+ if(nargs < 1)
+ argcount(nargs, 1);
+ size_t i;
+ int r = 0, w = 0, c = 0, t = 0, a = 0;
+ for(i = 1; i < nargs; i++){+ if(args[i] == FL_rdsym)
+ r = 1;
+ else if(args[i] == FL_wrsym)
+ w = 1;
+ else if(args[i] == FL_apsym)
+ a = w = 1;
+ else if(args[i] == FL_crsym)
+ c = w = 1;
+ else if(args[i] == FL_truncsym)
+ t = w = 1;
+ }
+ if((r|w|c|t|a) == 0)
+ r = 1; // default to reading
+ value_t f = cvalue(FL(iostreamtype), sizeof(ios_t));
+ char *fname = tostring(args[0]);
+ ios_t *s = value2c(ios_t*, f);
+ if(ios_file(s, fname, r, w, c, t) == nil)
+ lerrorf(FL_IOError, "could not open \"%s\"", fname);
+ if(a)
+ ios_seek_end(s);
+ return f;
+}
+
+BUILTIN("buffer", buffer)+{+ argcount(nargs, 0);
+ USED(args);
+ value_t f = cvalue(FL(iostreamtype), sizeof(ios_t));
+ ios_t *s = value2c(ios_t*, f);
+ if(ios_mem(s, 0) == nil)
+ lerrorf(FL_MemoryError, "could not allocate stream");
+ return f;
+}
+
+BUILTIN("read", read)+{+ if(nargs > 1)
+ argcount(nargs, 1);
+ value_t a = nargs == 0 ? symbol_value(FL_instrsym) : args[0];
+ ios_t *s = toiostream(a);
+ value_t v = fl_read_sexpr(a);
+ return ios_eof(s) ? FL_eof : v;
+}
+
+BUILTIN("io-getc", io_getc)+{+ argcount(nargs, 1);
+ ios_t *s = toiostream(args[0]);
+ Rune r;
+ int res;
+ if((res = ios_getutf8(s, &r)) == IOS_EOF)
+ //lerrorf(FL_IOError, "end of file reached");
+ return FL_eof;
+ if(res == 0)
+ lerrorf(FL_IOError, "invalid UTF-8 sequence");
+ return mk_rune(r);
+}
+
+BUILTIN("io-wait", io_wait)+{+ if(nargs > 2)
+ argcount(nargs, 2);
+ ios_t *s = toiostream(args[0]);
+ int r = ios_wait(s, nargs > 1 ? todouble(args[1]) : -1);
+ if(r >= 0)
+ return r ? FL_t : FL_f;
+ if(r == IOS_EOF)
+ return FL_eof;
+ lerrorf(FL_IOError, "i/o error");
+}
+
+BUILTIN("io-putc", io_putc)+{+ argcount(nargs, 2);
+ ios_t *s = toiostream(args[0]);
+ if(!iscprim(args[1]) || ((cprim_t*)ptr(args[1]))->type != FL(runetype))
+ type_error("rune", args[1]);+ Rune r = *(Rune*)cp_data(ptr(args[1]));
+ return fixnum(ios_pututf8(s, r));
+}
+
+BUILTIN("io-skip", io_skip)+{+ argcount(nargs, 2);
+ ios_t *s = toiostream(args[0]);
+ off_t off = tooffset(args[1]);
+ off_t res = ios_skip(s, off);
+ if(res < 0)
+ return FL_f;
+ return sizeof(res) == sizeof(int64_t) ? mk_int64(res) : mk_int32(res);
+}
+
+BUILTIN("io-flush", io_flush)+{+ argcount(nargs, 1);
+ return ios_flush(toiostream(args[0])) == 0 ? FL_t : FL_f;
+}
+
+BUILTIN("io-close", io_close)+{+ argcount(nargs, 1);
+ ios_close(toiostream(args[0]));
+ return FL_void;
+}
+
+BUILTIN("io-truncate", io_truncate)+{+ argcount(nargs, 2);
+ ios_t *s = toiostream(args[0]);
+ if(ios_trunc(s, tooffset(args[1])) < 0)
+ lerrorf(FL_IOError, "truncation failed");
+ return FL_void;
+}
+
+BUILTIN("io-discardbuffer", io_discardbuffer)+{+ argcount(nargs, 1);
+ ios_purge(toiostream(args[0]));
+ return FL_void;
+}
+
+fl_purefn
+BUILTIN("io-eof?", io_eofp)+{+ argcount(nargs, 1);
+ return ios_eof(toiostream(args[0])) ? FL_t : FL_f;
+}
+
+BUILTIN("io-seek", io_seek)+{+ argcount(nargs, 2);
+ ios_t *s = toiostream(args[0]);
+ size_t pos = tosize(args[1]);
+ off_t res = ios_seek(s, (off_t)pos);
+ if(res < 0)
+ return FL_f;
+ return FL_t;
+}
+
+BUILTIN("io-pos", io_pos)+{+ argcount(nargs, 1);
+ ios_t *s = toiostream(args[0]);
+ off_t res = ios_pos(s);
+ if(res < 0)
+ return FL_f;
+ return size_wrap((size_t)res);
+}
+
+BUILTIN("write", write)+{+ if(nargs < 1 || nargs > 2)
+ argcount(nargs, 1);
+ ios_t *s;
+ s = nargs == 2 ? toiostream(args[1]) : toiostream(symbol_value(FL_outstrsym));
+ fl_print(s, args[0]);
+ return args[0];
+}
+
+BUILTIN("io-read", io_read)+{+ if(nargs != 3)
+ argcount(nargs, 2);
+ ios_t *s = toiostream(args[0]);
+ size_t n;
+ fltype_t *ft;
+ if(nargs == 3){+ // form (io.read s type count)
+ ft = get_array_type(args[1]);
+ n = tosize(args[2]) * ft->elsz;
+ }else{+ ft = get_type(args[1]);
+ if(ft->eltype != nil && !iscons(cdr_(cdr_(args[1]))))
+ lerrorf(FL_ArgError, "incomplete type");
+ n = ft->size;
+ }
+ value_t cv = cvalue(ft, n);
+ uint8_t *data = cptr(cv);
+ size_t got = ios_read(s, data, n);
+ if(got < n)
+ //lerrorf(FL_IOError, "end of input reached");
+ return FL_eof;
+ return cv;
+}
+
+// args must contain data[, offset[, count]]
+static void
+get_start_count_args(value_t *args, uint32_t nargs, size_t sz, size_t *offs, size_t *nb)
+{+ if(nargs > 1){+ *offs = tosize(args[1]);
+ *nb = nargs > 2 ? tosize(args[2]) : sz - *offs;
+ if(*offs >= sz || *offs + *nb > sz)
+ bounds_error(args[0], args[1]);
+ }
+}
+
+BUILTIN("io-write", io_write)+{+ if(nargs < 2 || nargs > 4)
+ argcount(nargs, 2);
+ ios_t *s = toiostream(args[0]);
+ if(iscprim(args[1]) && ((cprim_t*)ptr(args[1]))->type == FL(runetype)){+ if(nargs > 2)
+ lerrorf(FL_ArgError, "offset argument not supported for characters");
+ Rune r = *(Rune*)cp_data(ptr(args[1]));
+ return fixnum(ios_pututf8(s, r));
+ }
+ uint8_t *data;
+ size_t sz, offs = 0;
+ to_sized_ptr(args[1], &data, &sz);
+ size_t nb = sz;
+ if(nargs > 2){+ get_start_count_args(&args[1], nargs-1, sz, &offs, &nb);
+ data += offs;
+ }
+ return size_wrap(ios_write(s, data, nb));
+}
+
+static uint8_t
+get_delim_arg(value_t arg)
+{+ size_t uldelim = tosize(arg);
+ if(uldelim > 0x7f){+ // runes > 0x7f, or anything else > 0xff, are out of range
+ if((iscprim(arg) && cp_class(ptr(arg)) == FL(runetype)) || uldelim > 0xff)
+ lerrorf(FL_ArgError, "delimiter out of range");
+ }
+ return (uint8_t)uldelim;
+}
+
+BUILTIN("io-readuntil", io_readuntil)+{+ argcount(nargs, 2);
+ value_t str = cvalue_string(80);
+ cvalue_t *cv = ptr(str);
+ uint8_t *data = cv_data(cv);
+ ios_t dest;
+ ios_mem(&dest, 0);
+ ios_setbuf(&dest, data, 80, 0);
+ uint8_t delim = get_delim_arg(args[1]);
+ ios_t *src = toiostream(args[0]);
+ size_t n = ios_copyuntil(&dest, src, delim);
+ cv->len = n;
+ if(dest.buf != data){+ // outgrew initial space
+ size_t sz;
+ cv->data = ios_takebuf(&dest, &sz);
+ cv_autorelease(cv);
+ }else{+ ((uint8_t*)cv->data)[n] = 0;
+ }
+ if(n == 0 && ios_eof(src))
+ return FL_eof;
+ return str;
+}
+
+BUILTIN("io-copyuntil", io_copyuntil)+{+ argcount(nargs, 3);
+ ios_t *dest = toiostream(args[0]);
+ ios_t *src = toiostream(args[1]);
+ uint8_t delim = get_delim_arg(args[2]);
+ return size_wrap(ios_copyuntil(dest, src, delim));
+}
+
+BUILTIN("io-copy", io_copy)+{+ if(nargs < 2 || nargs > 3)
+ argcount(nargs, 2);
+ ios_t *dest = toiostream(args[0]);
+ ios_t *src = toiostream(args[1]);
+ if(nargs == 3)
+ return size_wrap(ios_copy(dest, src, tosize(args[2])));
+ return size_wrap(ios_copyall(dest, src));
+}
+
+BUILTIN("io-filename", io_filename)+{+ argcount(nargs, 1);
+ return string_from_cstr(toiostream(args[0])->loc.filename);
+}
+
+BUILTIN("io-set-filename!", io_set_filename)+{+ argcount(nargs, 2);
+ ios_t *s = toiostream(args[0]);
+ char *f = tostring(args[1]);
+ MEM_FREE(s->loc.filename);
+ s->loc.filename = MEM_STRDUP(f);
+ return args[1];
+}
+
+BUILTIN("io-line", io_line)+{+ argcount(nargs, 1);
+ return size_wrap(toiostream(args[0])->loc.lineno);
+}
+
+BUILTIN("io-set-line!", io_set_line)+{+ argcount(nargs, 2);
+ toiostream(args[0])->loc.lineno = tosize(args[1]);
+ return args[1];
+}
+
+BUILTIN("io-column", io_column)+{+ argcount(nargs, 1);
+ return size_wrap(toiostream(args[0])->loc.colno);
+}
+
+BUILTIN("io-set-column!", io_set_column)+{+ argcount(nargs, 2);
+ toiostream(args[0])->loc.colno = tosize(args[1]);
+ return args[1];
+}
+
+value_t
+stream_to_string(value_t *ps)
+{+ value_t str;
+ size_t n;
+ ios_t *st = value2c(ios_t*, *ps);
+ if(st->buf == &st->local[0]){+ n = st->size;
+ str = cvalue_string(n);
+ memcpy(cvalue_data(str), st->buf, n);
+ ios_trunc(st, 0);
+ }else{+ uint8_t *b = ios_takebuf(st, &n); n--;
+ if(n == 0)
+ return FL(the_empty_string);
+ b[n] = '\0';
+ str = cvalue_from_ref(FL(stringtype), b, n, FL_nil);
+ cv_autorelease(ptr(str));
+ }
+ return str;
+}
+
+BUILTIN("iostream->string", io_tostring)+{+ argcount(nargs, 1);
+ ios_t *src = toiostream(args[0]);
+ if(src->bm != bm_mem)
+ lerrorf(FL_ArgError, "requires memory stream");
+ bool eof = ios_eof(src);
+ value_t v = stream_to_string(&args[0]);
+ if(eof && v == FL(the_empty_string))
+ v = FL_eof;
+ return v;
+}
+
+void
+iostream_init(void)
+{+ FL_iostreamsym = symbol("iostream", false);+ FL_rdsym = symbol(":read", false);+ FL_wrsym = symbol(":write", false);+ FL_apsym = symbol(":append", false);+ FL_crsym = symbol(":create", false);+ FL_truncsym = symbol(":truncate", false);+ FL_instrsym = symbol("*input-stream*", false);+ FL_outstrsym = symbol("*output-stream*", false);+ FL(iostreamtype) = define_opaque_type(FL_iostreamsym, sizeof(ios_t), &iostream_vtable, nil);
+ set(symbol("*stdout*", false), cvalue_from_ref(FL(iostreamtype), ios_stdout, sizeof(ios_t), FL_nil));+ set(symbol("*stderr*", false), cvalue_from_ref(FL(iostreamtype), ios_stderr, sizeof(ios_t), FL_nil));+ set(symbol("*stdin*", false), cvalue_from_ref(FL(iostreamtype), ios_stdin, sizeof(ios_t), FL_nil));+}
--- /dev/null
+++ b/src/iostream.h
@@ -1,0 +1,3 @@
+ios_t *toiostream(value_t v);
+value_t stream_to_string(value_t *ps);
+void iostream_init(void);
--- /dev/null
+++ b/src/macos/femtolispm68k.r
@@ -1,0 +1,22 @@
+#include "Retro68APPL.r"
+
+resource 'SIZE' (-1) {+ reserved,
+ ignoreSuspendResumeEvents,
+ reserved,
+ cannotBackground,
+ needsActivateOnFGSwitch,
+ backgroundAndForeground,
+ dontGetFrontClicks,
+ ignoreChildDiedEvents,
+ is32BitCompatible,
+ notHighLevelEventAware,
+ onlyLocalHLEvents,
+ notStationeryAware,
+ dontUseTextEditServices,
+ reserved,
+ reserved,
+ reserved,
+ 4 * 1024 * 1024,
+ 1 * 1024 * 1024
+};
--- /dev/null
+++ b/src/macos/femtolispppc.r
@@ -1,0 +1,22 @@
+#include "RetroPPCAPPL.r"
+
+resource 'SIZE' (-1) {+ reserved,
+ ignoreSuspendResumeEvents,
+ reserved,
+ cannotBackground,
+ needsActivateOnFGSwitch,
+ backgroundAndForeground,
+ dontGetFrontClicks,
+ ignoreChildDiedEvents,
+ is32BitCompatible,
+ notHighLevelEventAware,
+ onlyLocalHLEvents,
+ notStationeryAware,
+ dontUseTextEditServices,
+ reserved,
+ reserved,
+ reserved,
+ 16 * 1024 * 1024,
+ 8 * 1024 * 1024
+};
--- /dev/null
+++ b/src/macos/platform.h
@@ -1,0 +1,57 @@
+#pragma once
+
+#define _XOPEN_SOURCE 700
+#include <assert.h>
+#include <ctype.h>
+#include <errno.h>
+#include <fcntl.h>
+#include <float.h>
+#include <inttypes.h>
+#include <limits.h>
+#include <locale.h>
+#include <math.h>
+#include <setjmp.h>
+#include <stdbool.h>
+#include <stdarg.h>
+#include <stdio.h>
+#include <stddef.h>
+#include <stdint.h>
+#include <stdlib.h>
+#include <string.h>
+#include <strings.h>
+#include <sys/stat.h>
+#include <sys/time.h>
+#include <time.h>
+#include <unistd.h>
+#include <wctype.h>
+#include <wchar.h>
+
+#define __os_name__ "macos"
+extern char os_version[];
+#define __os_version__ os_version
+
+#define nil NULL
+#define USED(x) ((void)(x))
+#define nelem(x) (int)(sizeof(x)/sizeof((x)[0]))
+
+#define PATHSEP '/'
+#define PATHSEPSTRING "/"
+#define PATHLISTSEP ':'
+#define PATHLISTSEPSTRING ":"
+#define ISPATHSEP(c) ((c) == '/')
+
+#ifndef BYTE_ORDER
+#error unknown byte order
+#endif
+
+#if !defined(INITIAL_HEAP_SIZE)
+#define INITIAL_HEAP_SIZE 128*1024
+#endif
+#if !defined(ALLOC_LIMIT_TRIGGER)
+#define ALLOC_LIMIT_TRIGGER INITIAL_HEAP_SIZE
+#endif
+
+#include "cc.h"
+#include "mem.h"
+#include "mp.h"
+#include "utf.h"
--- /dev/null
+++ b/src/macos/sys.c
@@ -1,0 +1,94 @@
+#include <OSUtils.h>
+#include "flisp.h"
+#include "timefuncs.h"
+
+double
+sec_realtime(void)
+{+ struct timeval now;
+
+ if(gettimeofday(&now, nil) != 0)
+ return 0.0;
+ return (double)now.tv_sec + (double)now.tv_usec/1.0e6;
+}
+
+/*
+ * nsec() is wallclock and can be adjusted by timesync
+ * so need to use cycles() instead, but fall back to
+ * nsec() in case we can't
+ */
+uint64_t
+nanosec_monotonic(void)
+{+ return 0;
+}
+
+void
+timestring(double s, char *buf, int sz)
+{+ USED(s); USED(sz);
+ buf[0] = 0;
+}
+
+double
+parsetime(const char *s)
+{+ USED(s);
+ return 0.0;
+}
+
+void
+sleep_ms(int ms)
+{+ USED(ms);
+}
+
+int
+ftruncate(int f, off_t sz)
+{+ USED(f); USED(sz);
+ return -1;
+}
+
+char *
+getcwd(char *buf, size_t len)
+{+ USED(buf); USED(len);
+ return nil;
+}
+
+int
+chdir(const char *path)
+{+ USED(path);
+ return -1;
+}
+
+int
+access(const char *path, int amode)
+{+ USED(path); USED(amode);
+ return -1;
+}
+
+char os_version[10];
+
+static const uint8_t boot[] = {+#include "flisp.boot.h"
+};
+
+int
+main(int argc, char **argv)
+{+ static SysEnvRec r;
+ memset(&r, 0, sizeof(r));
+ SysEnvirons(2, &r);
+ snprintf(
+ os_version, sizeof(boot),
+ "%d.%d.%d",
+ r.systemVersion>>8,
+ (r.systemVersion>>4)&0xf,
+ (r.systemVersion>>0)&0xf
+ );
+ flmain(boot, sizeof(boot), argc, argv);
+}
--- /dev/null
+++ b/src/maxstack.inc
@@ -1,0 +1,166 @@
+fl_purefn
+static int
+compute_maxstack(uint8_t *code, size_t len)
+{+ uint8_t *ip = code+4, *end = code+len;
+ int i, n, sp = 0, maxsp = 0;
+
+ while(ip < end){+ opcode_t op = *ip++;
+ if(op >= N_OPCODES)
+ return -1;
+ switch(op){+ case OP_LOADA: case OP_LOADI8: case OP_LOADV: case OP_LOADG:
+ ip++; // fallthrough
+ case OP_LOADA0: case OP_LOADA1:
+ case OP_DUP: case OP_LOADT: case OP_LOADF: case OP_LOADNIL: case OP_LOADVOID:
+ case OP_LOAD0:
+ case OP_LOAD1: case OP_LOADC0:
+ case OP_LOADC1:
+ sp++;
+ break;
+
+ case OP_BRF: case OP_BRT:
+ SWAP_INT16(ip);
+ ip += 2;
+ sp--;
+ break;
+
+ case OP_POP: case OP_RET:
+ case OP_CONS: case OP_SETCAR: case OP_SETCDR:
+ case OP_EQ: case OP_EQV: case OP_EQUAL: case OP_ADD2: case OP_SUB2:
+ case OP_IDIV: case OP_COMPARE:
+ case OP_AREF2: case OP_TRYCATCH:
+ sp--;
+ break;
+
+ case OP_AREF:
+ n = 2 + *ip++;
+ sp -= n;
+ break;
+
+ case OP_ARGC: case OP_SETG: case OP_SETA: case OP_BOX:
+ ip++;
+ continue;
+
+ case OP_TCALL: case OP_CALL: case OP_CLOSURE: case OP_SHIFT:
+ n = *ip++; // nargs
+ sp -= n;
+ break;
+
+ case OP_LOADVL: case OP_LOADGL: case OP_LOADAL:
+ sp++; // fallthrough
+ case OP_SETGL: case OP_SETAL: case OP_LARGC: case OP_BOXL:
+ SWAP_INT32(ip);
+ ip += 4;
+ break;
+
+ case OP_LOADC:
+ sp++;
+ ip++;
+ break;
+
+ case OP_VARGC:
+ n = *ip++;
+ sp += n+2;
+ break;
+ case OP_LVARGC:
+ SWAP_INT32(ip);
+ n = GET_INT32(ip); ip += 4;
+ sp += n+2;
+ break;
+ case OP_OPTARGS:
+ SWAP_INT32(ip);
+ i = GET_INT32(ip); ip += 4;
+ SWAP_INT32(ip);
+ n = abs(GET_INT32(ip)); ip += 4;
+ sp += n-i;
+ break;
+ case OP_KEYARGS:
+ SWAP_INT32(ip);
+ i = GET_INT32(ip); ip += 4;
+ SWAP_INT32(ip);
+ ip += 4;
+ SWAP_INT32(ip);
+ n = abs(GET_INT32(ip)); ip += 4;
+ sp += n-i;
+ break;
+ case OP_BRBOUND:
+ SWAP_INT32(ip);
+ ip += 4;
+ sp++;
+ break;
+ case OP_TCALLL: case OP_CALLL:
+ SWAP_INT32(ip);
+ n = GET_INT32(ip); ip+=4;
+ sp -= n;
+ break;
+ case OP_JMP:
+ SWAP_INT16(ip);
+ ip += 2;
+ continue;
+ case OP_JMPL:
+ SWAP_INT32(ip);
+ ip += 4;
+ continue;
+ case OP_BRFL: case OP_BRTL:
+ SWAP_INT32(ip);
+ ip += 4;
+ sp--;
+ break;
+ case OP_BRNE:
+ SWAP_INT16(ip);
+ ip += 2;
+ sp -= 2;
+ break;
+ case OP_BRNEL:
+ SWAP_INT32(ip);
+ ip += 4;
+ sp -= 2;
+ break;
+ case OP_BRNN: case OP_BRN:
+ SWAP_INT16(ip);
+ ip += 2;
+ sp--;
+ break;
+ case OP_BRNNL: case OP_BRNL:
+ SWAP_INT32(ip);
+ ip += 4; // fallthrough
+ case OP_TAPPLY: case OP_APPLY:
+ case OP_LIST: case OP_ADD: case OP_SUB: case OP_MUL: case OP_DIV:
+ case OP_VECTOR: case OP_LT: case OP_NUMEQ:
+ n = *ip++;
+ sp -= n-1;
+ break;
+
+ case OP_FOR:
+ if(maxsp < sp+2)
+ maxsp = sp+2; // fallthrough
+ case OP_ASET:
+ sp -= 2;
+ break;
+
+ case OP_LOADCL:
+ sp++; // fallthrough
+ SWAP_INT32(ip);
+ ip += 4;
+ break;
+
+ case OP_CAR: case OP_CDR: case OP_CADR:
+ case OP_NOT: case OP_NEG:
+ case OP_CONSP: case OP_ATOMP: case OP_SYMBOLP:
+ case OP_NULLP: case OP_BOOLEANP: case OP_NUMBERP:
+ case OP_FIXNUMP: case OP_BOUNDP: case OP_BUILTINP:
+ case OP_FUNCTIONP: case OP_VECTORP: case OP_NANP:
+ continue;
+
+ case OP_EOF_OBJECT: case N_OPCODES:
+ return -1;
+ }
+ if((int32_t)sp > (int32_t)maxsp)
+ maxsp = sp;
+ }
+ assert(ip == end);
+ assert(maxsp >= 0);
+ return maxsp+4;
+}
--- /dev/null
+++ b/src/mem.c
@@ -1,0 +1,81 @@
+#if defined(__macos__)
+#include <MacMemory.h>
+#endif
+#include "platform.h"
+
+#define HAVE_MORECORE 1
+#define MORECORE fl_sbrk
+static void *fl_sbrk(intptr_t increment);
+#define MORECORE_CONTIGUOUS 0
+#define MORECORE_CANNOT_TRIM 1
+#define NO_SEGMENT_TRAVERSAL 1
+#define USE_BUILTIN_FFS 1
+#define MALLOC_ALIGNMENT 8
+#define USE_LOCKS 0
+#define USE_DL_PREFIX 1
+#define LACKS_SYS_PARAM_H
+#define LACKS_FCNTL_H
+#define LACKS_TIME_H
+#define LACKS_SYS_TYPES_H
+#define HAVE_MMAP 0
+#define HAVE_MREMAP 0
+#define NO_MALLINFO 1
+#define NO_MALLOC_STATS 1
+#define DEFAULT_GRANULARITY 64
+#define malloc_getpagesize 4096
+#include "dlmalloc.inc"
+
+void *
+fl_malloc(size_t size)
+{+ return dlmalloc(size);
+}
+
+void
+fl_free(void *p)
+{+ dlfree(p);
+}
+
+void *
+fl_calloc(size_t n, size_t size)
+{+ return dlcalloc(n, size);
+}
+
+void *
+fl_realloc(void *p, size_t size)
+{+ return dlrealloc(p, size);
+}
+
+char *
+fl_strdup(const char *s)
+{+ size_t sz = strlen(s)+1;
+ char *p = dlmalloc(sz);
+ memcpy(p, s, sz);
+ return p;
+}
+
+#if defined(__macos__)
+static void *
+fl_sbrk(intptr_t increment)
+{+ static char *e = nil;
+ if(increment == 0)
+ return e;
+ if(increment < 0)
+ return MFAIL;
+ increment = (increment + malloc_getpagesize-1) & ~(malloc_getpagesize-1);
+ char *p = NewPtr(increment);
+ e = p + increment;
+ return p;
+}
+#else
+static void *
+fl_sbrk(intptr_t increment)
+{+ return sbrk(increment);
+}
+#endif
--- /dev/null
+++ b/src/mem.h
@@ -1,0 +1,18 @@
+#if defined(USE_DLMALLOC)
+void *fl_malloc(size_t);
+void fl_free(void *);
+void *fl_calloc(size_t, size_t);
+void *fl_realloc(void *, size_t);
+char *fl_strdup(const char *s);
+#define MEM_CALLOC(n, sz) fl_calloc((size_t)(n), (size_t)(sz))
+#define MEM_ALLOC(n) fl_malloc((size_t)(n))
+#define MEM_REALLOC(p, n) fl_realloc((p), (size_t)(n))
+#define MEM_FREE(x) fl_free(x)
+#define MEM_STRDUP(s) fl_strdup(s)
+#else
+#define MEM_CALLOC(n, sz) calloc((size_t)(n), (size_t)(sz))
+#define MEM_ALLOC(n) malloc((size_t)(n))
+#define MEM_REALLOC(p, n) realloc((p), (size_t)(n))
+#define MEM_FREE(x) free(x)
+#define MEM_STRDUP(s) strdup(s)
+#endif
--- /dev/null
+++ b/src/nan.c
@@ -1,0 +1,17 @@
+#include "platform.h"
+#include "nan.h"
+#include "ieee754.h"
+
+double D_NNAN, D_NINF;
+
+void
+nan_init(void)
+{+ union ieee754_double *d;
+ D_NNAN = D_PNAN;
+ d = (union ieee754_double *)&D_NNAN;
+ d->ieee.negative = 1;
+ D_NINF = D_PINF;
+ d = (union ieee754_double *)&D_NINF;
+ d->ieee.negative = 1;
+}
--- /dev/null
+++ b/src/nan.h
@@ -1,0 +1,11 @@
+#pragma once
+
+#if defined(__plan9__)
+extern double D_PNAN, D_PINF;
+#else
+#define D_PNAN __builtin_nan("")+#define D_PINF __builtin_inf()
+#endif
+extern double D_NNAN, D_NINF;
+
+void nan_init(void);
--- /dev/null
+++ b/src/opcodes.c
@@ -1,0 +1,40 @@
+#include "flisp.h"
+
+const Builtin builtins[N_OPCODES] = {+ [OP_SETCAR] = {"set-car!", 2},+ [OP_NANP] = {"nan?", 1},+ [OP_CDR] = {"cdr", 1},+ [OP_BOOLEANP] = {"boolean?", 1},+ [OP_FUNCTIONP] = {"function?", 1},+ [OP_CADR] = {"cadr", 1},+ [OP_SETCDR] = {"set-cdr!", 2},+ [OP_EQ] = {"eq?", 2},+ [OP_APPLY] = {"apply", -2},+ [OP_NULLP] = {"null?", 1},+ [OP_CONSP] = {"cons?", 1},+ [OP_ATOMP] = {"atom?", 1},+ [OP_ASET] = {"aset!", -3},+ [OP_NOT] = {"not", 1},+ [OP_LIST] = {"list", ANYARGS},+ [OP_CONS] = {"cons", 2},+ [OP_NUMBERP] = {"number?", 1},+ [OP_BOUNDP] = {"bound?", 1},+ [OP_LT] = {"<", -1},+ [OP_VECTORP] = {"vector?", 1},+ [OP_CAR] = {"car", 1},+ [OP_EQV] = {"eqv?", 2},+ [OP_IDIV] = {"div0", 2},+ [OP_FIXNUMP] = {"fixnum?", 1},+ [OP_NUMEQ] = {"=", -1},+ [OP_SYMBOLP] = {"symbol?", 1},+ [OP_BUILTINP] = {"builtin?", 1},+ [OP_SUB] = {"-", -1},+ [OP_COMPARE] = {"compare", 2},+ [OP_FOR] = {"for", 3},+ [OP_MUL] = {"*", ANYARGS},+ [OP_ADD] = {"+", ANYARGS},+ [OP_AREF] = {"aref", -2},+ [OP_DIV] = {"/", -1},+ [OP_VECTOR] = {"vector", ANYARGS},+ [OP_EQUAL] = {"equal?", 2},+};
--- /dev/null
+++ b/src/opcodes.h
@@ -1,0 +1,101 @@
+typedef enum {+ OP_LOADA0,
+ OP_LOADA1,
+ OP_LOADV,
+ OP_BRF,
+ OP_POP,
+ OP_CALL,
+ OP_TCALL,
+ OP_LOADG,
+ OP_LOADA,
+ OP_LOADC,
+ OP_RET,
+ OP_DUP,
+ OP_CAR,
+ OP_CDR,
+ OP_CLOSURE,
+ OP_SETA,
+ OP_JMP,
+ OP_LOADC0,
+ OP_CONSP,
+ OP_BRNE,
+ OP_LOADT,
+ OP_LOAD0,
+ OP_LOADC1,
+ OP_AREF2,
+ OP_ATOMP,
+ OP_BRT,
+ OP_BRNN,
+ OP_LOAD1,
+ OP_LT,
+ OP_ADD2,
+ OP_SETCDR,
+ OP_LOADF,
+ OP_CONS,
+ OP_EQ,
+ OP_SYMBOLP,
+ OP_NOT,
+ OP_CADR,
+ OP_NEG,
+ OP_NULLP,
+ OP_BOOLEANP,
+ OP_NUMBERP,
+ OP_FIXNUMP,
+ OP_BOUNDP,
+ OP_BUILTINP,
+ OP_FUNCTIONP,
+ OP_VECTORP,
+ OP_SHIFT,
+ OP_SETCAR,
+ OP_JMPL,
+ OP_BRFL,
+ OP_BRTL,
+ OP_EQV,
+ OP_EQUAL,
+ OP_LIST,
+ OP_APPLY,
+ OP_ADD,
+ OP_SUB,
+ OP_MUL,
+ OP_DIV,
+ OP_IDIV,
+ OP_NUMEQ,
+ OP_COMPARE,
+ OP_ARGC,
+ OP_VECTOR,
+ OP_ASET,
+ OP_LOADNIL,
+ OP_LOADI8,
+ OP_LOADVL,
+ OP_LOADGL,
+ OP_LOADAL,
+ OP_LOADCL,
+ OP_SETG,
+ OP_SETGL,
+ OP_SETAL,
+ OP_VARGC,
+ OP_TRYCATCH,
+ OP_FOR,
+ OP_TAPPLY,
+ OP_SUB2,
+ OP_LARGC,
+ OP_LVARGC,
+ OP_CALLL,
+ OP_TCALLL,
+ OP_BRNEL,
+ OP_BRNNL,
+ OP_BRN,
+ OP_BRNL,
+ OP_OPTARGS,
+ OP_BRBOUND,
+ OP_KEYARGS,
+ OP_BOX,
+ OP_BOXL,
+ OP_AREF,
+ OP_LOADVOID,
+ OP_NANP,
+ OP_EOF_OBJECT,
+ N_OPCODES
+}opcode_t;
+
+extern const Builtin builtins[N_OPCODES];
--- /dev/null
+++ b/src/operators.c
@@ -1,0 +1,290 @@
+#include "flisp.h"
+#include "operators.h"
+
+mpint *
+conv_to_mpint(void *data, numerictype_t tag)
+{+ switch(tag){+ case T_INT8: return itomp(*(int8_t*)data, nil);
+ case T_UINT8: return uitomp(*(uint8_t*)data, nil);
+ case T_INT16: return itomp(*(int16_t*)data, nil);
+ case T_UINT16: return uitomp(*(uint16_t*)data, nil);
+ case T_INT32: return itomp(*(int32_t*)data, nil);
+ case T_UINT32: return uitomp(*(uint32_t*)data, nil);
+ case T_INT64: return vtomp(*(int64_t*)data, nil);
+ case T_UINT64: return uvtomp(*(int64_t*)data, nil);
+ case T_MPINT: return mpcopy(*(mpint**)data);
+ case T_FLOAT: return dtomp(*(float*)data, nil);
+ case T_DOUBLE: return dtomp(*(double*)data, nil);
+ }
+ return mpzero;
+}
+
+fl_purefn
+double
+conv_to_double(void *data, numerictype_t tag)
+{+ double d;
+ switch(tag){+ case T_INT8: return *(int8_t*)data;
+ case T_UINT8: return *(uint8_t*)data;
+ case T_INT16: return *(int16_t*)data;
+ case T_UINT16: return *(uint16_t*)data;
+ case T_INT32: return *(int32_t*)data;
+ case T_UINT32: return *(uint32_t*)data;
+ case T_INT64:
+ d = *(int64_t*)data;
+ if(d > 0 && *(int64_t*)data < 0) // can happen!
+ d = -d;
+ return d;
+ case T_UINT64: return *(uint64_t*)data;
+ case T_MPINT: return mptod(*(mpint**)data);
+ case T_FLOAT: return *(float*)data;
+ case T_DOUBLE: return *(double*)data;
+ }
+ return 0;
+}
+
+void
+conv_from_double(void *dest, double d, numerictype_t tag)
+{+ switch(tag){+ case T_INT8: *(int8_t*)dest = d; break;
+ case T_UINT8: *(uint8_t*)dest = d; break;
+ case T_INT16: *(int16_t*)dest = d; break;
+ case T_UINT16: *(uint16_t*)dest = d; break;
+ case T_INT32: *(int32_t*)dest = d; break;
+ case T_UINT32: *(uint32_t*)dest = d; break;
+ case T_INT64:
+ *(int64_t*)dest = d;
+ if(d > 0 && *(int64_t*)dest < 0) // 0x8000000000000000 is a bitch
+ *(int64_t*)dest = INT64_MAX;
+ break;
+ case T_UINT64: *(uint64_t*)dest = d; break;
+ case T_MPINT: *(mpint**)dest = dtomp(d, nil); break;
+ case T_FLOAT: *(float*)dest = d; break;
+ case T_DOUBLE: *(double*)dest = d; break;
+ }
+}
+
+// FIXME sign with mpint
+#define CONV_TO_INTTYPE(name, ctype) \
+fl_purefn \
+ctype \
+conv_to_##name(void *data, numerictype_t tag) \
+{ \+ switch(tag){ \+ case T_INT8: return (ctype)*(int8_t*)data; \
+ case T_UINT8: return (ctype)*(uint8_t*)data; \
+ case T_INT16: return (ctype)*(int16_t*)data; \
+ case T_UINT16: return (ctype)*(uint16_t*)data; \
+ case T_INT32: return (ctype)*(int32_t*)data; \
+ case T_UINT32: return (ctype)*(uint32_t*)data; \
+ case T_INT64: return (ctype)*(int64_t*)data; \
+ case T_UINT64: return (ctype)*(uint64_t*)data; \
+ case T_MPINT: return (ctype)mptov(*(mpint**)data); \
+ case T_FLOAT: return (ctype)*(float*)data; \
+ case T_DOUBLE: return (ctype)*(double*)data; \
+ } \
+ return 0; \
+}
+
+CONV_TO_INTTYPE(int64, int64_t)
+CONV_TO_INTTYPE(int32, int32_t)
+CONV_TO_INTTYPE(uint32, uint32_t)
+
+// this is needed to work around an UB casting negative
+// floats and doubles to uint64. you need to cast to int64
+// first.
+fl_purefn
+uint64_t
+conv_to_uint64(void *data, numerictype_t tag)
+{+ int64_t s;
+ switch(tag){+ case T_INT8: return *(int8_t*)data; break;
+ case T_UINT8: return *(uint8_t*)data; break;
+ case T_INT16: return *(int16_t*)data; break;
+ case T_UINT16: return *(uint16_t*)data; break;
+ case T_INT32: return *(int32_t*)data; break;
+ case T_UINT32: return *(uint32_t*)data; break;
+ case T_INT64: return *(int64_t*)data; break;
+ case T_UINT64: return *(uint64_t*)data; break;
+ case T_MPINT: return mptouv(*(mpint**)data); break;
+ case T_FLOAT:
+ if(*(float*)data >= 0)
+ return *(float*)data;
+ s = *(float*)data;
+ return s;
+ case T_DOUBLE:
+ if(*(double*)data >= 0)
+ return *(double*)data;
+ s = *(double*)data;
+ return s;
+ }
+ return 0;
+}
+
+fl_purefn
+int
+cmp_same_lt(void *a, void *b, numerictype_t tag)
+{+ switch(tag){+ case T_INT8: return *(int8_t*)a < *(int8_t*)b;
+ case T_UINT8: return *(uint8_t*)a < *(uint8_t*)b;
+ case T_INT16: return *(int16_t*)a < *(int16_t*)b;
+ case T_UINT16: return *(uint16_t*)a < *(uint16_t*)b;
+ case T_INT32: return *(int32_t*)a < *(int32_t*)b;
+ case T_UINT32: return *(uint32_t*)a < *(uint32_t*)b;
+ case T_INT64: return *(int64_t*)a < *(int64_t*)b;
+ case T_UINT64: return *(uint64_t*)a < *(uint64_t*)b;
+ case T_MPINT: return mpcmp(*(mpint**)a, *(mpint**)b) < 0;
+ case T_FLOAT: return *(float*)a < *(float*)b;
+ case T_DOUBLE: return *(double*)a < *(double*)b;
+ }
+ return 0;
+}
+
+fl_purefn
+int
+cmp_same_eq(void *a, void *b, numerictype_t tag)
+{+ switch(tag){+ case T_INT8: return *(int8_t*)a == *(int8_t*)b;
+ case T_UINT8: return *(uint8_t*)a == *(uint8_t*)b;
+ case T_INT16: return *(int16_t*)a == *(int16_t*)b;
+ case T_UINT16: return *(uint16_t*)a == *(uint16_t*)b;
+ case T_INT32: return *(int32_t*)a == *(int32_t*)b;
+ case T_UINT32: return *(uint32_t*)a == *(uint32_t*)b;
+ case T_INT64: return *(int64_t*)a == *(int64_t*)b;
+ case T_UINT64: return *(uint64_t*)a == *(uint64_t*)b;
+ case T_MPINT: return mpcmp(*(mpint**)a, *(mpint**)b) == 0;
+ case T_FLOAT: return *(float*)a == *(float*)b && !isnan(*(float*)a);
+ case T_DOUBLE: return *(double*)a == *(double*)b && !isnan(*(double*)b);
+ }
+ return 0;
+}
+
+/* FIXME one is allocated for all compare ops */
+static mpint *cmpmpint;
+
+int
+cmp_lt(void *a, numerictype_t atag, void *b, numerictype_t btag)
+{+ if(atag == btag)
+ return cmp_same_lt(a, b, atag);
+
+ double da = conv_to_double(a, atag);
+ double db = conv_to_double(b, btag);
+
+ // casting to double will only get the wrong answer for big int64s
+ // that differ in low bits
+ if(da < db && !isnan(da) && !isnan(db))
+ return 1;
+ if(db < da)
+ return 0;
+
+ if(cmpmpint == nil && (atag == T_MPINT || btag == T_MPINT))
+ cmpmpint = mpnew(0);
+
+ if(atag == T_UINT64){+ if(btag == T_INT64){+ if(*(int64_t*)b >= 0)
+ return *(uint64_t*)a < (uint64_t)*(int64_t*)b;
+ return (int64_t)*(uint64_t*)a < *(int64_t*)b;
+ }
+ if(btag == T_DOUBLE)
+ return db == db ? *(uint64_t*)a < (uint64_t)*(double*)b : 0;
+ if(btag == T_MPINT)
+ return mpcmp(uvtomp(*(uint64_t*)a, cmpmpint), *(mpint**)b) < 0;
+ }
+ if(atag == T_INT64){+ if(btag == T_UINT64){+ if(*(int64_t*)a >= 0)
+ return (uint64_t)*(int64_t*)a < *(uint64_t*)b;
+ return *(int64_t*)a < (int64_t)*(uint64_t*)b;
+ }
+ if(btag == T_DOUBLE)
+ return db == db ? *(int64_t*)a < (int64_t)*(double*)b : 0;
+ if(btag == T_MPINT)
+ return mpcmp(vtomp(*(int64_t*)a, cmpmpint), *(mpint**)b) < 0;
+ }
+ if(btag == T_UINT64){+ if(atag == T_DOUBLE)
+ return da == da ? *(uint64_t*)b > (uint64_t)*(double*)a : 0;
+ if(atag == T_MPINT)
+ return mpcmp(*(mpint**)a, uvtomp(*(uint64_t*)b, cmpmpint)) < 0;
+ }
+ if(btag == T_INT64){+ if(atag == T_DOUBLE)
+ return da == da ? *(int64_t*)b > (int64_t)*(double*)a : 0;
+ if(atag == T_MPINT)
+ return mpcmp(*(mpint**)a, vtomp(*(int64_t*)b, cmpmpint)) < 0;
+ }
+ return 0;
+}
+
+int
+cmp_eq(void *a, numerictype_t atag, void *b, numerictype_t btag, int equalnans)
+{+ union {+ double d;
+ int64_t i64;
+ }u, v;
+
+ if(atag == btag && (!equalnans || atag < T_FLOAT))
+ return cmp_same_eq(a, b, atag);
+
+ double da = conv_to_double(a, atag);
+ double db = conv_to_double(b, btag);
+
+ if((int)atag >= T_FLOAT && (int)btag >= T_FLOAT){+ if(equalnans){+ u.d = da; v.d = db;
+ return u.i64 == v.i64;
+ }
+ return da == db;
+ }
+
+ if(da != db)
+ return 0;
+
+ if(cmpmpint == nil && (atag == T_MPINT || btag == T_MPINT))
+ cmpmpint = mpnew(0);
+
+ if(atag == T_UINT64){+ // this is safe because if a had been bigger than INT64_MAX,
+ // we would already have concluded that it's bigger than b.
+ if(btag == T_INT64)
+ return (int64_t)*(uint64_t*)a == *(int64_t*)b;
+ if(btag == T_DOUBLE)
+ return *(uint64_t*)a == (uint64_t)(int64_t)*(double*)b;
+ if(btag == T_MPINT)
+ return mpcmp(uvtomp(*(uint64_t*)a, cmpmpint), *(mpint**)b) == 0;
+ }
+ if(atag == T_INT64){+ if(btag == T_UINT64)
+ return *(int64_t*)a == (int64_t)*(uint64_t*)b;
+ if(btag == T_DOUBLE)
+ return *(int64_t*)a == (int64_t)*(double*)b;
+ if(btag == T_MPINT)
+ return mpcmp(vtomp(*(int64_t*)a, cmpmpint), *(mpint**)b) == 0;
+ }
+ if(btag == T_UINT64){+ if(atag == T_INT64)
+ return (int64_t)*(uint64_t*)b == *(int64_t*)a;
+ if(atag == T_DOUBLE)
+ return *(uint64_t*)b == (uint64_t)(int64_t)*(double*)a;
+ if(atag == T_MPINT)
+ return mpcmp(*(mpint**)a, uvtomp(*(uint64_t*)b, cmpmpint)) == 0;
+ }
+ if(btag == T_INT64){+ if(atag == T_UINT64)
+ return *(int64_t*)b == (int64_t)*(uint64_t*)a;
+ if(atag == T_DOUBLE)
+ return *(int64_t*)b == (int64_t)*(double*)a;
+ if(atag == T_MPINT)
+ return mpcmp(*(mpint**)a, vtomp(*(int64_t*)b, cmpmpint)) == 0;
+ }
+ return 1;
+}
--- /dev/null
+++ b/src/operators.h
@@ -1,0 +1,16 @@
+#pragma once
+
+mpint * conv_to_mpint(void *data, numerictype_t tag);
+double conv_to_double(void *data, numerictype_t tag);
+void conv_from_double(void *dest, double d, numerictype_t tag);
+
+int cmp_same_lt(void *a, void *b, numerictype_t tag);
+int cmp_same_eq(void *a, void *b, numerictype_t tag);
+int cmp_lt(void *a, numerictype_t atag, void *b, numerictype_t btag);
+int cmp_eq(void *a, numerictype_t atag, void *b, numerictype_t btag, int equalnans);
+
+int64_t conv_to_int64(void *data, numerictype_t tag);
+uint64_t conv_to_uint64(void *data, numerictype_t tag);
+int32_t conv_to_int32(void *data, numerictype_t tag);
+uint32_t conv_to_uint32(void *data, numerictype_t tag);
+Rune conv_to_Rune(void *data, numerictype_t tag);
--- /dev/null
+++ b/src/plan9/clz.c
@@ -1,0 +1,11 @@
+#include "platform.h"
+
+int
+fl_clz(uint32_t x)
+{+ uint32_t r;
+ if(x == 0)
+ return 32;
+ for(r = 0; (x & (1UL<<31)) == 0; x <<= 1, r++);
+ return r;
+}
--- /dev/null
+++ b/src/plan9/clz_amd64.s
@@ -1,0 +1,4 @@
+TEXT fl_clz(SB),1,$0
+ BYTE $0x0F; BYTE $0xBD; BYTE $0xC5 /* BSRL RARG, AX */
+ XORL $31, AX
+ RET
--- /dev/null
+++ b/src/plan9/clz_arm64.s
@@ -1,0 +1,3 @@
+TEXT fl_clz(SB),1,$0
+ CLZW R0, R0
+ RETURN
--- /dev/null
+++ b/src/plan9/platform.h
@@ -1,0 +1,139 @@
+#pragma once
+
+#include <u.h>
+#include <libc.h>
+#include <ctype.h>
+#include <mp.h>
+
+#ifdef NDEBUG
+#undef assert
+#define assert(x)
+#define static_assert(a,b)
+#else
+#define static_assert_cat(a, b) a##b
+#define static_assert_name(line) static_assert_cat(static_assert_, line)
+#define static_assert(must_be_true, message) \
+ static const void *static_assert_name(__LINE__) \
+ [must_be_true ? 2 : -1] = { \+ message, \
+ static_assert_name(__LINE__), \
+ }
+#endif
+
+#define __os_name__ "plan9"
+
+int fl_popcount(unsigned int w);
+int fl_clz(unsigned int x);
+
+extern double D_PNAN, D_PINF;
+
+#if defined(__amd64__) || \
+ defined(__arm64__) || \
+ defined(__mips64__) || \
+ defined(__power64__) || \
+ defined(__sparc64__)
+#define BITS64
+#define PRIdPTR PRId64
+#define PRIuPTR PRIu64
+#else
+#define PRIdPTR "ld"
+#define PRIuPTR "lud"
+#endif
+
+#if defined(__386__) || defined(__amd64__) || defined(__arm64__)
+#define MEM_UNALIGNED_ACCESS
+#endif
+
+#define unsetenv(name) putenv(name, "")
+#define setenv(name, val, overwrite) putenv(name, val)
+#define exit(x) exits((x) ? "error" : nil)
+#define isinf(x) isInf(x, 0)
+#define isnan(x) isNaN(x)
+
+#define getcwd getwd
+#define vsnprintf vsnprint
+#define vdprintf vfprint
+#define snprintf snprint
+#define strcasecmp cistrcmp
+#define lseek seek
+#define towupper toupperrune
+#define towlower tolowerrune
+#define iswalpha isalpharune
+#define signbit(r) ((*(uint64_t*)&(r)) & (1ULL<<63))
+#define isfinite(d) (((*(uint64_t*)&(d))&0x7ff0000000000000ULL) != 0x7ff0000000000000ULL)
+
+#define PRId32 "d"
+#define PRIu32 "ud"
+#define PRIx32 "x"
+#define PRId64 "lld"
+#define PRIu64 "llud"
+#define PRIx64 "llx"
+
+#define INT32_MAX 0x7fffffff
+#define UINT32_MAX 0xffffffffU
+#define INT32_MIN (-INT32_MAX-1)
+#define INT64_MIN ((int64_t)0x8000000000000000LL)
+#define INT64_MAX 0x7fffffffffffffffLL
+#define UINT64_MAX 0xffffffffffffffffULL
+#define ULONG_MAX UINT32_MAX
+
+#define PATHSEP '/'
+#define PATHSEPSTRING "/"
+#define PATHLISTSEP ':'
+#define PATHLISTSEPSTRING ":"
+#define ISPATHSEP(c) ((c) == '/')
+
+enum {+ SEEK_SET,
+ SEEK_CUR,
+ SEEK_END,
+
+ STDIN_FILENO = 0,
+ STDOUT_FILENO,
+ STDERR_FILENO,
+};
+
+#define O_RDWR ORDWR
+#define O_WRONLY OWRITE
+#define O_RDONLY OREAD
+#define O_TRUNC OTRUNC
+#define F_OK 0
+
+#define LITTLE_ENDIAN 1234
+#define BIG_ENDIAN 4321
+
+#if defined(__mips__) || \
+ defined(__power__) || defined(__power64__) || \
+ defined(__sparc__) || defined(__sparc64__)
+#define BYTE_ORDER BIG_ENDIAN
+#else
+#define BYTE_ORDER LITTLE_ENDIAN
+#endif
+
+typedef s8int int8_t;
+typedef s16int int16_t;
+typedef s32int int32_t;
+typedef s64int int64_t;
+typedef u8int uint8_t;
+typedef u16int uint16_t;
+typedef u32int uint32_t;
+typedef u64int uint64_t;
+typedef vlong off_t;
+typedef intptr intptr_t;
+typedef uintptr uintptr_t;
+typedef intptr ssize_t;
+typedef uintptr size_t;
+typedef enum { false, true } bool;+
+int wcwidth(Rune c);
+int ftruncate(int f, off_t sz);
+
+#if !defined(INITIAL_HEAP_SIZE)
+#define INITIAL_HEAP_SIZE 16*1024*1024
+#endif
+#if !defined(ALLOC_LIMIT_TRIGGER)
+#define ALLOC_LIMIT_TRIGGER INITIAL_HEAP_SIZE
+#endif
+
+#include "cc.h"
+#include "mem.h"
--- /dev/null
+++ b/src/plan9/popcount.c
@@ -1,0 +1,11 @@
+#include "platform.h"
+
+int
+fl_popcount(unsigned int w)
+{+ w -= (w >> 1) & 0x55555555U;
+ w = (w & 0x33333333U) + ((w >> 2) & 0x33333333U);
+ w = (w + (w >> 4)) & 0x0F0F0F0FU;
+ w = (w * 0x01010101U) >> 24;
+ return w;
+}
--- /dev/null
+++ b/src/plan9/sys.c
@@ -1,0 +1,94 @@
+#include "flisp.h"
+#include "timefuncs.h"
+#include <tos.h>
+
+double D_PNAN, D_PINF;
+
+double
+sec_realtime(void)
+{+ vlong t = nsec();
+ vlong ns = t % 1000000000LL;
+ vlong s = (t - ns) / 1000000000LL;
+ return (double)s + (double)ns/1.0e9;
+}
+
+/*
+ * nsec() is wallclock and can be adjusted by timesync
+ * so need to use cycles() instead, but fall back to
+ * nsec() in case we can't
+ */
+uint64_t
+nanosec_monotonic(void)
+{+ static uint64_t fasthz, xstart;
+ uint64_t x, div;
+
+ if(fasthz == ~0ULL)
+ return nsec() - xstart;
+
+ if(fasthz == 0){+ if(_tos->cyclefreq){+ fasthz = _tos->cyclefreq;
+ cycles(&xstart);
+ } else {+ fasthz = ~0ULL;
+ xstart = nsec();
+ }
+ return 0;
+ }
+ cycles(&x);
+ x -= xstart;
+
+ /* this is ugly */
+ for(div = 1000000000ULL; x < 0x1999999999999999ULL && div > 1 ; div /= 10ULL, x *= 10ULL);
+
+ return x / (fasthz / div);
+}
+
+void
+timestring(double s, char *buf, int sz)
+{+ Tm tm;
+ snprint(buf, sz, "%τ", tmfmt(tmtime(&tm, s, tzload("local")), nil));+}
+
+double
+parsetime(const char *s)
+{+ Tm tm;
+ if(tmparse(&tm, "?WWW, ?MM ?DD hh:mm:ss ?Z YYYY", s, tzload("local"), nil) == nil)+ return -1;
+ return tmnorm(&tm);
+}
+
+void
+sleep_ms(int ms)
+{+ if(ms != 0)
+ sleep(ms);
+}
+
+int
+ftruncate(int f, off_t sz)
+{+ Dir d;
+
+ nulldir(&d);
+ d.length = sz;
+ return dirfwstat(f, &d) > 0 ? 0 : -1;
+}
+
+extern uchar bootcode[];
+extern ulong bootlen;
+
+void
+main(int argc, char **argv)
+{+ argv0 = argv[0];
+ setfcr(FPPDBL|FPRNR|FPOVFL);
+ tmfmtinstall();
+ D_PNAN = strtod("+NaN", nil);+ D_PINF = strtod("+Inf", nil);+ flmain(bootcode, bootlen, argc, argv);
+}
--- /dev/null
+++ b/src/posix/platform.h
@@ -1,0 +1,102 @@
+#pragma once
+
+#define _XOPEN_SOURCE 700
+#include <assert.h>
+#include <ctype.h>
+#if defined(__APPLE__)
+#include <machine/endian.h>
+#else
+#include <endian.h>
+#endif
+#include <errno.h>
+#include <fcntl.h>
+#include <float.h>
+#include <inttypes.h>
+#include <limits.h>
+#include <locale.h>
+#include <math.h>
+#include <setjmp.h>
+#include <stdbool.h>
+#include <stdarg.h>
+#include <stdio.h>
+#include <stddef.h>
+#include <stdint.h>
+#include <stdlib.h>
+#include <string.h>
+#include <strings.h>
+#include <sys/stat.h>
+#include <sys/time.h>
+#include <time.h>
+#include <unistd.h>
+#include <wctype.h>
+#include <wchar.h>
+
+#if defined(__linux__)
+#define __os_name__ "linux"
+#elif defined(__OpenBSD__)
+#define __os_name__ "openbsd"
+#elif defined(__FreeBSD__)
+#define __os_name__ "freebsd"
+#elif defined(__NetBSD__)
+#define __os_name__ "netbsd"
+#elif defined(__DragonFly__)
+#define __os_name__ "dragonflybsd"
+#elif defined(__APPLE__)
+#define __os_name__ "macosx"
+#elif defined(__HAIKU__)
+#define __os_name__ "haiku"
+#else
+#define __os_name__ "unknown"
+#endif
+
+extern char __os_version__[];
+#define __os_version__ __os_version__
+
+#ifndef __SIZEOF_POINTER__
+#error pointer size unknown
+#elif __SIZEOF_POINTER__ == 8
+#define BITS64
+#endif
+
+#define nil NULL
+#define USED(x) ((void)(x))
+#define nelem(x) (int)(sizeof(x)/sizeof((x)[0]))
+
+#define PATHSEP '/'
+#define PATHSEPSTRING "/"
+#define PATHLISTSEP ':'
+#define PATHLISTSEPSTRING ":"
+#define ISPATHSEP(c) ((c) == '/')
+
+#if !defined(BYTE_ORDER)
+#if !defined(__BYTE_ORDER)
+#define LITTLE_ENDIAN 1234
+#define BIG_ENDIAN 4321
+#if defined(__LITTLE_ENDIAN__)
+#define BYTE_ORDER LITTLE_ENDIAN
+#else
+#define BYTE_ORDER BIG_ENDIAN
+#endif
+#else
+#define LITTLE_ENDIAN __LITTLE_ENDIAN
+#define BIG_ENDIAN __BIG_ENDIAN
+#define BYTE_ORDER __BYTE_ORDER
+#endif
+#endif
+
+// FIXME: __clang__ because no idea how to check if ubsan is enabled.
+#if !defined(__clang__) && (defined(__386__) || defined(__x86_64__) || defined(__aarch64__))
+#define MEM_UNALIGNED_ACCESS
+#endif
+
+#if !defined(INITIAL_HEAP_SIZE)
+#define INITIAL_HEAP_SIZE 16*1024*1024
+#endif
+#if !defined(ALLOC_LIMIT_TRIGGER)
+#define ALLOC_LIMIT_TRIGGER INITIAL_HEAP_SIZE
+#endif
+
+#include "cc.h"
+#include "mem.h"
+#include "mp.h"
+#include "utf.h"
--- /dev/null
+++ b/src/posix/sys.c
@@ -1,0 +1,87 @@
+#include "flisp.h"
+#include "timefuncs.h"
+
+double
+sec_realtime(void)
+{+ struct timespec now;
+ if(clock_gettime(CLOCK_REALTIME, &now) != 0)
+ return 0;
+ return (double)now.tv_sec + (double)now.tv_nsec/1.0e9;
+}
+
+uint64_t
+nanosec_monotonic(void)
+{+ static int64_t z;
+ struct timespec now;
+
+ if(clock_gettime(CLOCK_MONOTONIC, &now) != 0)
+ return 0;
+ if(z == 0){+ z = now.tv_sec*1000000000LL + now.tv_nsec;
+ return 0;
+ }
+ return now.tv_sec*1000000000LL + now.tv_nsec - z;
+}
+
+void
+timestring(double s, char *buf, int sz)
+{+ time_t tme = (time_t)s;
+ struct tm tm;
+
+ *buf = 0;
+ if(localtime_r(&tme, &tm) != nil)
+ strftime(buf, sz, "%a %b %e %H:%M:%S %Y", &tm);
+}
+
+double
+parsetime(const char *s)
+{+ char *res;
+ time_t t;
+ struct tm tm;
+
+ res = strptime(s, "%c", &tm);
+ if(res != nil){+ /* Not set by strptime(); tells mktime() to determine
+ * whether daylight saving time is in effect
+ */
+ tm.tm_isdst = -1;
+ t = mktime(&tm);
+ if(t == (time_t)-1)
+ return -1;
+ return (double)t;
+ }
+ return -1;
+}
+
+void
+sleep_ms(int ms)
+{+ if(ms != 0){+ struct timeval timeout;
+ timeout.tv_sec = ms/1000;
+ timeout.tv_usec = (ms % 1000) * 1000;
+ select(0, nil, nil, nil, &timeout);
+ }
+}
+
+static const uint8_t boot[] = {+#include "flisp.boot.h"
+};
+
+char __os_version__[64];
+#include <sys/utsname.h>
+
+int
+main(int argc, char **argv)
+{+ setlocale(LC_NUMERIC, "C");
+ struct utsname u;
+ __os_version__[0] = 0;
+ if(uname(&u) == 0)
+ snprintf(__os_version__, sizeof(__os_version__), "%s", u.release);
+ flmain(boot, sizeof(boot), argc, argv);
+}
--- /dev/null
+++ b/src/print.c
@@ -1,0 +1,873 @@
+#include "flisp.h"
+#include "operators.h"
+#include "cvalues.h"
+#include "ieee754.h"
+#include "print.h"
+#include "read.h"
+
+#define LOG2_10 3.321928094887362347870319429489
+
+static void
+outc(ios_t *f, char c)
+{+ ios_putc(f, c);
+ if(c == '\n')
+ FL(hpos) = 0;
+ else
+ FL(hpos)++;
+}
+
+static void
+outs(ios_t *f, const char *s)
+{+ ios_puts(f, s);
+ FL(hpos) += u8_strwidth(s);
+}
+
+static void
+outsn(ios_t *f, const char *s, size_t n)
+{+ ios_write(f, s, n);
+ FL(hpos) += u8_strwidth(s);
+}
+
+static int
+outindent(ios_t *f, int n)
+{+ // move back to left margin if we get too indented
+ if(n > FL(scr_width)-12)
+ n = 2;
+ int n0 = n;
+ ios_putc(f, '\n');
+ FL(vpos)++;
+ FL(hpos) = n;
+ while(n >= 8){+ ios_putc(f, '\t');
+ n -= 8;
+ }
+ while(n){+ ios_putc(f, ' ');
+ n--;
+ }
+ return n0;
+}
+
+void
+fl_print_chr(ios_t *f, char c)
+{+ outc(f, c);
+}
+
+void
+fl_print_str(ios_t *f, const char *s)
+{+ outs(f, s);
+}
+
+void
+print_traverse(value_t v)
+{+ value_t *bp;
+ while(iscons(v)){+ if(ismarked(v)){+ bp = (value_t*)ptrhash_bp(&FL(printconses), (void*)v);
+ if(*bp == (value_t)HT_NOTFOUND)
+ *bp = fixnum(FL(printlabel)++);
+ return;
+ }
+ mark_cons(v);
+ print_traverse(car_(v));
+ v = cdr_(v);
+ }
+ if(!ismanaged(v) || issymbol(v))
+ return;
+ if(ismarked(v)){+ bp = (value_t*)ptrhash_bp(&FL(printconses), (void*)v);
+ if(*bp == (value_t)HT_NOTFOUND)
+ *bp = fixnum(FL(printlabel)++);
+ return;
+ }
+ if(isvector(v)){+ if(vector_size(v) > 0)
+ mark_cons(v);
+ unsigned int i;
+ for(i = 0; i < vector_size(v); i++)
+ print_traverse(vector_elt(v, i));
+ }else if(iscprim(v)){+ // don't consider shared references to e.g. chars
+ }else if(isclosure(v)){+ mark_cons(v);
+ function_t *f = ptr(v);
+ print_traverse(f->bcode);
+ print_traverse(f->vals);
+ print_traverse(f->env);
+ }else if(iscvalue(v)){+ cvalue_t *cv = ptr(v);
+ // don't consider shared references to ""
+ if(!cv_isstr(cv) || cv_len(cv) != 0)
+ mark_cons(v);
+ fltype_t *t = cv_class(cv);
+ if(t->vtable != nil && t->vtable->print_traverse != nil)
+ t->vtable->print_traverse(v);
+ }
+}
+
+static void
+print_symbol_name(ios_t *f, const char *name)
+{+ int i, escape = 0, charescape = 0;
+
+ if((name[0] == '\0') ||
+ (name[0] == '.' && name[1] == '\0') ||
+ (name[0] == '#') ||
+ fl_read_numtok(name, nil, 0))
+ escape = 1;
+ i = 0;
+ while(name[i]){+ if(!symchar(name[i])){+ escape = 1;
+ if(name[i] == '|' || name[i] == '\\'){+ charescape = 1;
+ break;
+ }
+ }
+ i++;
+ }
+ if(escape){+ if(charescape){+ outc(f, '|');
+ i = 0;
+ while(name[i]){+ if(name[i] == '|' || name[i] == '\\')
+ outc(f, '\\');
+ outc(f, name[i]);
+ i++;
+ }
+ outc(f, '|');
+ }else{+ outc(f, '|');
+ outs(f, name);
+ outc(f, '|');
+ }
+ }else{+ outs(f, name);
+ }
+}
+
+/*
+ The following implements a simple pretty-printing algorithm. This is
+ an unlimited-width approach that doesn't require an extra pass.
+ It uses some heuristics to guess whether an expression is "small",
+ and avoids wrapping symbols across lines. The result is high
+ performance and nice output for typical code. Quality is poor for
+ pathological or deeply-nested expressions, but those are difficult
+ to print anyway.
+*/
+#define SMALL_STR_LEN 20
+static inline int
+tinyp(value_t v)
+{+ if(issymbol(v))
+ return u8_strwidth(symbol_name(v)) < SMALL_STR_LEN;
+ if(fl_isstring(v))
+ return cv_len(ptr(v)) < SMALL_STR_LEN;
+ return (
+ isfixnum(v) || isbuiltin(v) || iscprim(v) ||
+ v == FL_f || v == FL_t ||
+ v == FL_nil || v == FL_eof || v == FL_void
+ );
+}
+
+static int
+smallp(value_t v)
+{+ if(tinyp(v))
+ return 1;
+ if(fl_isnumber(v))
+ return 1;
+ if(iscons(v)){+ if(tinyp(car_(v)) &&
+ (tinyp(cdr_(v)) || (iscons(cdr_(v)) && tinyp(car_(cdr_(v))) && cdr_(cdr_(v)) == FL_nil)))
+ return 1;
+ return 0;
+ }
+ if(isvector(v)){+ size_t s = vector_size(v);
+ return (
+ s == 0 ||
+ (tinyp(vector_elt(v, 0)) && (s == 1 || (s == 2 && tinyp(vector_elt(v, 1)))))
+ );
+ }
+ return 0;
+}
+
+static int
+specialindent(value_t head)
+{+ // indent these forms 2 spaces, not lined up with the first argument
+ if(head == FL_lambda || head == FL_trycatch || head == FL_definesym ||
+ head == FL_defmacrosym || head == FL_forsym)
+ return 2;
+ return -1;
+}
+
+static int
+lengthestimate(value_t v)
+{+ // get the width of an expression if we can do so cheaply
+ if(issymbol(v))
+ return u8_strwidth(symbol_name(v));
+ if(iscprim(v) && ptr(v) != nil && cp_class(ptr(v)) == FL(runetype))
+ return 4;
+ return -1;
+}
+
+static int
+allsmallp(value_t v)
+{+ int n = 1;
+ while(iscons(v)){+ if(!smallp(car_(v)))
+ return 0;
+ v = cdr_(v);
+ n++;
+ if(n > 25)
+ return n;
+ }
+ return n;
+}
+
+static int
+indentafter3(value_t head, value_t v)
+{+ // for certain X always indent (X a b c) after b
+ return head == FL_forsym && !allsmallp(cdr_(v));
+}
+
+static int
+indentafter2(value_t head, value_t v)
+{+ // for certain X always indent (X a b) after a
+ return (head == FL_definesym || head == FL_defmacrosym) && !allsmallp(cdr_(v));
+}
+
+static int
+indentevery(value_t v)
+{+ // indent before every subform of a special form, unless every
+ // subform is "small"
+ value_t c = car_(v);
+ if(c == FL_lambda || c == FL_setqsym)
+ return 0;
+ //if(c == FL(IF)) // TODO: others
+ // return !allsmallp(cdr_(v));
+ return 0;
+}
+
+static int
+blockindent(value_t v)
+{+ // in this case we switch to block indent mode, where the head
+ // is no longer considered special:
+ // (a b c d e
+ // f g h i j)
+ return allsmallp(v) > 9;
+}
+
+static void
+print_cons(ios_t *f, value_t v)
+{+ value_t cd;
+ const char *op;
+ if(iscons(cdr_(v)) && cdr_(cdr_(v)) == FL_nil &&
+ !ptrhash_has(&FL(printconses), (void*)cdr_(v)) &&
+ ((car_(v) == FL_quote && (op = "'")) ||
+ (car_(v) == FL_backquote && (op = "`")) ||
+ (car_(v) == FL_comma && (op = ",")) ||
+ (car_(v) == FL_commaat && (op = ",@")) ||
+ (car_(v) == FL_commadot && (op = ",.")))){+ // special prefix syntax
+ unmark_cons(v);
+ unmark_cons(cdr_(v));
+ outs(f, op);
+ fl_print_child(f, car_(cdr_(v)));
+ return;
+ }
+ int startpos = FL(hpos);
+ outc(f, '(');+ int newindent = FL(hpos), blk = blockindent(v);
+ int lastv, n = 0, si, ind, est, always = 0, nextsmall, thistiny;
+ if(!blk)
+ always = indentevery(v);
+ value_t head = car_(v);
+ int after3 = indentafter3(head, v);
+ int after2 = indentafter2(head, v);
+ int n_unindented = 1;
+ while(1){+ cd = cdr_(v);
+ if(FL(print_length) >= 0 && n >= FL(print_length) && cd != FL_nil){+ outsn(f, "...)", 4);
+ break;
+ }
+ lastv = FL(vpos);
+ unmark_cons(v);
+ fl_print_child(f, car_(v));
+ if(!iscons(cd) || ptrhash_has(&FL(printconses), (void*)cd)){+ if(cd != FL_nil){+ outsn(f, " . ", 3);
+ fl_print_child(f, cd);
+ }
+ outc(f, ')');
+ break;
+ }
+
+ if(!FL(print_pretty) ||
+ (head == FL_lambda && n == 0)){+ // never break line before lambda-list
+ ind = 0;
+ }else{+ est = lengthestimate(car_(cd));
+ nextsmall = smallp(car_(cd));
+ thistiny = tinyp(car_(v));
+ ind = ((FL(vpos) > lastv ||
+ (FL(hpos)>FL(scr_width)/2 && !nextsmall && !thistiny && n>0)) ||
+
+ (FL(hpos) > FL(scr_width)-4) ||
+
+ (est != -1 && FL(hpos)+est > FL(scr_width)-2) ||
+
+ (head == FL_lambda && !nextsmall) ||
+
+ (n > 0 && always) ||
+
+ (n == 2 && after3) ||
+ (n == 1 && after2) ||
+
+ (n_unindented >= 3 && !nextsmall) ||
+
+ (n == 0 && !smallp(head)));
+ }
+
+ if(ind){+ newindent = outindent(f, newindent);
+ n_unindented = 1;
+ }else{+ n_unindented++;
+ outc(f, ' ');
+ if(n == 0){+ // set indent level after printing head
+ si = specialindent(head);
+ if(si != -1)
+ newindent = startpos + si;
+ else if(!blk)
+ newindent = FL(hpos);
+ }
+ }
+ n++;
+ v = cd;
+ }
+}
+
+static void cvalue_print(ios_t *f, value_t v);
+
+static int
+print_circle_prefix(ios_t *f, value_t v)
+{+ value_t label;
+ if((label = (value_t)ptrhash_get(&FL(printconses), (void*)v)) != (value_t)HT_NOTFOUND){+ if(!ismarked(v)){+ FL(hpos) += ios_printf(f, "#%"PRIdPTR"#", (intptr_t)numval(label));
+ return 1;
+ }
+ FL(hpos) += ios_printf(f, "#%"PRIdPTR"=", (intptr_t)numval(label));
+ }
+ if(ismanaged(v))
+ unmark_cons(v);
+ return 0;
+}
+
+void
+fl_print_child(ios_t *f, value_t v)
+{+ const char *name;
+ if(FL(print_level) >= 0 && FL(p_level) >= FL(print_level) && (iscons(v) || isvector(v) || isclosure(v))){+ outc(f, '#');
+ return;
+ }
+ FL(p_level)++;
+
+ switch(tag(v)){+ case TAG_NUM: case TAG_NUM1:
+ FL(hpos) += ios_printf(f, "%"PRIdFIXNUM, numval(v));
+ break;
+ case TAG_SYM:
+ name = symbol_name(v);
+ if(FL(print_princ))
+ outs(f, name);
+ else if(ismanaged(v)){+ outsn(f, "#:", 2);
+ outs(f, name);
+ }else
+ print_symbol_name(f, name);
+ break;
+ case TAG_FUNCTION:
+ if(v == FL_t)
+ outsn(f, "#t", 2);
+ else if(v == FL_f)
+ outsn(f, "#f", 2);
+ else if(v == FL_nil)
+ outsn(f, "nil", 3);
+ else if(v == FL_eof)
+ outsn(f, "#<eof>", 6);
+ else if(v == FL_void){+ outsn(f, "#<void>", 7);
+ }else if(isbuiltin(v)){+ if(!FL(print_princ))
+ outsn(f, "#.", 2);
+ outs(f, builtins[uintval(v)].name);
+ }else{+ assert(isclosure(v));
+ if(!FL(print_princ)){+ if(print_circle_prefix(f, v))
+ break;
+ function_t *fn = ptr(v);
+ outs(f, "#fn(");+ char *data = cvalue_data(fn->bcode);
+ size_t i, sz = cvalue_len(fn->bcode);
+ for(i = 0; i < sz; i++)
+ data[i] += 48;
+ fl_print_child(f, fn->bcode);
+ for(i = 0; i < sz; i++)
+ data[i] -= 48;
+ outc(f, ' ');
+ fl_print_child(f, fn->vals);
+ if(fn->env != FL_nil){+ outc(f, ' ');
+ fl_print_child(f, fn->env);
+ }
+ if(fn->name != FL_lambda){+ outc(f, ' ');
+ fl_print_child(f, fn->name);
+ }
+ outc(f, ')');
+ }else{+ outs(f, "#<function>");
+ }
+ }
+ break;
+ case TAG_CPRIM:
+ if(v == UNBOUND)
+ outs(f, "#<undefined>");
+ else
+ cvalue_print(f, v);
+ break;
+ case TAG_CVALUE:
+ case TAG_VECTOR:
+ case TAG_CONS:
+ if(!FL(print_princ) && print_circle_prefix(f, v))
+ break;
+ if(isvector(v)){+ outs(f, "#(");+ int newindent = FL(hpos), est;
+ int i, sz = vector_size(v);
+ for(i = 0; i < sz; i++){+ if(FL(print_length) >= 0 && i >= FL(print_length) && i < sz-1){+ outsn(f, "...", 3);
+ break;
+ }
+ fl_print_child(f, vector_elt(v, i));
+ if(i < sz-1){+ if(!FL(print_pretty))
+ outc(f, ' ');
+ else{+ est = lengthestimate(vector_elt(v, i+1));
+ if(FL(hpos) > FL(scr_width)-4 ||
+ (est != -1 && (FL(hpos)+est > FL(scr_width)-2)) ||
+ (FL(hpos) > FL(scr_width)/2 && !smallp(vector_elt(v, i+1)) && !tinyp(vector_elt(v, i))))
+ newindent = outindent(f, newindent);
+ else
+ outc(f, ' ');
+ }
+ }
+ }
+ outc(f, ')');
+ break;
+ }
+ if(iscvalue(v))
+ cvalue_print(f, v);
+ else
+ print_cons(f, v);
+ break;
+ }
+ FL(p_level)--;
+}
+
+static void
+print_string(ios_t *f, const char *str, size_t sz)
+{+ char buf[64];
+ uint8_t c;
+ static const char hexdig[] = "0123456789abcdef";
+
+ size_t i = 0;
+ if(!u8_isvalid(str, sz)){+ // alternate print algorithm that preserves data if it's not UTF-8
+ for(; i < sz; i++){+ c = str[i];
+ if(c == '\\')
+ outsn(f, "\\\\", 2);
+ else if(c == '"')
+ outsn(f, "\\\"", 2);
+ else if(c >= 32 && c < 0x7f)
+ outc(f, c);
+ else{+ outsn(f, "\\x", 2);
+ outc(f, hexdig[c>>4]);
+ outc(f, hexdig[c&0xf]);
+ }
+ }
+ }else{+ while(i < sz){+ size_t n = u8_escape(buf, sizeof(buf), str, &i, sz, true, false);
+ outsn(f, buf, n-1);
+ }
+ }
+}
+
+static int
+double_exponent(double d)
+{+ union ieee754_double dl;
+
+ dl.d = d;
+ return dl.ieee.exponent - IEEE754_DOUBLE_BIAS;
+}
+
+static void
+snprint_real(char *s, size_t cnt, double r,
+ int width, // printf field width, or 0
+ int dec, // # decimal digits desired, recommend 16
+ // # of zeros in .00...0x before using scientific notation
+ // recommend 3-4 or so
+ int max_digs_rt,
+ // # of digits left of decimal before scientific notation
+ // recommend 10
+ int max_digs_lf)
+{+ bool keepz = false;
+ int mag, sz;
+
+ s[0] = '\0';
+ if(width == -1){+ width = 0;
+ keepz = true;
+ }
+ if(isinf(r)){+ strncpy(s, signbit(r) ? "-inf" : "inf", cnt);
+ return;
+ }
+ if(isnan(r)){+ strncpy(s, signbit(r) ? "-nan" : "nan", cnt);
+ return;
+ }
+ if(r == 0){+ strncpy(s, "0", cnt);
+ return;
+ }
+
+ char num_format[4];
+ num_format[0] = 'l';
+ num_format[2] = '\0';
+
+ mag = double_exponent(r);
+ mag = (int)(((double)mag)/LOG2_10 + 0.5);
+ if(r == 0)
+ mag = 0;
+ double fpart, temp;
+ if(mag > max_digs_lf-1 || mag < -max_digs_rt){+ num_format[1] = 'e';
+ temp = r/pow(10, mag); /* see if number will have a decimal */
+ fpart = temp - floor(temp); /* when written in scientific notation */
+ }else{+ num_format[1] = 'f';
+ fpart = r - floor(r);
+ }
+ if(fpart == 0)
+ dec = 0;
+
+ char format[28];
+ if(width == 0)
+ snprintf(format, sizeof(format), "%%.%d%s", dec, num_format);
+ else
+ snprintf(format, sizeof(format), "%%%d.%d%s", width, dec, num_format);
+#pragma GCC diagnostic push
+#pragma GCC diagnostic ignored "-Wformat-nonliteral"
+ sz = snprintf(s, cnt, format, r);
+#pragma GCC diagnostic pop
+ /* trim trailing zeros from fractions. not when using scientific
+ notation, since we might have e.g. 1.2000e+100. also not when we
+ need a specific output width */
+ if(width == 0 && !keepz){+ if(sz > 2 && fpart){+ char *e = nil;
+ if(num_format[1] == 'e'){+ while(s[--sz] != 'e');
+ e = s + sz--;
+ }
+ while(s[sz-1] == '0'){+ s[sz-1] = '\0';
+ sz--;
+ }
+ // don't need trailing .
+ if(s[sz-1] == '.')
+ s[--sz] = '\0';
+ if(num_format[1] == 'e'){+ while(*e)
+ s[sz++] = *e++;
+ s[sz] = 0;
+ }
+ }
+ }
+}
+
+// 'weak' means we don't need to accurately reproduce the type, so
+// for example #int32(0) can be printed as just 0. this is used
+// printing in a context where a type is already implied, e.g. inside
+// an array.
+static void
+cvalue_printdata(ios_t *f, void *data, size_t len, value_t type, int weak)
+{+ if(type == FL_bytesym){+ uint8_t ch = *(uint8_t*)data;
+ if(FL(print_princ))
+ outc(f, ch);
+ else if(weak)
+ FL(hpos) += ios_printf(f, "0x%hhx", ch);
+ else
+ FL(hpos) += ios_printf(f, "#byte(0x%hhx)", ch);
+ }else if(type == FL_runesym){+ Rune r = *(Rune*)data;
+ char seq[UTFmax+1];
+ int nb = runetochar(seq, &r);
+ seq[nb] = '\0';
+ if(FL(print_princ)){+ outsn(f, seq, nb);
+ }else{+ outsn(f, "#\\", 2);
+ switch(r){+ case 0x00: outsn(f, "nul", 3); break;
+ case 0x07: outsn(f, "alarm", 5); break;
+ case 0x08: outsn(f, "backspace", 9); break;
+ case 0x09: outsn(f, "tab", 3); break;
+ case 0x0a: outsn(f, "newline", 7); break;
+ case 0x0b: outsn(f, "vtab", 4); break;
+ case 0x0c: outsn(f, "page", 4); break;
+ case 0x0d: outsn(f, "return", 6); break;
+ case 0x1b: outsn(f, "esc", 3); break;
+ case ' ': outsn(f, "space", 5); break;
+ case 0x7f: outsn(f, "delete", 6); break;
+ default:
+ if(u8_iswprint(r))
+ outs(f, seq);
+ else
+ FL(hpos) += ios_printf(f, "x%04"PRIx32, r);
+ break;
+ }
+ }
+ }else if(type == FL_floatsym || type == FL_doublesym){+ char buf[64];
+ double d;
+ int ndec;
+ if(type == FL_floatsym){+ d = (double)*(float*)data;
+ ndec = 8;
+ }else{+ d = *(double*)data;
+ ndec = 16;
+ }
+ if(!isfinite(d)){+ const char *rep;
+ if(isinf(d))
+ rep = signbit(d) ? "-inf.0" : "+inf.0";
+ else if(isnan(d))
+ rep = signbit(d) ? "-nan.0" : "+nan.0";
+ else
+ rep = signbit(d) ? "-wtf.0" : "+wtf.0";
+ if(type == FL_floatsym && !FL(print_princ) && !weak)
+ FL(hpos) += ios_printf(f, "#%s(%s)", symbol_name(type), rep);
+ else
+ outs(f, rep);
+ }else if(d == 0){+ if(1/d < 0)
+ outsn(f, "-0.0", 4);
+ else
+ outsn(f, "0.0", 3);
+ if(type == FL_floatsym && !FL(print_princ) && !weak)
+ outc(f, 'f');
+ }else{+ snprint_real(buf, sizeof(buf), d, 0, ndec, 3, 10);
+ int hasdec = (strpbrk(buf, ".eE") != nil);
+ outs(f, buf);
+ if(!hasdec)
+ outsn(f, ".0", 2);
+ if(type == FL_floatsym && !FL(print_princ) && !weak)
+ outc(f, 'f');
+ }
+ }else if(type == FL_uint64sym){+ uint64_t ui64 = *(uint64_t*)data;
+ if(weak || FL(print_princ))
+ FL(hpos) += ios_printf(f, "%"PRIu64, ui64);
+ else
+ FL(hpos) += ios_printf(f, "#%s(%"PRIu64")", symbol_name(type), ui64);
+ }else if(type == FL_bignumsym){+ mpint *i = *(mpint**)data;
+ char *s = mptoa(i, 10, nil, 0);
+ FL(hpos) += ios_printf(f, "%s", s);
+ MEM_FREE(s);
+ }else if(issymbol(type)){+ // handle other integer prims. we know it's smaller than uint64
+ // at this point, so int64 is big enough to capture everything.
+ numerictype_t nt = sym_to_numtype(type);
+ if(valid_numtype(nt)){+ int64_t i64 = conv_to_int64(data, nt);
+ if(weak || FL(print_princ))
+ FL(hpos) += ios_printf(f, "%"PRId64, i64);
+ else
+ FL(hpos) += ios_printf(f, "#%s(%"PRId64")", symbol_name(type), i64);
+ }else{+ FL(hpos) += ios_printf(f, "#<%s>", symbol_name(type));
+ }
+ }else if(iscons(type)){+ if(car_(type) == FL_arraysym){+ size_t i;
+ value_t eltype = car(cdr_(type));
+ size_t cnt, elsize;
+ if(iscons(cdr_(cdr_(type)))){+ cnt = tosize(car_(cdr_(cdr_(type))));
+ elsize = cnt ? len/cnt : 0;
+ }else{+ // incomplete array type
+ elsize = ctype_sizeof(eltype);
+ cnt = elsize ? len/elsize : 0;
+ }
+ if(eltype == FL_bytesym){+ if(FL(print_princ)){+ ios_write(f, data, len);
+ /*
+ char *nl = llt_memrchr(data, '\n', len);
+ if(nl)
+ FL(hpos) = u8_strwidth(nl+1);
+ else
+ FL(hpos) += u8_strwidth(data);
+ */
+ }else{+ outc(f, '"');
+ print_string(f, (char*)data, len);
+ outc(f, '"');
+ }
+ return;
+ }else if(eltype == FL_runesym){+ char buf[UTFmax+1];
+ if(!FL(print_princ))
+ outc(f, '"');
+ for(i = 0; i < cnt; i++, data = (char*)data + elsize){+ int n = runetochar(buf, (Rune*)data);
+ buf[n] = 0;
+ if(FL(print_princ))
+ ios_write(f, buf, n);
+ else
+ print_string(f, buf, n);
+ }
+ if(!FL(print_princ))
+ outc(f, '"');
+ return;
+ }
+ if(!weak){+ if(eltype == FL_uint8sym){+ outsn(f, "#vu8(", 5);+ }else{+ outsn(f, "#array(", 7);+ fl_print_child(f, eltype);
+ if(cnt > 0)
+ outc(f, ' ');
+ }
+ }else{+ outs(f, "#(");+ }
+ for(i = 0; i < cnt; i++){+ if(i > 0)
+ outc(f, ' ');
+ cvalue_printdata(f, data, elsize, eltype, 1);
+ data = (char*)data + elsize;
+ }
+ outc(f, ')');
+ }
+ }
+}
+
+static void
+cvalue_print(ios_t *f, value_t v)
+{+ cvalue_t *cv = ptr(v);
+ void *data = cptr(v);
+ value_t label;
+
+ if(cv_class(cv) == FL(builtintype)){+ void *fptr = *(void**)data;
+ label = (value_t)ptrhash_get(&FL(reverse_dlsym_lookup_table), cv);
+ if(label == (value_t)HT_NOTFOUND){+ FL(hpos) += ios_printf(f, "#<builtin @%p>", fptr);
+ }else{+ if(FL(print_princ)){+ outs(f, symbol_name(label));
+ }else{+ outsn(f, "#fn(", 4);+ outs(f, symbol_name(label));
+ outc(f, ')');
+ }
+ }
+ }else if(cv_class(cv)->vtable != nil && cv_class(cv)->vtable->print != nil){+ cv_class(cv)->vtable->print(v, f);
+ }else{+ value_t type = cv_type(cv);
+ size_t len = iscprim(v) ? cv_class(cv)->size : cv_len(cv);
+ cvalue_printdata(f, data, len, type, 0);
+ }
+}
+
+static void
+set_print_width(void)
+{+ value_t pw = symbol_value(FL_printwidthsym);
+ if(!isfixnum(pw))
+ return;
+ FL(scr_width) = numval(pw);
+}
+
+void
+fl_print(ios_t *f, value_t v)
+{+ FL(print_pretty) = symbol_value(FL_printprettysym) != FL_f;
+ if(FL(print_pretty))
+ set_print_width();
+ FL(print_princ) = symbol_value(FL_printreadablysym) == FL_f;
+ value_t pl = symbol_value(FL_printlengthsym);
+ FL(print_length) = isfixnum(pl) ? numval(pl) : -1;
+ pl = symbol_value(FL_printlevelsym);
+ FL(print_level) = isfixnum(pl) ? numval(pl) : -1;
+ FL(p_level) = 0;
+
+ FL(printlabel) = 0;
+ if(!FL(print_princ))
+ print_traverse(v);
+ FL(hpos) = FL(vpos) = 0;
+
+ fl_print_child(f, v);
+
+ if(FL(print_level) >= 0 || FL(print_length) >= 0)
+ memset(FL(consflags), 0, 4*bitvector_nwords(FL(heapsize)/sizeof(cons_t)));
+
+ if((iscons(v) || isvector(v) || isfunction(v) || iscvalue(v)) &&
+ !fl_isstring(v) && v != FL_t && v != FL_f && v != FL_nil && v != FL_void)
+ htable_reset(&FL(printconses), 32);
+}
--- /dev/null
+++ b/src/print.h
@@ -1,0 +1,7 @@
+#pragma once
+
+void fl_print(ios_t *f, value_t v);
+void print_traverse(value_t v);
+void fl_print_chr(ios_t *f, char c);
+void fl_print_str(ios_t *f, const char *s);
+void fl_print_child(ios_t *f, value_t v);
--- /dev/null
+++ b/src/ptrhash.c
@@ -1,0 +1,39 @@
+/*
+ pointer hash table
+ optimized for storing info about particular values
+*/
+
+#include "flisp.h"
+
+#if defined(BITS64)
+static uint64_t
+_pinthash(uint64_t key)
+{+ key = (~key) + (key << 21); // key = (key << 21) - key - 1;
+ key = key ^ (key >> 24);
+ key = (key + (key << 3)) + (key << 8); // key * 265
+ key = key ^ (key >> 14);
+ key = (key + (key << 2)) + (key << 4); // key * 21
+ key = key ^ (key >> 28);
+ key = key + (key << 31);
+ return key;
+}
+#else
+static uint32_t
+_pinthash(uint32_t a)
+{+ a = (a+0x7ed55d16) + (a<<12);
+ a = (a^0xc761c23c) ^ (a>>19);
+ a = (a+0x165667b1) + (a<<5);
+ a = (a+0xd3a2646c) ^ (a<<9);
+ a = (a+0xfd7046c5) + (a<<3);
+ a = (a^0xb55a4f09) ^ (a>>16);
+ return a;
+}
+#endif
+
+#define HTNAME(suffix) ptrhash##suffix
+#define HFUNC(v) _pinthash((value_t)(v))
+#define EQFUNC(x, y) ((x) == (y))
+
+#include "htable.inc"
--- /dev/null
+++ b/src/random.c
@@ -1,0 +1,31 @@
+#include "flisp.h"
+#include "mt19937-64.h"
+#include "timefuncs.h"
+#include "random.h"
+
+static mt19937_64 ctx;
+
+uint64_t
+genrand_uint64(void)
+{+ return genrand64_int64(&ctx);
+}
+
+uint32_t
+genrand_uint32(void)
+{+ return genrand64_int64(&ctx) >> 32;
+}
+
+double
+genrand_double(void)
+{+ return genrand64_real1(&ctx);
+}
+
+void
+randomize(void)
+{+ unsigned long long tm = sec_realtime() * 1000.0;
+ init_by_array64(&ctx, &tm, 1);
+}
--- /dev/null
+++ b/src/random.h
@@ -1,0 +1,6 @@
+#pragma once
+
+void randomize(void);
+double genrand_double(void);
+uint64_t genrand_uint64(void);
+uint32_t genrand_uint32(void);
--- /dev/null
+++ b/src/read.c
@@ -1,0 +1,737 @@
+#include "flisp.h"
+#include "cvalues.h"
+#include "read.h"
+#include "nan.h"
+
+enum {+ TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM,
+ TOK_BQ, TOK_COMMA, TOK_COMMAAT, TOK_COMMADOT,
+ TOK_SHARPDOT, TOK_LABEL, TOK_BACKREF, TOK_SHARPQUOTE, TOK_SHARPOPEN,
+ TOK_OPENB, TOK_CLOSEB, TOK_SHARPSYM, TOK_GENSYM, TOK_DOUBLEQUOTE,
+ TOK_OPENC, TOK_CLOSEC,
+};
+
+#define PAtLoc "at %"PRIu32":%"PRIu32
+
+typedef struct Rctx Rctx;
+
+struct Rctx {+ uint32_t toktype;
+ value_t tokval;
+ ios_loc_t loc;
+ char buf[1024];
+};
+
+static value_t do_read_sexpr(Rctx *ctx, value_t label);
+
+#define RS value2c(ios_t*, FL(readstate)->source)
+
+bool
+fl_read_numtok(const char *tok, value_t *pval, int base)
+{+ char *end;
+ int64_t i64;
+ double d;
+
+ if(*tok == '\0')
+ return false;
+ if(!((tok[0] == '0' && tok[1] == 'x') || (base >= 15)) && strpbrk(tok, ".eEpP")){+ d = strtod(tok, &end);
+ if(*end == '\0'){+ if(pval)
+ *pval = mk_double(d);
+ return true;
+ }
+ // floats can end in f or f0
+ if(end > tok && end[0] == 'f' &&
+ (end[1] == '\0' ||
+ (end[1] == '0' && end[2] == '\0'))){+ if(pval)
+ *pval = mk_float((float)d);
+ return true;
+ }
+ }
+
+ if(tok[0] == '+'){+ if(!strcmp(tok, "+NaN") || !strcasecmp(tok, "+nan.0")){+ if(pval)
+ *pval = mk_double(D_PNAN);
+ return true;
+ }
+ if(!strcmp(tok, "+Inf") || !strcasecmp(tok, "+inf.0")){+ if(pval)
+ *pval = mk_double(D_PINF);
+ return true;
+ }
+ }else if(tok[0] == '-'){+ if(!strcmp(tok, "-NaN") || !strcasecmp(tok, "-nan.0")){+ if(pval)
+ *pval = mk_double(D_NNAN);
+ return true;
+ }
+ if(!strcmp(tok, "-Inf") || !strcasecmp(tok, "-inf.0")){+ if(pval)
+ *pval = mk_double(D_NINF);
+ return true;
+ }
+ }
+ i64 = strtoll(tok, &end, base);
+ if(*end != '\0')
+ return false;
+ if(pval != nil){+ mpint *m;
+ if(fits_fixnum(i64))
+ *pval = fixnum(i64);
+ else if((m = strtomp(tok, &end, base, nil)) != nil)
+ *pval = mk_mpint(m);
+ else
+ return false;
+ }
+ return true;
+}
+
+static char
+nextchar(void)
+{+ int ch;
+ char c;
+ ios_t *f = RS;
+
+ do{+ ch = ios_getc(RS);
+ if(ch == IOS_EOF)
+ return 0;
+ c = (char)ch;
+ if(c == ';'){+ // single-line comment
+ do{+ ch = ios_getc(f);
+ if(ch == IOS_EOF)
+ return 0;
+ }while((char)ch != '\n');
+ c = (char)ch;
+ }
+ }while(c == ' ' || isspace(c));
+ return c;
+}
+
+static void
+take(Rctx *ctx)
+{+ ctx->toktype = TOK_NONE;
+}
+
+static _Noreturn void fl_printfmt(2, 3)
+parse_error(ios_loc_t *loc, const char *format, ...)
+{+ char msgbuf[512];
+ va_list args;
+ int n;
+
+ n = snprintf(msgbuf, sizeof(msgbuf), "%s:%"PRIu64":%"PRIu64": ",
+ loc->filename, (uint64_t)loc->lineno, (uint64_t)loc->colno);
+ if(n >= (int)sizeof(msgbuf))
+ n = 0;
+ va_start(args, format);
+ vsnprintf(msgbuf+n, sizeof(msgbuf)-n, format, args);
+ value_t msg = string_from_cstr(msgbuf);
+ va_end(args);
+
+ fl_raise(fl_list2(FL_ParseError, msg));
+}
+
+static void
+accumchar(Rctx *ctx, char c, int *pi)
+{+ ctx->buf[(*pi)++] = c;
+ if(*pi >= (int)(sizeof(ctx->buf)-1))
+ parse_error(&ctx->loc, "token too long");
+}
+
+// return: 1 if escaped (forced to be symbol)
+static bool
+read_token(Rctx *ctx, char c, bool digits)
+{+ int i = 0, ch, nc = 0;
+ bool escaped = false, issym = false;
+
+ while(1){+ if(nc != 0){+ if(nc != 1)
+ ios_getc(RS);
+ ch = ios_peekc(RS);
+ if(ch == IOS_EOF)
+ goto terminate;
+ c = (char)ch;
+ }
+ if(c == '|'){+ issym = true;
+ escaped = !escaped;
+ }else if(c == '\\'){+ issym = true;
+ ios_getc(RS);
+ ch = ios_peekc(RS);
+ if(ch == IOS_EOF)
+ goto terminate;
+ accumchar(ctx, (char)ch, &i);
+ }else if(!escaped && !(symchar(c) && (!digits || isdigit(c)))){+ break;
+ }else{+ accumchar(ctx, c, &i);
+ }
+ nc++;
+ }
+ if(nc == 0)
+ ios_skip(RS, -1);
+terminate:
+ ctx->buf[i++] = '\0';
+ return issym;
+}
+
+static int
+isdigit_base(char c, int base)
+{+ if(base < 11)
+ return c >= '0' && c < '0'+base;
+ return (c >= '0' && c <= '9') || (c >= 'a' && c < 'a'+base-10) || (c >= 'A' && c < 'A'+base-10);
+}
+
+static uint32_t
+peek(Rctx *ctx)
+{+ char c, *end;
+ fixnum_t x;
+ int ch, base;
+
+ if(ctx->toktype != TOK_NONE)
+ return ctx->toktype;
+ c = nextchar();
+ ctx->loc = RS->loc;
+ if(ios_eof(RS))
+ return TOK_NONE;
+ if(c == '(')+ ctx->toktype = TOK_OPEN;
+ else if(c == ')')
+ ctx->toktype = TOK_CLOSE;
+ else if(c == '[')
+ ctx->toktype = TOK_OPENB;
+ else if(c == ']')
+ ctx->toktype = TOK_CLOSEB;
+ else if(c == '{')+ ctx->toktype = TOK_OPENC;
+ else if(c == '}')
+ ctx->toktype = TOK_CLOSEC;
+ else if(c == '\'')
+ ctx->toktype = TOK_QUOTE;
+ else if(c == '`')
+ ctx->toktype = TOK_BQ;
+ else if(c == '"')
+ ctx->toktype = TOK_DOUBLEQUOTE;
+ else if(c == '#'){+ ch = ios_getc(RS); c = (char)ch;
+ if(ch == IOS_EOF)
+ parse_error(&ctx->loc, "invalid read macro");
+ if(c == '.')
+ ctx->toktype = TOK_SHARPDOT;
+ else if(c == '\'')
+ ctx->toktype = TOK_SHARPQUOTE;
+ else if(c == '\\'){+ Rune cval;
+ if(ios_getutf8(RS, &cval) == IOS_EOF)
+ parse_error(&ctx->loc, "end of input in character constant");
+ if(cval == 'u' || cval == 'U' || cval == 'x'){+ read_token(ctx, 'u', 0);
+ if(ctx->buf[1] != '\0'){ // not a solitary 'u','U','x'+ if(!fl_read_numtok(&ctx->buf[1], &ctx->tokval, 16))
+ parse_error(&ctx->loc, "invalid hex character constant");
+ cval = numval(ctx->tokval);
+ }
+ }else if(cval >= 'a' && cval <= 'z'){+ read_token(ctx, (char)cval, 0);
+ ctx->tokval = symbol(ctx->buf, true);
+ if(ctx->buf[1] == '\0') USED(cval); /* one character */
+ else if(ctx->tokval == FL_nulsym) cval = 0x00;
+ else if(ctx->tokval == FL_alarmsym) cval = 0x07;
+ else if(ctx->tokval == FL_backspacesym) cval = 0x08;
+ else if(ctx->tokval == FL_tabsym) cval = 0x09;
+ else if(ctx->tokval == FL_linefeedsym) cval = 0x0A;
+ else if(ctx->tokval == FL_newlinesym) cval = 0x0A;
+ else if(ctx->tokval == FL_vtabsym) cval = 0x0B;
+ else if(ctx->tokval == FL_pagesym) cval = 0x0C;
+ else if(ctx->tokval == FL_returnsym) cval = 0x0D;
+ else if(ctx->tokval == FL_escsym) cval = 0x1B;
+ else if(ctx->tokval == FL_spacesym) cval = 0x20;
+ else if(ctx->tokval == FL_deletesym) cval = 0x7F;
+ else
+ parse_error(&ctx->loc, "unknown character #\\%s", ctx->buf);
+ }
+ ctx->toktype = TOK_NUM;
+ ctx->tokval = mk_rune(cval);
+ }else if(c == '('){+ ctx->toktype = TOK_SHARPOPEN;
+ }else if(c == '<'){+ parse_error(&ctx->loc, "unreadable object");
+ }else if(isdigit(c)){+ read_token(ctx, c, 1);
+ c = (char)ios_getc(RS);
+ if(c == '#')
+ ctx->toktype = TOK_BACKREF;
+ else if(c == '=')
+ ctx->toktype = TOK_LABEL;
+ else
+ parse_error(&ctx->loc, "invalid label");
+ x = strtoll(ctx->buf, &end, 10);
+ if(*end != '\0')
+ parse_error(&ctx->loc, "invalid label");
+ ctx->tokval = fixnum(x);
+ }else if(c == '!'){+ // #! single line comment for shbang script support
+ do{+ ch = ios_getc(RS);
+ }while(ch != IOS_EOF && (char)ch != '\n');
+ return peek(ctx);
+ }else if(c == '|'){+ // multiline comment
+ int commentlevel = 1;
+ while(1){+ ch = ios_getc(RS);
+ hashpipe_gotc:
+ if(ch == IOS_EOF)
+ parse_error(&ctx->loc, "eof within comment");
+ if((char)ch == '|'){+ ch = ios_getc(RS);
+ if((char)ch == '#'){+ commentlevel--;
+ if(commentlevel == 0)
+ break;
+ else
+ continue;
+ }
+ goto hashpipe_gotc;
+ }else if((char)ch == '#'){+ ch = ios_getc(RS);
+ if((char)ch == '|')
+ commentlevel++;
+ else
+ goto hashpipe_gotc;
+ }
+ }
+ // this was whitespace, so keep peeking
+ return peek(ctx);
+ }else if(c == ';'){+ // datum comment
+ (void)do_read_sexpr(ctx, UNBOUND); // skip
+ return peek(ctx);
+ }else if(c == ':'){+ // gensym
+ ch = ios_getc(RS);
+ if((char)ch == 'g')
+ ch = ios_getc(RS);
+ read_token(ctx, (char)ch, 0);
+ x = strtol(ctx->buf, &end, 10);
+ if(*end != '\0' || ctx->buf[0] == '\0')
+ parse_error(&ctx->loc, "invalid gensym label");
+ ctx->toktype = TOK_GENSYM;
+ ctx->tokval = fixnum(x);
+ }else if(symchar(c)){+ read_token(ctx, ch, 0);
+
+ if(((c == 'b' && (base = 2)) ||
+ (c == 'o' && (base = 8)) ||
+ (c == 'd' && (base = 10)) ||
+ (c == 'x' && (base = 16))) && (isdigit_base(ctx->buf[1], base) || ctx->buf[1] == '-')){+ if(!fl_read_numtok(&ctx->buf[1], &ctx->tokval, base))
+ parse_error(&ctx->loc, "invalid base %d constant", base);
+ return (ctx->toktype = TOK_NUM);
+ }
+
+ ctx->toktype = TOK_SHARPSYM;
+ ctx->tokval = symbol(ctx->buf, true);
+ }else{+ parse_error(&ctx->loc, "unknown read macro");
+ }
+ }else if(c == ','){+ ctx->toktype = TOK_COMMA;
+ ch = ios_peekc(RS);
+ if(ch == IOS_EOF)
+ return ctx->toktype;
+ if((char)ch == '@')
+ ctx->toktype = TOK_COMMAAT;
+ else if((char)ch == '.')
+ ctx->toktype = TOK_COMMADOT;
+ else
+ return ctx->toktype;
+ ios_getc(RS);
+ }else{+ if(!read_token(ctx, c, 0)){+ if(ctx->buf[0] == '.' && ctx->buf[1] == '\0')
+ return (ctx->toktype = TOK_DOT);
+ if(fl_read_numtok(ctx->buf, &ctx->tokval, 0))
+ return (ctx->toktype = TOK_NUM);
+ }
+ ctx->toktype = TOK_SYM;
+ const char *name = (strcmp(ctx->buf, "lambda") == 0 || strcmp(ctx->buf, "λ") == 0) ? "λ" : ctx->buf;
+ ctx->tokval = strcasecmp(name, "nil") == 0 ? FL_nil : symbol(name, name == ctx->buf);
+ }
+ return ctx->toktype;
+}
+
+// NOTE: this is NOT an efficient operation. it is only used by the
+// reader, and requires at least 1 and up to 3 garbage collections!
+static value_t
+vector_grow(value_t v, bool rewrite_refs)
+{+ size_t i, s = vector_size(v);
+ size_t d = vector_grow_amt(s);
+ PUSHSAFE(v);
+ assert(s+d > s);
+ value_t newv = alloc_vector(s+d, 1);
+ v = FL(stack)[FL(sp)-1];
+ for(i = 0; i < s; i++)
+ vector_elt(newv, i) = vector_elt(v, i);
+ // use gc to rewrite references from the old vector to the new
+ FL(stack)[FL(sp)-1] = newv;
+ if(s > 0 && rewrite_refs){+ ((size_t*)ptr(v))[0] |= 0x1;
+ vector_elt(v, 0) = newv;
+ fl_gc(0);
+ }
+ return POP();
+}
+
+static value_t
+read_vector(Rctx *ctx, value_t label, uint32_t closer)
+{+ value_t v = FL(the_empty_vector), elt;
+ uint32_t i = 0;
+ PUSHSAFE(v);
+ if(label != UNBOUND)
+ ptrhash_put(&FL(readstate)->backrefs, (void*)label, (void*)v);
+ while(peek(ctx) != closer){+ if(ios_eof(RS))
+ parse_error(&ctx->loc, "unexpected end of input");
+ v = FL(stack)[FL(sp)-1]; // reload after possible alloc in peek()
+ if(i >= vector_size(v)){+ v = FL(stack)[FL(sp)-1] = vector_grow(v, label != UNBOUND);
+ if(label != UNBOUND)
+ ptrhash_put(&FL(readstate)->backrefs, (void*)label, (void*)v);
+ }
+ elt = do_read_sexpr(ctx, UNBOUND);
+ v = FL(stack)[FL(sp)-1];
+ assert(i < vector_size(v));
+ vector_elt(v, i) = elt;
+ i++;
+ }
+ take(ctx);
+ if(i > 0)
+ vector_setsize(v, i);
+ return POP();
+}
+
+static value_t
+read_string(Rctx *ctx)
+{+ char *buf, *temp;
+ char eseq[10];
+ size_t i = 0, j, sz, ndig;
+ int c;
+ value_t s;
+ Rune r = 0;
+
+ sz = sizeof(ctx->buf);
+ buf = ctx->buf;
+ while(1){+ if(i >= sz-UTFmax){ // -UTFmax: leaves room for longest utf8 sequence+ sz *= 2;
+ if(buf == ctx->buf){+ if((temp = MEM_ALLOC(sz)) != nil)
+ memcpy(temp, ctx->buf, i);
+ }else
+ temp = MEM_REALLOC(buf, sz);
+ if(temp == nil){+ if(buf == ctx->buf)
+ MEM_FREE(buf);
+ parse_error(&ctx->loc, "out of memory reading string");
+ }
+ buf = temp;
+ }
+ c = ios_getc(RS);
+ if(c == IOS_EOF){+ if(buf != ctx->buf)
+ MEM_FREE(buf);
+ parse_error(&ctx->loc, "unexpected end of input in string");
+ }
+ if(c == '"')
+ break;
+ else if(c == '\\'){+ c = ios_getc(RS);
+ if(c == IOS_EOF){+ if(buf != ctx->buf)
+ MEM_FREE(buf);
+ parse_error(&ctx->loc, "end of input in escape sequence");
+ }
+ j = 0;
+ if(octal_digit(c)){+ while(1){+ eseq[j++] = c;
+ c = ios_peekc(RS);
+ if(c == IOS_EOF || !octal_digit(c) || j >= 3)
+ break;
+ ios_getc(RS);
+ }
+ eseq[j] = '\0';
+ r = strtol(eseq, nil, 8);
+ // \DDD and \xXX read bytes, not characters
+ buf[i++] = (char)r;
+ }else if((c == 'x' && (ndig = 2)) || (c == 'u' && (ndig = 4)) || (c == 'U' && (ndig = 8))){+ while(1){+ c = ios_peekc(RS);
+ if(c == IOS_EOF || !hex_digit(c) || j >= ndig)
+ break;
+ eseq[j++] = c;
+ ios_getc(RS);
+ }
+ eseq[j] = '\0';
+ if(j)
+ r = strtol(eseq, nil, 16);
+ if(!j || r > Runemax){+ if(buf != ctx->buf)
+ MEM_FREE(buf);
+ parse_error(&ctx->loc, "invalid escape sequence");
+ }
+ if(ndig == 2)
+ buf[i++] = (char)r;
+ else
+ i += runetochar(&buf[i], &r);
+ }else if(c == '\n'){+ /* do nothing */
+ }else{+ char esc = read_escape_control_char((char)c);
+ if(esc == (char)c && !strchr("\\'\"`", esc)){+ if(buf != ctx->buf)
+ MEM_FREE(buf);
+ ios_loc_t *l = &RS->loc;
+ parse_error(
+ &ctx->loc,
+ "invalid escape sequence \\%c "PAtLoc,
+ (char)c,
+ l->lineno,
+ l->colno
+ );
+ }
+ buf[i++] = esc;
+ }
+ }else{+ buf[i++] = c;
+ }
+ }
+ s = cvalue_string(i);
+ memcpy(cvalue_data(s), buf, i);
+ if(buf != ctx->buf)
+ MEM_FREE(buf);
+ return s;
+}
+
+// build a list of conses. this is complicated by the fact that all conses
+// can move whenever a new cons is allocated. we have to refer to every cons
+// through a handle to a relocatable pointer (i.e. a pointer on the stack).
+static void
+read_list(Rctx *ctx, value_t label, uint32_t closer)
+{+ value_t c, *pc, *pval;
+ uint32_t t, ipval, ipc;
+ ios_loc_t loc0;
+
+ loc0 = RS->loc;
+ loc0.colno--;
+ ipval = FL(sp)-1;
+ PUSHSAFE(FL_nil);
+ ipc = FL(sp)-1; // to keep track of current cons cell
+ t = peek(ctx);
+ while(t != closer){+ if(ios_eof(RS))
+ parse_error(&loc0, "not closed: unexpected EOI "PAtLoc, ctx->loc.lineno, ctx->loc.colno);
+ c = mk_cons(); car_(c) = cdr_(c) = FL_nil;
+ pc = &FL(stack)[ipc];
+ if(iscons(*pc))
+ cdr_(*pc) = c;
+ else{+ pval = &FL(stack)[ipval];
+ *pval = c;
+ if(label != UNBOUND)
+ ptrhash_put(&FL(readstate)->backrefs, (void*)label, (void*)c);
+ }
+ *pc = c;
+ c = do_read_sexpr(ctx, UNBOUND);
+ pc = &FL(stack)[ipc];
+ car_(*pc) = c;
+
+ t = peek(ctx);
+ if(t == TOK_DOT){+ take(ctx);
+ c = do_read_sexpr(ctx, UNBOUND);
+ pc = &FL(stack)[ipc];
+ cdr_(*pc) = c;
+ t = peek(ctx);
+ if(ios_eof(RS))
+ parse_error(&ctx->loc, "unexpected end of input");
+ if(t != closer){+ take(ctx);
+ parse_error(
+ &ctx->loc,
+ "expected '%c'",
+ closer == TOK_CLOSEB ? ']' : (closer == TOK_CLOSEC ? '}' : ')')
+ );
+ }
+ }
+ }
+ take(ctx);
+ c = POP();
+ USED(c);
+}
+
+// label is the backreference we'd like to fix up with this read
+static value_t
+do_read_sexpr(Rctx *ctx, value_t label)
+{+ value_t v, sym, oldtokval, *head;
+ value_t *pv;
+ uint32_t t;
+ char c;
+
+ t = peek(ctx);
+ take(ctx);
+ switch(t){+ case TOK_OPEN:
+ PUSHSAFE(FL_nil);
+ read_list(ctx, label, TOK_CLOSE);
+ return POP();
+ case TOK_SYM:
+ case TOK_NUM:
+ return ctx->tokval;
+ case TOK_OPENB:
+ PUSHSAFE(FL_nil);
+ read_list(ctx, label, TOK_CLOSEB);
+ return POP();
+ case TOK_OPENC:
+ PUSHSAFE(FL_nil);
+ read_list(ctx, label, TOK_CLOSEC);
+ return POP();
+ case TOK_COMMA:
+ head = &FL_comma; goto listwith;
+ case TOK_COMMAAT:
+ head = &FL_commaat; goto listwith;
+ case TOK_COMMADOT:
+ head = &FL_commadot; goto listwith;
+ case TOK_BQ:
+ head = &FL_backquote; goto listwith;
+ case TOK_QUOTE:
+ head = &FL_quote;
+ listwith:
+ v = cons_reserve(2);
+ car_(v) = *head;
+ cdr_(v) = tagptr((cons_t*)ptr(v)+1, TAG_CONS);
+ car_(cdr_(v)) = cdr_(cdr_(v)) = FL_nil;
+ PUSHSAFE(v);
+ if(label != UNBOUND)
+ ptrhash_put(&FL(readstate)->backrefs, (void*)label, (void*)v);
+ v = do_read_sexpr(ctx, UNBOUND);
+ car_(cdr_(FL(stack)[FL(sp)-1])) = v;
+ return POP();
+ case TOK_SHARPQUOTE:
+ // femtoLisp doesn't need symbol-function, so #' does nothing
+ return do_read_sexpr(ctx, label);
+ case TOK_SHARPSYM:
+ sym = ctx->tokval;
+ if(sym == FL_tsym || sym == FL_Tsym)
+ return FL_t;
+ if(sym == FL_fsym || sym == FL_Fsym)
+ return FL_f;
+ // constructor notation
+ c = nextchar();
+ ctx->loc = RS->loc;
+ if(c != '('){+ take(ctx);
+ parse_error(&ctx->loc, "expected argument list for %s", symbol_name(ctx->tokval));
+ }
+ PUSHSAFE(FL_nil);
+ read_list(ctx, UNBOUND, TOK_CLOSE);
+ if(sym == FL_vu8sym){+ sym = FL_arraysym;
+ FL(stack)[FL(sp)-1] = fl_cons(FL_uint8sym, FL(stack)[FL(sp)-1]);
+ }else if(sym == FL_fnsym){+ sym = FL_function;
+ }
+ v = symbol_value(sym);
+ if(v == UNBOUND)
+ unbound_error(sym);
+ return fl_apply(v, POP());
+ case TOK_SHARPOPEN:
+ return read_vector(ctx, label, TOK_CLOSE);
+ case TOK_SHARPDOT:
+ // eval-when-read
+ // evaluated expressions can refer to existing backreferences, but they
+ // cannot see pending labels. in other words:
+ // (... #2=#.#0# ... ) OK
+ // (... #2=#.(#2#) ... ) DO NOT WANT
+ sym = do_read_sexpr(ctx, UNBOUND);
+ if(issymbol(sym)){+ v = symbol_value(sym);
+ if(v == UNBOUND)
+ unbound_error(sym);
+ return v;
+ }
+ return fl_toplevel_eval(sym);
+ case TOK_LABEL:
+ // create backreference label
+ if(ptrhash_has(&FL(readstate)->backrefs, (void*)ctx->tokval))
+ parse_error(&ctx->loc, "label %"PRIdPTR" redefined", (intptr_t)numval(ctx->tokval));
+ oldtokval = ctx->tokval;
+ v = do_read_sexpr(ctx, ctx->tokval);
+ ptrhash_put(&FL(readstate)->backrefs, (void*)oldtokval, (void*)v);
+ return v;
+ case TOK_BACKREF:
+ // look up backreference
+ v = (value_t)ptrhash_get(&FL(readstate)->backrefs, (void*)ctx->tokval);
+ if(v == (value_t)HT_NOTFOUND)
+ parse_error(&ctx->loc, "undefined label %"PRIdPTR, (intptr_t)numval(ctx->tokval));
+ return v;
+ case TOK_GENSYM:
+ pv = (value_t*)ptrhash_bp(&FL(readstate)->gensyms, (void*)ctx->tokval);
+ if(*pv == (value_t)HT_NOTFOUND)
+ *pv = gensym();
+ return *pv;
+ case TOK_DOUBLEQUOTE:
+ return read_string(ctx);
+ case TOK_CLOSE:
+ parse_error(&ctx->loc, "unexpected ')'");
+ case TOK_CLOSEB:
+ parse_error(&ctx->loc, "unexpected ']'");
+ case TOK_CLOSEC:
+ parse_error(&ctx->loc, "unexpected '}'");
+ case TOK_DOT:
+ parse_error(&ctx->loc, "unexpected '.'");
+ }
+ return FL_void;
+}
+
+value_t
+fl_read_sexpr(value_t f)
+{+ fl_readstate_t state;
+ state.prev = FL(readstate);
+ htable_new(&state.backrefs, 8);
+ htable_new(&state.gensyms, 8);
+ state.source = f;
+ FL(readstate) = &state;
+ Rctx ctx;
+ ctx.toktype = TOK_NONE;
+ fl_gc_handle(&ctx.tokval);
+
+ value_t v = do_read_sexpr(&ctx, UNBOUND);
+
+ fl_free_gc_handles(1);
+ FL(readstate) = state.prev;
+ free_readstate(&state);
+ return v;
+}
--- /dev/null
+++ b/src/read.h
@@ -1,0 +1,10 @@
+#pragma once
+
+value_t fl_read_sexpr(value_t f);
+bool fl_read_numtok(const char *tok, value_t *pval, int base);
+
+// defines which characters are ordinary symbol characters.
+// exceptions are '.', which is an ordinary symbol character
+// unless it's the only character in the symbol, and '#', which is
+// an ordinary symbol character unless it's the first character.
+#define symchar(c) (!strchr("()[]{}'\";`,\\| \a\b\f\n\r\t\v", (c)))--- /dev/null
+++ b/src/string.c
@@ -1,0 +1,409 @@
+/*
+ string functions
+*/
+#include "flisp.h"
+#include "operators.h"
+#include "cvalues.h"
+#include "print.h"
+#include "read.h"
+#include "equal.h"
+#include "iostream.h"
+
+fl_purefn
+BUILTIN("string?", stringp)+{+ argcount(nargs, 1);
+ return fl_isstring(args[0]) ? FL_t : FL_f;
+}
+
+BUILTIN("string-length", string_length)+{+ size_t start = 0;
+ if(nargs < 1 || nargs > 3)
+ argcount(nargs, 1);
+ if(!fl_isstring(args[0]))
+ type_error("string", args[0]);+ size_t len = cv_len(ptr(args[0]));
+ size_t stop = len;
+ if(nargs > 1){+ start = tosize(args[1]);
+ if(start > len)
+ bounds_error(args[0], args[1]);
+ if(nargs > 2){+ stop = tosize(args[2]);
+ if(stop > len)
+ bounds_error(args[0], args[2]);
+ if(stop <= start)
+ return fixnum(0);
+ }
+ }
+ char *str = cvalue_data(args[0]);
+ return size_wrap(u8_charnum(str+start, stop-start));
+}
+
+BUILTIN("string-width", string_width)+{+ argcount(nargs, 1);
+ if(iscprim(args[0])){+ cprim_t *cp = ptr(args[0]);
+ if(cp_class(cp) == FL(runetype)){+ int w = wcwidth(*(Rune*)cp_data(cp));
+ return w < 0 ? FL_f : fixnum(w);
+ }
+ }
+ return size_wrap(u8_strwidth(tostring(args[0])));
+}
+
+BUILTIN("string-reverse", string_reverse)+{+ argcount(nargs, 1);
+ if(!fl_isstring(args[0]))
+ type_error("string", args[0]);+ size_t len = cv_len(ptr(args[0]));
+ value_t ns = cvalue_string(len);
+ u8_reverse(cvalue_data(ns), cvalue_data(args[0]), len);
+ return ns;
+}
+
+BUILTIN("string-encode", string_encode)+{+ argcount(nargs, 1);
+ if(iscvalue(args[0])){+ cvalue_t *cv = ptr(args[0]);
+ fltype_t *t = cv_class(cv);
+ if(t->eltype == FL(runetype)){+ size_t nr = cv_len(cv) / sizeof(Rune);
+ Rune *r = (Rune*)cv_data(cv);
+ size_t nb = runenlen(r, nr);
+ value_t str = cvalue_string(nb);
+ char *s = cvalue_data(str);
+ for(size_t i = 0; i < nr; i++)
+ s += runetochar(s, r+i);
+ return str;
+ }
+ }
+ type_error("rune array", args[0]);+}
+
+BUILTIN("string-decode", string_decode)+{+ int term = 0;
+ if(nargs == 2)
+ term = args[1] != FL_f;
+ else
+ argcount(nargs, 1);
+ if(!fl_isstring(args[0]))
+ type_error("string", args[0]);+ cvalue_t *cv = ptr(args[0]);
+ char *ptr = (char*)cv_data(cv);
+ size_t nb = cv_len(cv);
+ size_t nc = utfnlen(ptr, nb);
+ size_t newsz = nc*sizeof(Rune);
+ if(term)
+ newsz += sizeof(Rune);
+ value_t runestr = cvalue(FL(runestringtype), newsz);
+ ptr = cvalue_data(args[0]); // relocatable pointer
+ Rune *r = cvalue_data(runestr);
+ for(size_t i = 0; i < nb; i++)
+ ptr += chartorune(r+i, ptr);
+ if(term)
+ r[nb] = 0;
+ return runestr;
+}
+
+BUILTIN("string", string)+{+ if(nargs == 1 && fl_isstring(args[0]))
+ return args[0];
+ value_t arg, buf = fn_builtin_buffer(nil, 0);
+ fl_gc_handle(&buf);
+ ios_t *s = value2c(ios_t*, buf);
+ value_t oldpr = symbol_value(FL_printreadablysym);
+ value_t oldpp = symbol_value(FL_printprettysym);
+ set(FL_printreadablysym, FL_f);
+ set(FL_printprettysym, FL_f);
+ uint32_t i;
+ FOR_ARGS(i, 0, arg, args){+ USED(arg);
+ fl_print(s, args[i]);
+ }
+ set(FL_printreadablysym, oldpr);
+ set(FL_printprettysym, oldpp);
+ value_t outp = stream_to_string(&buf);
+ fl_free_gc_handles(1);
+ return outp;
+}
+
+BUILTIN("string-split", string_split)+{+ argcount(nargs, 2);
+ char *s = tostring(args[0]);
+ char *delim = tostring(args[1]);
+ size_t len = cv_len(ptr(args[0]));
+ size_t dlen = cv_len(ptr(args[1]));
+ size_t ssz, tokend, tokstart, i = 0;
+ value_t first = FL_nil, c = FL_nil, last;
+ size_t junk;
+ fl_gc_handle(&first);
+ fl_gc_handle(&last);
+
+ do{+ // find and allocate next token
+ tokstart = tokend = i;
+ while(i < len && !u8_memchr(delim, u8_nextmemchar(s, &i), dlen, &junk))
+ tokend = i;
+ ssz = tokend - tokstart;
+ last = c; // save previous cons cell
+ c = fl_cons(cvalue_string(ssz), FL_nil);
+
+ // we've done allocation; reload movable pointers
+ s = cvalue_data(args[0]);
+ delim = cvalue_data(args[1]);
+
+ if(ssz)
+ memmove(cvalue_data(car_(c)), &s[tokstart], ssz);
+
+ // link new cell
+ if(last == FL_nil)
+ first = c; // first time, save first cons
+ else
+ ((cons_t*)ptr(last))->cdr = c;
+
+ // note this tricky condition: if the string ends with a
+ // delimiter, we need to go around one more time to add an
+ // empty string. this happens when (i == len && tokend < i)
+ }while(i < len || (i == len && (tokend != i)));
+ fl_free_gc_handles(2);
+ return first;
+}
+
+BUILTIN("string-sub", string_sub)+{+ if(nargs != 2)
+ argcount(nargs, 3);
+ char *s = tostring(args[0]);
+ size_t lenbytes = cv_len(ptr(args[0]));
+ size_t startbytes, n, startchar = tosize(args[1]);
+ for(startbytes = n = 0; n < startchar && startbytes < lenbytes; n++)
+ startbytes += u8_seqlen(s+startbytes);
+ if(n != startchar)
+ bounds_error(args[0], args[1]);
+ size_t endbytes = lenbytes;
+ if(nargs == 3){+ size_t endchar = tosize(args[2]);
+ for(endbytes = startbytes; n < endchar && endbytes < lenbytes; n++)
+ endbytes += u8_seqlen(s+endbytes);
+ if(n != endchar)
+ bounds_error(args[0], args[2]);
+ }
+ value_t ns = cvalue_string(endbytes-startbytes);
+ s = cvalue_data(args[0]); // reload after alloc
+ memmove(cvalue_data(ns), s+startbytes, endbytes-startbytes);
+ return ns;
+}
+
+BUILTIN("string-char", string_char)+{+ argcount(nargs, 2);
+ char *s = tostring(args[0]);
+ size_t lenbytes = cv_len(ptr(args[0]));
+ size_t startbytes, n, startchar = tosize(args[1]);
+ for(startbytes = n = 0; n < startchar && startbytes < lenbytes; n++)
+ startbytes += u8_seqlen(s+startbytes);
+ if(n != startchar)
+ bounds_error(args[0], args[1]);
+ Rune r;
+ chartorune(&r, s+startbytes);
+ return mk_rune(r);
+}
+
+BUILTIN("char-upcase", char_upcase)+{+ argcount(nargs, 1);
+ cprim_t *cp = ptr(args[0]);
+ if(!iscprim(args[0]) || cp_class(cp) != FL(runetype))
+ type_error("rune", args[0]);+ return mk_rune(toupperrune(*(Rune*)cp_data(cp)));
+}
+
+BUILTIN("char-downcase", char_downcase)+{+ argcount(nargs, 1);
+ cprim_t *cp = ptr(args[0]);
+ if(!iscprim(args[0]) || cp_class(cp) != FL(runetype))
+ type_error("rune", args[0]);+ return mk_rune(tolowerrune(*(Rune*)cp_data(cp)));
+}
+
+BUILTIN("char-titlecase", char_titlecase)+{+ argcount(nargs, 1);
+ cprim_t *cp = ptr(args[0]);
+ if(!iscprim(args[0]) || cp_class(cp) != FL(runetype))
+ type_error("rune", args[0]);+ return mk_rune(totitlerune(*(Rune*)cp_data(cp)));
+}
+
+fl_purefn
+BUILTIN("char-alphabetic?", char_alphabeticp)+{+ argcount(nargs, 1);
+ cprim_t *cp = ptr(args[0]);
+ if(!iscprim(args[0]) || cp_class(cp) != FL(runetype))
+ type_error("rune", args[0]);+ return isalpharune(*(Rune*)cp_data(cp)) ? FL_t : FL_f;
+}
+
+fl_purefn
+BUILTIN("char-lower-case?", char_lower_casep)+{+ argcount(nargs, 1);
+ cprim_t *cp = ptr(args[0]);
+ if(!iscprim(args[0]) || cp_class(cp) != FL(runetype))
+ type_error("rune", args[0]);+ return islowerrune(*(Rune*)cp_data(cp)) ? FL_t : FL_f;
+}
+
+fl_purefn
+BUILTIN("char-upper-case?", char_upper_casep)+{+ argcount(nargs, 1);
+ cprim_t *cp = ptr(args[0]);
+ if(!iscprim(args[0]) || cp_class(cp) != FL(runetype))
+ type_error("rune", args[0]);+ return isupperrune(*(Rune*)cp_data(cp)) ? FL_t : FL_f;
+}
+
+fl_purefn
+BUILTIN("char-title-case?", char_title_casep)+{+ argcount(nargs, 1);
+ cprim_t *cp = ptr(args[0]);
+ if(!iscprim(args[0]) || cp_class(cp) != FL(runetype))
+ type_error("rune", args[0]);+ return istitlerune(*(Rune*)cp_data(cp)) ? FL_t : FL_f;
+}
+
+fl_purefn
+BUILTIN("char-numeric?", char_numericp)+{+ argcount(nargs, 1);
+ cprim_t *cp = ptr(args[0]);
+ if(!iscprim(args[0]) || cp_class(cp) != FL(runetype))
+ type_error("rune", args[0]);+ return isdigitrune(*(Rune*)cp_data(cp)) ? FL_t : FL_f;
+}
+
+fl_purefn
+BUILTIN("char-whitespace?", char_whitespacep)+{+ argcount(nargs, 1);
+ cprim_t *cp = ptr(args[0]);
+ if(!iscprim(args[0]) || cp_class(cp) != FL(runetype))
+ type_error("rune", args[0]);+ return isspacerune(*(Rune*)cp_data(cp)) ? FL_t : FL_f;
+}
+
+BUILTIN("string-find", string_find)+{+ char cbuf[UTFmax+1];
+ size_t start = 0;
+ if(nargs == 3)
+ start = tosize(args[2]);
+ else
+ argcount(nargs, 2);
+ char *s = tostring(args[0]);
+ size_t len = cv_len(ptr(args[0]));
+ if(start > len)
+ bounds_error(args[0], args[2]);
+ char *needle; size_t needlesz;
+
+ value_t v = args[1];
+ cprim_t *cp = ptr(v);
+ if(iscprim(v) && cp_class(cp) == FL(runetype)){+ Rune r = *(Rune*)cp_data(cp);
+ needlesz = runetochar(cbuf, &r);
+ needle = cbuf;
+ needle[needlesz] = 0;
+ }else if(iscprim(v) && cp_class(cp) == FL(bytetype)){+ needlesz = 1;
+ needle = cbuf;
+ needle[0] = *(char*)cp_data(cp);
+ needle[needlesz] = 0;
+ }else if(fl_isstring(v)){+ cvalue_t *cv = ptr(v);
+ needlesz = cv_len(cv);
+ needle = (char*)cv_data(cv);
+ }else{+ type_error("string", args[1]);+ }
+ if(needlesz > len-start)
+ return FL_f;
+ if(needlesz == 0)
+ return size_wrap(start);
+ size_t i;
+ for(i = start; i < len-needlesz+1; i++){+ if(s[i] == needle[0] && memcmp(&s[i+1], needle+1, needlesz-1) == 0)
+ return size_wrap(i);
+ }
+ return FL_f;
+}
+
+static unsigned long
+get_radix_arg(value_t arg)
+{+ unsigned long radix = tosize(arg);
+ if(radix < 2 || radix > 36)
+ lerrorf(FL_ArgError, "invalid radix");
+ return radix;
+}
+
+BUILTIN("number->string", number_2_string)+{+ if(nargs < 1 || nargs > 2)
+ argcount(nargs, 2);
+ value_t n = args[0];
+ int neg = 0;
+ uint64_t num;
+ if(isfixnum(n))
+ num = numval(n);
+ else if(!iscprim(n))
+ type_error("integer", n);+ else
+ num = conv_to_uint64(cp_data(ptr(n)), cp_numtype(ptr(n)));
+ if(numval(fl_compare(args[0], fixnum(0), false)) < 0){+ num = -num;
+ neg = 1;
+ }
+ unsigned long radix = 10;
+ if(nargs == 2)
+ radix = get_radix_arg(args[1]);
+ char buf[128];
+ char *str = uint2str(buf, sizeof(buf), num, radix);
+ if(neg && str > &buf[0])
+ *(--str) = '-';
+ return string_from_cstr(str);
+}
+
+BUILTIN("string->number", string_2_number)+{+ if(nargs < 1 || nargs > 2)
+ argcount(nargs, 2);
+ char *str = tostring(args[0]);
+ value_t n;
+ unsigned long radix = 0;
+ if(nargs == 2)
+ radix = get_radix_arg(args[1]);
+ if(!fl_read_numtok(str, &n, (int)radix))
+ return FL_f;
+ return n;
+}
+
+fl_purefn
+BUILTIN("string-utf8?", string_utf8p)+{+ argcount(nargs, 1);
+ char *s = tostring(args[0]);
+ size_t len = cv_len(ptr(args[0]));
+ return u8_isvalid(s, len) ? FL_t : FL_f;
+}
--- /dev/null
+++ b/src/system.lsp
@@ -1,0 +1,1154 @@
+; -*- scheme -*-
+; femtoLisp standard library
+; by Jeff Bezanson (C) 2009
+; Distributed under the BSD License
+
+;;; void
+
+(define (void . rest)
+ "Return the constant #<void> while ignoring any arguments.
+#<void> is mainly used when a function has side effects but does not
+produce any meaningful value to return, so even though #t or nil could
+be returned instead, in case of #<void> alone, REPL will not print
+it."
+ #.(void))
+
+(define (void? x)
+ "Return #t if x is #<void> and #f otherwise."
+ (eq? x #.(void)))
+
+;;; syntax environment
+
+(unless (bound? '*syntax-environment*)
+ (define *syntax-environment* (table)))
+
+(define (set-syntax! s v) (put! *syntax-environment* s v))
+(define (symbol-syntax s) (get *syntax-environment* s #f))
+
+(define-macro (define-macro form . body)
+ (let ((doc (value-get-doc body)))
+ (when doc
+ (symbol-set-doc (car form) doc (cdr form))
+ (set! body (cdr body)))
+ `(void (set-syntax! ',(car form)
+ (λ ,(cdr form) ,@body)))))
+
+(define-macro (letrec binds . body)
+ `((λ ,(map car binds)
+ ,.(map (λ (b) `(set! ,@b)) binds)
+ ,@body)
+ ,.(map void binds)))
+
+(define-macro (let binds . body)
+ (let ((lname #f))
+ (when (symbol? binds)
+ (set! lname binds)
+ (set! binds (car body))
+ (set! body (cdr body)))
+ (let ((thelambda
+ `(λ ,(map (λ (c) (if (cons? c) (car c) c))
+ binds)
+ ,@body))
+ (theargs
+ (map (λ (c) (if (cons? c) (cadr c) (void))) binds)))
+ (cons (if lname
+ `(letrec ((,lname ,thelambda)) ,lname)
+ thelambda)
+ theargs))))
+
+(define-macro (cond . clauses)
+ (define (cond-clauses->if lst)
+ (if (atom? lst)
+ #f
+ (let ((clause (car lst)))
+ (if (or (eq? (car clause) 'else)
+ (eq? (car clause) #t))
+ (if (null? (cdr clause))
+ (car clause)
+ (cons 'begin (cdr clause)))
+ (if (null? (cdr clause))
+ ; test by itself
+ (list 'or
+ (car clause)
+ (cond-clauses->if (cdr lst)))
+ ; test => expression
+ (if (eq? (cadr clause) '=>)
+ (if (1arg-lambda? (caddr clause))
+ ; test => (λ (x) ...)
+ (let ((var (caadr (caddr clause))))
+ `(let ((,var ,(car clause)))
+ (if ,var ,(cons 'begin (cddr (caddr clause)))
+ ,(cond-clauses->if (cdr lst)))))
+ ; test => proc
+ (let ((b (gensym)))
+ `(let ((,b ,(car clause)))
+ (if ,b
+ (,(caddr clause) ,b)
+ ,(cond-clauses->if (cdr lst))))))
+ (list 'if
+ (car clause)
+ (cons 'begin (cdr clause))
+ (cond-clauses->if (cdr lst)))))))))
+ (cond-clauses->if clauses))
+
+;;; props
+
+;; This is implemented in a slightly different fashion as expected:
+;;
+;; *properties* : key → { symbol → value }+;;
+;; The assumption here is that keys will most likely be the same across multiple symbols
+;; so it makes more sense to reduce the number of subtables for the *properties* table.
+(unless (bound? '*properties*)
+ (define *properties* (table)))
+
+(define (putprop sym key val)
+ (let ((kt (get *properties* key #f)))
+ (unless kt
+ (let ((t (table)))
+ (put! *properties* key t)
+ (set! kt t)))
+ (put! kt sym val)
+ val))
+
+(define (getprop sym key (def #f))
+ (let ((kt (get *properties* key #f)))
+ (or (and kt (get kt sym def)) def)))
+
+(define (remprop sym key)
+ (let ((kt (get *properties* key #f)))
+ (and kt (has? kt sym) (del! kt sym))))
+
+;;; documentation
+
+(define (symbol-set-doc sym doc . funvars)
+ (when doc
+ (putprop sym '*doc* doc))
+ (when (cons? funvars)
+ (putprop sym '*funvars* (append (getprop sym '*funvars* nil)
+ funvars))))
+
+;; chicken and egg - properties defined before symbol-set-doc
+(symbol-set-doc
+ '*properties*
+ "All properties of symbols recorded with putprop are recorded in this table.")
+
+(define-macro (help term)
+ "Display documentation for the specified term, if available."
+ (let* ((doc (getprop term '*doc*)))
+ (if doc
+ (begin
+ (princ doc)
+ (newline)
+ (for-each (λ (funvars) (newline) (print (cons term funvars)))
+ (getprop term '*funvars* nil))
+ (newline))
+ (begin
+ (princ "no help for " (string term))
+ (newline)))
+ (void)))
+
+(define (value-get-doc body)
+ (let ((first (car body))
+ (rest (cdr body)))
+ (and (string? first) (cons? rest) first)))
+
+;;; standard procedures
+
+(define (member item lst)
+ (cond ((null? lst) #f)
+ ((equal? (car lst) item) lst)
+ (#t (member item (cdr lst)))))
+(define (memv item lst)
+ (cond ((null? lst) #f)
+ ((eqv? (car lst) item) lst)
+ (#t (memv item (cdr lst)))))
+
+(define (assoc item lst)
+ (cond ((null? lst) #f)
+ ((equal? (caar lst) item) (car lst))
+ (#t (assoc item (cdr lst)))))
+(define (assv item lst)
+ (cond ((null? lst) #f)
+ ((eqv? (caar lst) item) (car lst))
+ (#t (assv item (cdr lst)))))
+
+(define (> a . rest)
+ "Return #t if the arguments are in strictly decreasing order (previous
+one is greater than the next one)."
+ (let loop ((a a) (rest rest))
+ (or (null? rest)
+ (and (< (car rest) a)
+ (loop (car rest) (cdr rest))))))
+(define-macro (> a . rest)
+ `(< ,@(reverse! rest) ,a))
+
+(define (<= a . rest)
+ "Return #t if the arguments are in non-decreasing order (previous
+one is less than or equal to the next one)."
+ (let loop ((a a) (rest rest))
+ (or (null? rest)
+ (unless (or (< (car rest) a)
+ (nan? a))
+ (loop (car rest) (cdr rest))))))
+
+(define (>= a . rest)
+ "Return #t if the arguments are in non-increasing order (previous
+one is greater than or equal to the next one)."
+ (let loop ((a a) (rest rest))
+ (or (null? rest)
+ (unless (or (< a (car rest))
+ (nan? a))
+ (loop (car rest) (cdr rest))))))
+
+(define-macro (/= a . rest)
+ "Return #t if not all arguments are equal. Shorthand for (not (= …))."
+ `(not (= ,a ,@rest)))
+
+(define (negative? x) (< x 0))
+(define (zero? x) (= x 0))
+(define (positive? x) (> x 0))
+(define (even? x) (= (logand x 1) 0))
+(define (odd? x) (not (even? x)))
+(define (identity x) x)
+(define (1+ n) (+ n 1))
+(define (1- n) (- n 1))
+(define (mod0 x y) (- x (* (div0 x y) y)))
+(define (div x y) (+ (div0 x y)
+ (or (and (< x 0)
+ (or (and (< y 0) 1)
+ -1))
+ 0)))
+(define (mod x y) (- x (* (div x y) y)))
+(define (random n)
+ (if (integer? n)
+ (mod (rand) n)
+ (* (rand-double) n)))
+(define (abs x) (if (< x 0) (- x) x))
+(define (max x0 . xs)
+ (if (null? xs) x0
+ (foldl (λ (a b) (if (< a b) b a)) x0 xs)))
+(define (min x0 . xs)
+ (if (null? xs) x0
+ (foldl (λ (a b) (if (< a b) a b)) x0 xs)))
+(define (char? x) (eq? (typeof x) 'rune))
+(define (array? x) (or (vector? x)
+ (let ((t (typeof x)))
+ (and (cons? t) (eq? (car t) 'array)))))
+(define (closure? x) (and (function? x) (not (builtin? x))))
+
+(define (caar x) (car (car x)))
+(define (cdar x) (cdr (car x)))
+(define (cddr x) (cdr (cdr x)))
+(define (caaar x) (car (car (car x))))
+(define (caadr x) (car (car (cdr x))))
+(define (cadar x) (car (cdr (car x))))
+(define (caddr x) (car (cdr (cdr x))))
+(define (cdaar x) (cdr (car (car x))))
+(define (cdadr x) (cdr (car (cdr x))))
+(define (cddar x) (cdr (cdr (car x))))
+(define (cdddr x) (cdr (cdr (cdr x))))
+(define (caaaar x) (car (car (car (car x)))))
+(define (caaadr x) (car (car (car (cdr x)))))
+(define (caadar x) (car (car (cdr (car x)))))
+(define (caaddr x) (car (car (cdr (cdr x)))))
+(define (cadaar x) (car (cdr (car (car x)))))
+(define (cadadr x) (car (cdr (car (cdr x)))))
+(define (caddar x) (car (cdr (cdr (car x)))))
+(define (cadddr x) (car (cdr (cdr (cdr x)))))
+(define (cdaaar x) (cdr (car (car (car x)))))
+(define (cdaadr x) (cdr (car (car (cdr x)))))
+(define (cdadar x) (cdr (car (cdr (car x)))))
+(define (cdaddr x) (cdr (car (cdr (cdr x)))))
+(define (cddaar x) (cdr (cdr (car (car x)))))
+(define (cddadr x) (cdr (cdr (car (cdr x)))))
+(define (cdddar x) (cdr (cdr (cdr (car x)))))
+(define (cddddr x) (cdr (cdr (cdr (cdr x)))))
+
+(let ((*values* (list '*values*)))
+ (set! values
+ (λ vs
+ (if (and (cons? vs) (null? (cdr vs)))
+ (car vs)
+ (cons *values* vs))))
+ (set! call-with-values
+ (λ (producer consumer)
+ (let ((res (producer)))
+ (if (and (cons? res) (eq? *values* (car res)))
+ (apply consumer (cdr res))
+ (consumer res))))))
+
+;;; list utilities
+
+(define (every pred lst)
+ (or (atom? lst)
+ (and (pred (car lst))
+ (every pred (cdr lst)))))
+
+(define (any pred lst)
+ (and (cons? lst)
+ (or (pred (car lst))
+ (any pred (cdr lst)))))
+
+(define (list? a) (or (null? a) (and (cons? a) (list? (cdr a)))))
+
+(define (list-tail lst n)
+ (if (<= n 0) lst
+ (list-tail (cdr lst) (- n 1))))
+
+(define (list-head lst n)
+ (if (<= n 0) ()
+ (cons (car lst)
+ (list-head (cdr lst) (- n 1)))))
+
+(define (list-ref lst n)
+ (car (list-tail lst n)))
+
+(define (length= lst n)
+ "Bounded length test.
+Use this instead of (= (length lst) n), since it avoids unnecessary
+work and always terminates."
+ (cond ((< n 0) #f)
+ ((= n 0) (atom? lst))
+ ((atom? lst) (= n 0))
+ (else (length= (cdr lst) (- n 1)))))
+
+(define (length> lst n)
+ (cond ((< n 0) lst)
+ ((= n 0) (and (cons? lst) lst))
+ ((atom? lst) (< n 0))
+ (else (length> (cdr lst) (- n 1)))))
+
+(define (last-pair l)
+ (if (atom? (cdr l))
+ l
+ (last-pair (cdr l))))
+
+(define (lastcdr l)
+ (if (atom? l)
+ l
+ (cdr (last-pair l))))
+
+(define (to-proper l)
+ (cond ((null? l) l)
+ ((atom? l) (list l))
+ (else (cons (car l) (to-proper (cdr l))))))
+
+(define (map! f lst)
+ (prog1 lst
+ (while (cons? lst)
+ (set-car! lst (f (car lst)))
+ (set! lst (cdr lst)))))
+
+(define (filter pred lst)
+ (define (filter- f lst acc)
+ (cdr
+ (prog1 acc
+ (while (cons? lst)
+ (when (pred (car lst))
+ (set! acc
+ (cdr (set-cdr! acc (cons (car lst) ())))))
+ (set! lst (cdr lst))))))
+ (filter- pred lst (list ())))
+
+(define (partition pred lst)
+ (define (partition- pred lst yes no)
+ (let ((vals
+ (prog1
+ (cons yes no)
+ (while (cons? lst)
+ (if (pred (car lst))
+ (set! yes (cdr (set-cdr! yes (cons (car lst) ()))))
+ (set! no (cdr (set-cdr! no (cons (car lst) ())))))
+ (set! lst (cdr lst))))))
+ (values (cdr (car vals)) (cdr (cdr vals)))))
+ (partition- pred lst (list ()) (list ())))
+
+(define (count f l)
+ (define (count- f l n)
+ (if (null? l)
+ n
+ (count- f (cdr l) (if (f (car l))
+ (+ n 1)
+ n))))
+ (count- f l 0))
+
+(define (nestlist f zero n)
+ (if (<= n 0) ()
+ (cons zero (nestlist f (f zero) (- n 1)))))
+
+(define (foldr f zero lst)
+ (if (null? lst) zero
+ (f (car lst) (foldr f zero (cdr lst)))))
+
+(define (foldl f zero lst)
+ (if (null? lst) zero
+ (foldl f (f (car lst) zero) (cdr lst))))
+
+(define (reverse- zero lst)
+ (if (null? lst) zero
+ (reverse- (cons (car lst) zero) (cdr lst))))
+
+(define (reverse lst) (reverse- () lst))
+
+(define (reverse!- prev l)
+ (while (cons? l)
+ (set! l (prog1 (cdr l)
+ (set-cdr! l (prog1 prev
+ (set! prev l))))))
+ prev)
+
+(define (reverse! l) (reverse!- () l))
+
+(define (copy-tree l)
+ (if (atom? l) l
+ (cons (copy-tree (car l))
+ (copy-tree (cdr l)))))
+
+(define (delete-duplicates lst)
+ (if (length> lst 20)
+ (let ((t (table)))
+ (let loop ((l lst) (acc '()))
+ (if (atom? l)
+ (reverse! acc)
+ (if (has? t (car l))
+ (loop (cdr l) acc)
+ (begin
+ (put! t (car l) #t)
+ (loop (cdr l) (cons (car l) acc)))))))
+ (if (atom? lst)
+ lst
+ (let ((elt (car lst))
+ (tail (cdr lst)))
+ (if (member elt tail)
+ (delete-duplicates tail)
+ (cons elt
+ (delete-duplicates tail)))))))
+
+;;; backquote
+
+(define (revappend l1 l2) (reverse- l2 l1))
+(define (nreconc l1 l2) (reverse!- l2 l1))
+
+(define (self-evaluating? x)
+ (or (and (atom? x)
+ (not (symbol? x)))
+ (and (constant? x)
+ (symbol? x)
+ (eq? x (top-level-value x)))))
+
+(define-macro (quasiquote x) (bq-process x 0))
+
+(define (splice-form? x)
+ (or (and (cons? x) (or (eq? (car x) 'unquote-splicing)
+ (eq? (car x) 'unquote-nsplicing)
+ (and (eq? (car x) 'unquote)
+ (length> x 2))))
+ (eq? x 'unquote)))
+
+;; bracket without splicing
+(define (bq-bracket1 x d)
+ (if (and (cons? x) (eq? (car x) 'unquote))
+ (if (= d 0)
+ (cadr x)
+ (list cons ''unquote
+ (bq-process (cdr x) (- d 1))))
+ (bq-process x d)))
+
+(define (bq-bracket x d)
+ (cond ((atom? x) (list list (bq-process x d)))
+ ((eq? (car x) 'unquote)
+ (if (= d 0)
+ (cons list (cdr x))
+ (list list (list cons ''unquote
+ (bq-process (cdr x) (- d 1))))))
+ ((eq? (car x) 'unquote-splicing)
+ (if (= d 0)
+ (list 'copy-list (cadr x))
+ (list list (list list ''unquote-splicing
+ (bq-process (cadr x) (- d 1))))))
+ ((eq? (car x) 'unquote-nsplicing)
+ (if (= d 0)
+ (cadr x)
+ (list list (list list ''unquote-nsplicing
+ (bq-process (cadr x) (- d 1))))))
+ (else (list list (bq-process x d)))))
+
+(define (bq-process x d)
+ (cond ((symbol? x) (list 'quote x))
+ ((vector? x)
+ (let ((body (bq-process (vector->list x) d)))
+ (if (eq? (car body) list)
+ (cons vector (cdr body))
+ (list apply vector body))))
+ ((atom? x) x)
+ ((eq? (car x) 'quasiquote)
+ (list list ''quasiquote (bq-process (cadr x) (+ d 1))))
+ ((eq? (car x) 'unquote)
+ (if (and (= d 0) (length= x 2))
+ (cadr x)
+ (list cons ''unquote (bq-process (cdr x) (- d 1)))))
+ ((not (any splice-form? x))
+ (let ((lc (lastcdr x))
+ (forms (map (λ (x) (bq-bracket1 x d)) x)))
+ (if (null? lc)
+ (cons list forms)
+ (if (null? (cdr forms))
+ (list cons (car forms) (bq-process lc d))
+ (nconc (cons list* forms) (list (bq-process lc d)))))))
+ (else
+ (let loop ((p x) (q ()))
+ (cond ((null? p) ;; proper list
+ (cons 'nconc (reverse! q)))
+ ((cons? p)
+ (cond ((eq? (car p) 'unquote)
+ ;; (... . ,x)
+ (cons 'nconc
+ (nreconc q
+ (if (= d 0)
+ (cdr p)
+ (list (list list ''unquote)
+ (bq-process (cdr p)
+ (- d 1)))))))
+ (else
+ (loop (cdr p) (cons (bq-bracket (car p) d) q)))))
+ (else
+ ;; (... . x)
+ (cons 'nconc (reverse! (cons (bq-process p d) q)))))))))
+
+;;; standard macros
+
+(define (quote-value v)
+ (if (self-evaluating? v)
+ v
+ (list 'quote v)))
+
+(define-macro (let* binds . body)
+ (if (atom? binds) `((λ () ,@body))
+ `((λ (,(caar binds))
+ ,@(if (cons? (cdr binds))
+ `((let* ,(cdr binds) ,@body))
+ body))
+ ,(cadar binds))))
+
+(define-macro (when c . body) (list 'if c (cons 'begin body) #f))
+(define-macro (unless c . body) (list 'if c #f (cons 'begin body)))
+
+(define-macro (case key . clauses)
+ (define (vals->cond key v)
+ (cond ((eq? v 'else) 'else)
+ ((null? v) #f)
+ ((symbol? v) `(eq? ,key ,(quote-value v)))
+ ((atom? v) `(eqv? ,key ,(quote-value v)))
+ ((null? (cdr v)) `(eqv? ,key ,(quote-value (car v))))
+ ((every symbol? v)
+ `(memq ,key ',v))
+ (else `(memv ,key ',v))))
+ (let ((g (gensym)))
+ `(let ((,g ,key))
+ (cond ,.(map (λ (clause)
+ (cons (vals->cond g (car clause))
+ (cdr clause)))
+ clauses)))))
+
+(define-macro (do vars test-spec . commands)
+ (let ((loop (gensym))
+ (test-expr (car test-spec))
+ (vars (map car vars))
+ (inits (map cadr vars))
+ (steps (map (λ (x)
+ (if (cons? (cddr x))
+ (caddr x)
+ (car x)))
+ vars)))
+ `(letrec ((,loop (λ ,vars
+ (if ,test-expr
+ (begin
+ ,@(cdr test-spec))
+ (begin
+ ,@commands
+ (,loop ,.steps))))))
+ (,loop ,.inits))))
+
+; SRFI 8
+(define-macro (receive formals expr . body)
+ `(call-with-values (λ () ,expr)
+ (λ ,formals ,@body)))
+
+(define-macro (dotimes var . body)
+ (let ((v (car var))
+ (cnt (cadr var)))
+ `(for 0 (- ,cnt 1)
+ (λ (,v) ,@body))))
+
+(define (map-int f n)
+ (if (<= n 0)
+ nil
+ (let ((first (cons (f 0) ()))
+ (acc ()))
+ (set! acc first)
+ (for 1 (1- n)
+ (λ (i) (set-cdr! acc (cons (f i) ()))
+ (set! acc (cdr acc))))
+ first)))
+
+(define (iota n) (map-int identity n))
+
+(define-macro (with-bindings binds . body)
+ (let ((vars (map car binds))
+ (vals (map cadr binds))
+ (olds (map (λ (x) (gensym)) binds)))
+ `(let ,(map list olds vars)
+ ,@(map (λ (v val) `(set! ,v ,val)) vars vals)
+ (unwind-protect
+ (begin ,@body)
+ (begin ,@(map (λ (v old) `(set! ,v ,old)) vars olds))))))
+
+;;; exceptions
+
+(define (error . args) (raise (cons 'error args)))
+
+(define-macro (throw tag value) `(raise (list 'thrown-value ,tag ,value)))
+(define-macro (catch tag expr)
+ (let ((e (gensym)))
+ `(trycatch ,expr
+ (λ (,e) (if (and (cons? ,e)
+ (eq? (car ,e) 'thrown-value)
+ (eq? (cadr ,e) ,tag))
+ (caddr ,e)
+ (raise ,e))))))
+
+(define-macro (unwind-protect expr finally)
+ (let ((e (gensym))
+ (thk (gensym)))
+ `(let ((,thk (λ () ,finally)))
+ (prog1 (trycatch ,expr
+ (λ (,e) (begin (,thk) (raise ,e))))
+ (,thk)))))
+
+;;; debugging utilities
+
+(define-macro (assert expr) `(if ,expr #t (raise '(assert-failed ,expr))))
+
+(define traced?
+ (letrec ((sample-traced-lambda (λ args (begin (write (cons 'x args))
+ (newline)
+ (apply #.apply args)))))
+ (λ (f)
+ (and (closure? f)
+ (equal? (function:code f)
+ (function:code sample-traced-lambda))))))
+
+(define (trace sym)
+ (let* ((func (top-level-value sym))
+ (args (gensym)))
+ (when (not (traced? func))
+ (set-top-level-value! sym
+ (eval
+ `(λ ,args
+ (begin (write (cons ',sym ,args))
+ (newline)
+ (apply ',func ,args)))))))
+ (void))
+
+(define (untrace sym)
+ (let ((func (top-level-value sym)))
+ (when (traced? func)
+ (set-top-level-value! sym
+ (aref (function:vals func) 3))))
+ (void))
+
+(define-macro (time expr)
+ (let ((t0 (gensym)))
+ `(let ((,t0 (time-now)))
+ (prog1
+ ,expr
+ (princ "Elapsed time: " (- (time-now) ,t0) " seconds" *linefeed*)))))
+
+;;; text I/O
+
+(define (print . args) (for-each write args))
+(define (princ . args)
+ (with-bindings ((*print-readably* #f))
+ (for-each write args)))
+
+(define (newline (port *output-stream*))
+ (io-write port *linefeed*)
+ (void))
+
+(define (io-readline s) (io-readuntil s #\linefeed))
+
+; call f on a stream until the stream runs out of data
+(define (read-all-of f s)
+ (let loop ((lines ())
+ (curr (f s)))
+ (if (io-eof? s)
+ (reverse! lines)
+ (loop (cons curr lines) (f s)))))
+
+(define (io-readlines s) (read-all-of io-readline s))
+(define (read-all s) (read-all-of read s))
+
+(define (io-readall s)
+ (let ((b (buffer)))
+ (io-copy b s)
+ (iostream->string b)))
+
+(define-macro (with-output-to stream . body)
+ `(with-bindings ((*output-stream* ,stream))
+ ,@body))
+(define-macro (with-input-from stream . body)
+ `(with-bindings ((*input-stream* ,stream))
+ ,@body))
+
+;;; vector functions
+
+(define (list->vector l) (apply vector l))
+(define (vector->list v)
+ (let ((n (length v))
+ (l ()))
+ (for 1 n
+ (λ (i)
+ (set! l (cons (aref v (- n i)) l))))
+ l))
+
+(define (vector-map f v)
+ (let* ((n (length v))
+ (nv (vector-alloc n)))
+ (for 0 (- n 1)
+ (λ (i)
+ (aset! nv i (f (aref v i)))))
+ nv))
+
+;;; table functions
+
+(define (table-pairs t)
+ (table-foldl (λ (k v z) (cons (cons k v) z))
+ () t))
+(define (table-keys t)
+ (table-foldl (λ (k v z) (cons k z))
+ () t))
+(define (table-values t)
+ (table-foldl (λ (k v z) (cons v z))
+ () t))
+(define (table-clone t)
+ (let ((nt (table)))
+ (table-foldl (λ (k v z) (put! nt k v))
+ () t)
+ nt))
+(define (table-invert t)
+ (let ((nt (table)))
+ (table-foldl (λ (k v z) (put! nt v k))
+ () t)
+ nt))
+
+;;; string functions
+
+(define (string-tail s n) (string-sub s n))
+
+(define (string-trim s at-start at-end)
+ (define (trim-start s chars i L)
+ (if (and (< i L) (string-find chars (string-char s i)))
+ (trim-start s chars (1+ i) L)
+ i))
+ (define (trim-end s chars i)
+ (if (and (> i 0) (string-find chars (string-char s (1- i))))
+ (trim-end s chars (1- i))
+ i))
+ (let ((L (string-length s)))
+ (string-sub s
+ (trim-start s at-start 0 L)
+ (trim-end s at-end L))))
+
+(define (string-map f s)
+ (let ((b (buffer))
+ (n (string-length s)))
+ (let ((i 0))
+ (while (< i n)
+ (begin (io-putc b (f (string-char s i)))
+ (set! i (1+ i)))))
+ (iostream->string b)))
+
+(define (string-rep s k)
+ (cond ((< k 4)
+ (cond ((<= k 0) "")
+ ((= k 1) (string s))
+ ((= k 2) (string s s))
+ (else (string s s s))))
+ ((odd? k) (string s (string-rep s (- k 1))))
+ (else (string-rep (string s s) (/ k 2)))))
+
+(define (string-lpad s n c) (string (string-rep c (- n (string-length s))) s))
+(define (string-rpad s n c) (string s (string-rep c (- n (string-length s)))))
+
+(define (print-to-string v)
+ (let ((b (buffer)))
+ (write v b)
+ (iostream->string b)))
+
+(define (string-join strlist sep)
+ (if (null? strlist) ""
+ (let ((b (buffer)))
+ (io-write b (car strlist))
+ (for-each (λ (s) (io-write b sep)
+ (io-write b s))
+ (cdr strlist))
+ (iostream->string b))))
+
+;;; toplevel
+
+(define (macrocall? e) (and (symbol? (car e))
+ (symbol-syntax (car e))))
+
+(define (macroexpand-1 e)
+ (if (atom? e) e
+ (let ((f (macrocall? e)))
+ (if f (apply f (cdr e))
+ e))))
+
+(define (expand e)
+ ; symbol resolves to toplevel; i.e. has no shadowing definition
+ (define (top? s env) (not (or (bound? s) (assq s env))))
+
+ (define (splice-begin body)
+ (cond ((atom? body) body)
+ ((equal? body '((begin)))
+ body)
+ ((and (cons? (car body))
+ (eq? (caar body) 'begin))
+ (append (splice-begin (cdar body)) (splice-begin (cdr body))))
+ (else
+ (cons (car body) (splice-begin (cdr body))))))
+
+ (define *expanded* (list '*expanded*))
+
+ (define (expand-body body env)
+ (if (atom? body) body
+ (let* ((body (if (top? 'begin env)
+ (splice-begin body)
+ body))
+ (def? (top? 'define env))
+ (dvars (if def? (get-defined-vars body) ()))
+ (env (nconc (map list dvars) env)))
+ (if (not def?)
+ (map (λ (x) (expand-in x env)) body)
+ (let* ((ex-nondefs ; expand non-definitions
+ (let loop ((body body))
+ (cond ((atom? body) body)
+ ((and (cons? (car body))
+ (eq? 'define (caar body)))
+ (cons (car body) (loop (cdr body))))
+ (else
+ (let ((form (expand-in (car body) env)))
+ (set! env (nconc
+ (map list (get-defined-vars form))
+ env))
+ (cons
+ (cons *expanded* form)
+ (loop (cdr body))))))))
+ (body ex-nondefs))
+ (while (cons? body) ; now expand deferred definitions
+ (if (not (eq? *expanded* (caar body)))
+ (set-car! body (expand-in (car body) env))
+ (set-car! body (cdar body)))
+ (set! body (cdr body)))
+ ex-nondefs)))))
+
+ (define (expand-lambda-list l env)
+ (if (atom? l) l
+ (cons (if (and (cons? (car l)) (cons? (cdr (car l))))
+ (list (caar l) (expand-in (cadar l) env))
+ (car l))
+ (expand-lambda-list (cdr l) env))))
+
+ (define (l-vars l)
+ (cond ((atom? l) (list l))
+ ((cons? (car l)) (cons (caar l) (l-vars (cdr l))))
+ (else (cons (car l) (l-vars (cdr l))))))
+
+ (define (expand-lambda e env)
+ (let ((formals (cadr e))
+ (name (lastcdr e))
+ (body (cddr e))
+ (vars (l-vars (cadr e))))
+ (let ((env (nconc (map list vars) env)))
+ `(λ ,(expand-lambda-list formals env)
+ ,.(expand-body body env)
+ . ,name))))
+
+ (define (expand-define e env)
+ (if (or (null? (cdr e)) (atom? (cadr e)))
+ (if (null? (cddr e))
+ e
+ (let ((name (cadr e))
+ (doc (value-get-doc (cddr e))))
+ (when doc
+ (set! e (cdr e))
+ (symbol-set-doc name doc))
+ `(define ,name ,(expand-in (caddr e) env))))
+ (let* ((formals (cdadr e))
+ (name (caadr e))
+ (body (cddr e))
+ (doc (value-get-doc body))
+ (vars (l-vars formals))
+ (menv (nconc (map list vars) env)))
+ (when doc
+ (set! body (cdr body))
+ (symbol-set-doc name doc formals))
+ `(define ,(cons name (expand-lambda-list formals menv))
+ ,.(expand-body body menv)))))
+
+ (define (expand-let-syntax e env)
+ (let ((binds (cadr e)))
+ (cons 'begin
+ (expand-body (cddr e)
+ (nconc
+ (map (λ (bind)
+ (list (car bind)
+ ((compile-thunk
+ (expand-in (cadr bind) env)))
+ env))
+ binds)
+ env)))))
+
+ ; given let-syntax definition environment (menv) and environment
+ ; at the point of the macro use (lenv), return the environment to
+ ; expand the macro use in. TODO
+ (define (local-expansion-env menv lenv) menv)
+
+ (define (expand-in e env)
+ (if (atom? e) e
+ (let* ((head (car e))
+ (bnd (assq head env))
+ (default (λ ()
+ (let loop ((e e))
+ (if (atom? e) e
+ (cons (if (atom? (car e))
+ (car e)
+ (expand-in (car e) env))
+ (loop (cdr e))))))))
+ (cond ((and bnd (cons? (cdr bnd))) ; local macro
+ (expand-in (apply (cadr bnd) (cdr e))
+ (local-expansion-env (caddr bnd) env)))
+ ((macrocall? e) => (λ (f)
+ (expand-in (apply f (cdr e)) env)))
+ ((or bnd ; bound lexical or toplevel var
+ (not (symbol? head))
+ (bound? head))
+ (default))
+ ((eq? head 'quote) e)
+ ((eq? head 'λ) (expand-lambda e env))
+ ((eq? head 'lambda) (expand-lambda e env))
+ ((eq? head 'define) (expand-define e env))
+ ((eq? head 'let-syntax) (expand-let-syntax e env))
+ (else (default))))))
+ (expand-in e ()))
+
+(define (eval x) ((compile-thunk (expand x))))
+
+(define (load-process x) (eval x))
+
+(define (load filename)
+ (let ((F (file filename :read)))
+ (trycatch
+ (let next (prev E v)
+ (if (not (io-eof? F))
+ (next (read F)
+ prev
+ (begin (load-process E) (void)))
+ (begin (io-close F)
+ ; evaluate last form in almost-tail position
+ (void (load-process E)))))
+ (λ (e)
+ (io-close F)
+ (raise `(load-error ,filename ,e))))))
+
+(define (repl)
+ (define (prompt)
+ (*prompt*)
+ (io-flush *output-stream*)
+ (let ((v (trycatch (read)
+ (λ (e) (io-discardbuffer *input-stream*)
+ (raise e)))))
+ (and (not (io-eof? *input-stream*))
+ (let ((V (load-process v)))
+ (unless (void? V) (print V) (newline))
+ (void (set! that V))))))
+ (define (reploop)
+ (when (trycatch (prompt)
+ (λ (e)
+ (top-level-exception-handler e)
+ #t))
+ (reploop)))
+ (reploop)
+ (newline))
+
+(define (top-level-exception-handler e)
+ (with-output-to *stderr*
+ (print-exception e)
+ (print-stack-trace (stacktrace))))
+
+(define (print-stack-trace st)
+ (define (find-in-f f tgt path)
+ (let ((path (cons (function:name f) path)))
+ (if (eq? (function:code f) (function:code tgt))
+ (throw 'ffound path)
+ (let ((v (function:vals f)))
+ (for 0 (1- (length v))
+ (λ (i) (when (closure? (aref v i))
+ (find-in-f (aref v i) tgt path))))))))
+ (define (fn-name f e)
+ (let ((p (catch 'ffound
+ (begin
+ (for-each (λ (topfun)
+ (find-in-f topfun f ()))
+ e)
+ #f))))
+ (if p
+ (string-join (map string (reverse! p)) "/")
+ "λ")))
+ (let ((st (reverse! (if (length> st 3)
+ (list-tail st (if *interactive* 5 4))
+ st)))
+ (e (filter closure? (map (λ (s) (and (bound? s)
+ (top-level-value s)))
+ (environment))))
+ (n 0))
+ (for-each
+ (λ (f)
+ (princ "(" (fn-name (aref f 1) e))+ (for-each (λ (p) (princ " ") (print p))
+ (cdr (cdr (vector->list f))))
+ (princ ")" *linefeed*)
+ (when (= n 0)
+ (disassemble (aref f 1) (aref f 0)))
+ (set! n (+ n 1)))
+ st)))
+
+(define (print-exception e)
+ (cond ((and (cons? e)
+ (eq? (car e) 'type-error)
+ (length= e 3))
+ (princ "type error: expected " (cadr e) ", got " (typeof (caddr e)) ": ")
+ (print (caddr e)))
+
+ ((and (cons? e)
+ (eq? (car e) 'bounds-error)
+ (length= e 3))
+ (princ "index " (caddr e) " out of bounds for ")
+ (print (cadr e)))
+
+ ((and (cons? e)
+ (eq? (car e) 'unbound-error)
+ (length= e 2))
+ (princ "eval: variable " (cadr e) " has no value"))
+
+ ((and (cons? e)
+ (eq? (car e) 'error))
+ (princ "error: ")
+ (apply princ (cdr e)))
+
+ ((and (cons? e)
+ (eq? (car e) 'load-error))
+ (print-exception (caddr e))
+ (princ "in file " (cadr e)))
+
+ ((and (list? e)
+ (length= e 2))
+ (print (car e))
+ (princ ": ")
+ (let ((msg (cadr e)))
+ ((if (or (string? msg) (symbol? msg))
+ princ print)
+ msg)))
+
+ (else (princ "*** Unhandled exception: ")
+ (print e)))
+
+ (princ *linefeed*))
+
+(define (simple-sort l)
+ (if (or (null? l) (null? (cdr l))) l
+ (let ((piv (car l)))
+ (receive (less grtr)
+ (partition (λ (x) (< x piv)) (cdr l))
+ (nconc (simple-sort less)
+ (list piv)
+ (simple-sort grtr))))))
+
+(define (make-system-image fname)
+ (let ((f (file fname :write :create :truncate))
+ (z (file (string fname ".builtin") :write :create :truncate))
+ (b (buffer))
+ (excludes '(*linefeed* *directory-separator* *argv* that
+ *print-pretty* *print-width* *print-readably*
+ *print-level* *print-length* *os-name* *interactive*
+ *prompt* *os-version*)))
+ (with-bindings ((*print-pretty* #t)
+ (*print-readably* #t))
+ (let* ((syms
+ (filter (λ (s)
+ (and (bound? s)
+ (not (constant? s))
+ (or (not (builtin? (top-level-value s)))
+ (not (equal? (string s) ; alias of builtin
+ (string (top-level-value s)))))
+ (not (memq s excludes))
+ (not (iostream? (top-level-value s)))))
+ (simple-sort (environment))))
+ (data (apply nconc (map list syms (map top-level-value syms)))))
+ (write data b)
+ (write data f)
+ (io-write f *linefeed*))
+ (let* ((size (sizeof b))
+ (packed (lz-pack (iostream->string b) 10))
+ (hdr (array 'byte 0
+ (logand 0xff size)
+ (ash size -8)
+ (ash size -16)
+ (ash size -24))))
+ (io-write z hdr)
+ (io-write z packed))
+ (io-close f)
+ (io-close z))))
+
+; initialize globals that need to be set at load time
+(define (__init_globals)
+ (let ((defprompt (if (equal? *os-name* "macos")
+ (λ () (princ "\x1b[0m\x1b[1m#;> \x1b[0m"))
+ (λ () (princ "#;> ")))))
+ (set! *prompt*
+ "Function called by REPL to signal the user input is required.
+Default function prints \"#;> \"." defprompt))
+ (set! *directory-separator* (or (and (equal? *os-name* "dos") "\\") "/"))
+ (set! *linefeed* "\n")
+ (set! *output-stream* *stdout*)
+ (set! *input-stream* *stdin*)
+ (set! *error-stream* *stderr*))
+
+(define (__script fname)
+ (trycatch (load fname)
+ (λ (e) (begin (top-level-exception-handler e)
+ (exit 1)))))
+
+(define (__rcscript)
+ (let* ((homevar (case *os-name*
+ (("unknown") #f)+ (("plan9") "home")+ (("macos") (princ "\x1b]0;femtolisp v0.999\007") #f)+ (else "HOME")))
+ (home (and homevar (os-getenv homevar)))
+ (fname (and home (string home *directory-separator* ".flisprc"))))
+ (when (and fname (path-exists? fname)) (load fname))))
+
+(define (__start argv)
+ (__init_globals)
+ (if (cons? (cdr argv))
+ (begin (set! *argv* (cdr argv))
+ (set! *interactive* #f)
+ (__script (cadr argv)))
+ (begin (set! *argv* argv)
+ (set! *interactive* #t)
+ (__rcscript)
+ (repl)))
+ (exit 0))
--- /dev/null
+++ b/src/table.c
@@ -1,0 +1,208 @@
+#include "flisp.h"
+#include "equalhash.h"
+#include "cvalues.h"
+#include "types.h"
+#include "print.h"
+#include "table.h"
+
+#define inline_space sizeof(((htable_t*)nil)->_space)
+
+static void
+print_htable(value_t v, ios_t *f)
+{+ htable_t *h = cvalue_data(v);
+ size_t i;
+ int first = 1;
+ fl_print_str(f, "#table(");+ for(i = 0; i < h->size; i += 2){+ if(h->table[i+1] != HT_NOTFOUND){+ if(!first)
+ fl_print_str(f, " ");
+ fl_print_child(f, (value_t)h->table[i]);
+ fl_print_chr(f, ' ');
+ fl_print_child(f, (value_t)h->table[i+1]);
+ first = 0;
+ }
+ }
+ fl_print_chr(f, ')');
+}
+
+static void
+print_traverse_htable(value_t self)
+{+ htable_t *h = cvalue_data(self);
+ size_t i;
+ for(i = 0; i < h->size; i += 2){+ if(h->table[i+1] != HT_NOTFOUND){+ print_traverse((value_t)h->table[i]);
+ print_traverse((value_t)h->table[i+1]);
+ }
+ }
+}
+
+static void
+free_htable(value_t self)
+{+ htable_t *h = cvalue_data(self);
+ htable_free(h);
+}
+
+static void
+relocate_htable(value_t oldv, value_t newv)
+{+ htable_t *oldh = cvalue_data(oldv);
+ htable_t *h = cvalue_data(newv);
+ if(oldh->table == &oldh->_space[0])
+ h->table = &h->_space[0];
+ h->i = oldh->i;
+ for(size_t i = 0; i < h->size; i++){+ if(h->table[i] != HT_NOTFOUND)
+ h->table[i] = (void*)relocate((value_t)h->table[i]);
+ }
+}
+
+static cvtable_t table_vtable = {+ print_htable,
+ relocate_htable,
+ free_htable,
+ print_traverse_htable,
+};
+
+bool
+ishashtable(value_t v)
+{+ return iscvalue(v) && cv_class(ptr(v)) == FL(tabletype);
+}
+
+fl_purefn
+BUILTIN("table?", tablep)+{+ argcount(nargs, 1);
+ return ishashtable(args[0]) ? FL_t : FL_f;
+}
+
+htable_t *
+totable(value_t v)
+{+ if(!ishashtable(v))
+ type_error("table", v);+ return cvalue_data(v);
+}
+
+BUILTIN("table", table)+{+ size_t cnt = (size_t)nargs;
+ if(cnt & 1)
+ lerrorf(FL_ArgError, "arguments must come in pairs");
+ value_t nt;
+ // prevent small tables from being added to finalizer list
+ if(cnt <= HT_N_INLINE)
+ nt = cvalue_nofinalizer(FL(tabletype), sizeof(htable_t));
+ else
+ nt = cvalue(FL(tabletype), sizeof(htable_t)-inline_space);
+ htable_t *h = cvalue_data(nt);
+ htable_new(h, cnt/2);
+ size_t i;
+ value_t k = FL_nil, arg;
+ FOR_ARGS(i, 0, arg, args){+ if(i & 1)
+ equalhash_put(h, (void*)k, (void*)arg);
+ else
+ k = arg;
+ }
+ if(h->table != &h->_space[0] && cnt <= HT_N_INLINE){+ cvalue_t *cv = ptr(nt);
+ add_finalizer(cv);
+ cv->len = sizeof(htable_t) - inline_space;
+ }
+ return nt;
+}
+
+// (put! table key value)
+BUILTIN("put!", put)+{+ argcount(nargs, 3);
+ htable_t *h = totable(args[0]);
+ void **table0 = h->table;
+ equalhash_put(h, (void*)args[1], (void*)args[2]);
+ // register finalizer if we outgrew inline space
+ if(table0 == &h->_space[0] && h->table != &h->_space[0]){+ cvalue_t *cv = ptr(args[0]);
+ add_finalizer(cv);
+ cv->len = sizeof(htable_t) - inline_space;
+ }
+ return args[0];
+}
+
+_Noreturn
+static void
+key_error(value_t key)
+{+ lerrorf(fl_list2(FL_KeyError, key), "key not found");
+}
+
+// (get table key [default])
+fl_purefn
+BUILTIN("get", get)+{+ if(nargs != 3)
+ argcount(nargs, 2);
+ htable_t *h = totable(args[0]);
+ value_t v = (value_t)equalhash_get(h, (void*)args[1]);
+ if(v == (value_t)HT_NOTFOUND){+ if(nargs == 3)
+ return args[2];
+ key_error(args[1]);
+ }
+ return v;
+}
+
+// (has? table key)
+fl_purefn
+BUILTIN("has?", has)+{+ argcount(nargs, 2);
+ htable_t *h = totable(args[0]);
+ return equalhash_has(h, (void*)args[1]) ? FL_t : FL_f;
+}
+
+// (del! table key)
+BUILTIN("del!", del)+{+ argcount(nargs, 2);
+ htable_t *h = totable(args[0]);
+ if(!equalhash_remove(h, (void*)args[1]))
+ key_error(args[1]);
+ return args[0];
+}
+
+BUILTIN("table-foldl", table_foldl)+{+ argcount(nargs, 3);
+ value_t f = args[0], zero = args[1], t = args[2];
+ htable_t *h = totable(t);
+ size_t n = h->size;
+ void **table = h->table;
+ fl_gc_handle(&f);
+ fl_gc_handle(&zero);
+ fl_gc_handle(&t);
+ for(size_t i = 0; i < n; i += 2){+ if(table[i+1] != HT_NOTFOUND){+ zero = fl_applyn(3, f, (value_t)table[i], (value_t)table[i+1], zero);
+ // reload pointer
+ h = cvalue_data(t);
+ if(h->size != n)
+ lerrorf(FL_EnumerationError, "table modified");
+ table = h->table;
+ }
+ }
+ fl_free_gc_handles(3);
+ return zero;
+}
+
+void
+table_init(void)
+{+ FL_tablesym = symbol("table", false);+ FL(tabletype) = define_opaque_type(FL_tablesym, sizeof(htable_t), &table_vtable, nil);
+}
--- /dev/null
+++ b/src/table.h
@@ -1,0 +1,3 @@
+bool ishashtable(value_t v) fl_purefn;
+htable_t *totable(value_t v) fl_purefn;
+void table_init(void);
--- /dev/null
+++ b/src/timefuncs.h
@@ -1,0 +1,7 @@
+#pragma once
+
+double sec_realtime(void);
+uint64_t nanosec_monotonic(void);
+void timestring(double s, char *buf, int sz);
+double parsetime(const char *s);
+void sleep_ms(int ms);
--- /dev/null
+++ b/src/types.c
@@ -1,0 +1,94 @@
+#include "flisp.h"
+#include "cvalues.h"
+#include "equalhash.h"
+#include "types.h"
+
+fltype_t *
+get_type(value_t t)
+{+ fltype_t *ft;
+ if(issymbol(t)){+ ft = ((symbol_t*)ptr(t))->type;
+ if(ft != nil)
+ return ft;
+ }
+ void **bp = equalhash_bp(&FL(TypeTable), (void*)t);
+ if(*bp != HT_NOTFOUND){+ assert(*bp != nil);
+ return *bp;
+ }
+
+ bool isarray = iscons(t) && car_(t) == FL_arraysym && iscons(cdr_(t));
+ size_t sz;
+ if(isarray && !iscons(cdr_(cdr_(t)))){+ // special case: incomplete array type
+ sz = 0;
+ }else{+ sz = ctype_sizeof(t);
+ }
+
+ ft = MEM_CALLOC(1, sizeof(fltype_t));
+ assert(ft != nil);
+ ft->type = t;
+ ft->numtype = NONNUMERIC;
+ if(issymbol(t)){+ ft->numtype = sym_to_numtype(t);
+ assert(valid_numtype(ft->numtype));
+ ((symbol_t*)ptr(t))->type = ft;
+ }
+ ft->size = sz;
+ if(iscons(t)){+ if(isarray){+ fltype_t *eltype = get_type(car_(cdr_(t)));
+ assert(eltype != nil);
+ if(eltype->size == 0){+ MEM_FREE(ft);
+ lerrorf(FL_ArgError, "invalid array element type");
+ }
+ ft->elsz = eltype->size;
+ ft->eltype = eltype;
+ ft->init = cvalue_array_init;
+ //eltype->artype = ft; -- this is a bad idea since some types carry array sizes
+ }
+ }
+ *bp = ft;
+ return ft;
+}
+
+fltype_t *
+get_array_type(value_t eltype)
+{+ fltype_t *et = get_type(eltype);
+ if(et->artype == nil)
+ et->artype = get_type(fl_list2(FL_arraysym, eltype));
+ return et->artype;
+}
+
+fltype_t *
+define_opaque_type(value_t sym, size_t sz, cvtable_t *vtab, cvinitfunc_t init)
+{+ fltype_t *ft = MEM_CALLOC(1, sizeof(fltype_t));
+ assert(ft != nil);
+ ft->type = sym;
+ ft->numtype = NONNUMERIC;
+ ft->size = sz;
+ ft->vtable = vtab;
+ ft->init = init;
+ return ft;
+}
+
+void
+relocate_typetable(void)
+{+ htable_t *h = &FL(TypeTable);
+ size_t i;
+ void *nv;
+ for(i = 0; i < h->size; i += 2){+ if(h->table[i] != HT_NOTFOUND){+ nv = (void*)relocate((value_t)h->table[i]);
+ h->table[i] = nv;
+ if(h->table[i+1] != HT_NOTFOUND)
+ ((fltype_t*)h->table[i+1])->type = (value_t)nv;
+ }
+ }
+}
--- /dev/null
+++ b/src/types.h
@@ -1,0 +1,6 @@
+#pragma once
+
+fltype_t *get_type(value_t t);
+fltype_t *get_array_type(value_t eltype);
+fltype_t *define_opaque_type(value_t sym, size_t sz, cvtable_t *vtab, cvinitfunc_t init);
+void relocate_typetable(void);
--- /dev/null
+++ b/src/utf8.c
@@ -1,0 +1,319 @@
+/*
+ Basic UTF-8 manipulation routines
+ by Jeff Bezanson
+ placed in the public domain Fall 2005
+
+ This code is designed to provide the utilities you need to manipulate
+ UTF-8 as an internal string encoding. These functions do not perform the
+ error checking normally needed when handling UTF-8 data, so if you happen
+ to be from the Unicode Consortium you will want to flay me alive.
+ I do this because error checking can be performed at the boundaries (I/O),
+ with these routines reserved for higher performance on data known to be
+ valid.
+ A UTF-8 validation routine is included.
+*/
+
+#include "flisp.h"
+
+static const uint32_t offsetsFromUTF8[6] = {+ 0x00000000U, 0x00003080U, 0x000E2080U,
+ 0x03C82080U, 0xFA082080U, 0x82082080U
+};
+
+static const char trailingBytesForUTF8[256] = {+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+ 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 3,3,3,3,3,3,3,3,4,4,4,4,5,5,5,5
+};
+
+// straight from musl
+int
+u8_iswprint(Rune c)
+{+ if(c < 0xff)
+ return ((c+1) & 0x7f) >= 0x21;
+ if(c < 0x2028 || c-0x202a < 0xd800-0x202a || c-0xe000 < 0xfff9-0xe000)
+ return 1;
+ return !(c-0xfffc > Runemax-0xfffc || (c&0xfffe) == 0xfffe);
+}
+
+/* returns length of next utf-8 sequence */
+size_t
+u8_seqlen(const char *s)
+{+ return trailingBytesForUTF8[(uint8_t)s[0]] + 1;
+}
+
+/* byte offset => charnum */
+size_t
+u8_charnum(const char *s, size_t offset)
+{+ size_t charnum = 0, i = 0;
+
+ while(i < offset){+ if((s[i++] & 0x80) != 0 && !isutf(s[++i]) && !isutf(s[++i]))
+ i++;
+ charnum++;
+ }
+ return charnum;
+}
+
+size_t
+u8_strwidth(const char *s)
+{+ size_t i, w;
+ Rune r;
+
+ for(i = w = 0; s[i];){+ i += chartorune(&r, s+i);
+ w += wcwidth(r);
+ }
+ return w;
+}
+
+/* next character without NUL character terminator */
+Rune
+u8_nextmemchar(const char *s, size_t *i)
+{+ size_t sz = trailingBytesForUTF8[(uint8_t)s[*i]];
+ Rune ch = 0;
+ for(size_t j = 0; j <= sz; j++){+ ch <<= 6;
+ ch += (uint8_t)s[(*i)++];
+ };
+ return ch - offsetsFromUTF8[sz];
+}
+
+bool
+octal_digit(char c)
+{+ return c >= '0' && c <= '7';
+}
+
+bool
+hex_digit(char c)
+{+ return (c >= '0' && c <= '9') || (c >= 'a' && c <= 'f') || (c >= 'A' && c <= 'F');
+}
+
+char
+read_escape_control_char(char c)
+{+ switch(c){+ case 'n': return '\n';
+ case 't': return '\t';
+ case 'a': return '\a';
+ case 'b': return '\b';
+ case 'e': return 0x1b;
+ case 'f': return '\f';
+ case 'r': return '\r';
+ case 'v': return '\v';
+ }
+ return c;
+}
+
+static inline int
+buf_put2c(char *buf, const char *src)
+{+ buf[0] = src[0];
+ buf[1] = src[1];
+ buf[2] = '\0';
+ return 2;
+}
+
+int
+u8_escape_rune(char *buf, size_t sz, Rune ch)
+{+ assert(sz > 12);
+ if(ch >= 0x20 && ch < 0x7f){+ buf[0] = ch;
+ buf[1] = '\0';
+ return 1;
+ }
+ if(ch > 0xffff)
+ return snprintf(buf, sz, "\\U%.8"PRIx32, ch);
+ if(ch >= Runeself)
+ return snprintf(buf, sz, "\\u%04"PRIx32, ch);
+ switch(ch){+ case '\n': return buf_put2c(buf, "\\n");
+ case '\t': return buf_put2c(buf, "\\t");
+ case '\\': return buf_put2c(buf, "\\\\");
+ case '\a': return buf_put2c(buf, "\\a");
+ case '\b': return buf_put2c(buf, "\\b");
+ case 0x1b: return buf_put2c(buf, "\\e");
+ case '\f': return buf_put2c(buf, "\\f");
+ case '\r': return buf_put2c(buf, "\\r");
+ case '\v': return buf_put2c(buf, "\\v");
+ }
+ return snprintf(buf, sz, "\\x%02"PRIx32, ch);
+}
+
+size_t
+u8_escape(char *buf, size_t sz, const char *src, size_t *pi, size_t end, bool escape_quotes, bool ascii)
+{+ size_t i = *pi, i0;
+ Rune ch;
+ char *start = buf;
+ char *blim = start + sz-11;
+ assert(sz > 11);
+
+ while(i < end && buf < blim){+ // sz-11: leaves room for longest escape sequence
+ if(escape_quotes && src[i] == '"'){+ buf += buf_put2c(buf, "\\\"");
+ i++;
+ }else if(src[i] == '\\'){+ buf += buf_put2c(buf, "\\\\");
+ i++;
+ }else{+ i0 = i;
+ ch = u8_nextmemchar(src, &i);
+ if(ascii || !u8_iswprint(ch)){+ buf += u8_escape_rune(buf, sz - (buf-start), ch);
+ }else{+ i = i0;
+ do{+ *buf++ = src[i++];
+ }while(!isutf(src[i]));
+ }
+ }
+ }
+ *buf++ = '\0';
+ *pi = i;
+ return buf - start;
+}
+
+char *
+u8_memchr(char *s, Rune ch, size_t sz, size_t *charn)
+{+ size_t i = 0, lasti = 0;
+ Rune c;
+ int csz;
+
+ *charn = 0;
+ while(i < sz){+ c = csz = 0;
+ do{+ c <<= 6;
+ c += (uint8_t)s[i++];
+ csz++;
+ }while(i < sz && !isutf(s[i]));
+ c -= offsetsFromUTF8[csz-1];
+
+ if(c == ch)
+ return (char*)&s[lasti];
+ lasti = i;
+ (*charn)++;
+ }
+ return nil;
+}
+
+/* based on the valid_utf8 routine from the PCRE library by Philip Hazel
+
+ length is in bytes, since without knowing whether the string is valid
+ it's hard to know how many characters there are! */
+int
+u8_isvalid(const char *str, int length)
+{+ const uint8_t *p, *pend = (const uint8_t*)str + length;
+ uint8_t c;
+ int ab;
+
+ for(p = (const uint8_t*)str; p < pend; p++){+ c = *p;
+ if(c < 128)
+ continue;
+ if((c & 0xc0) != 0xc0)
+ return 0;
+ ab = trailingBytesForUTF8[c];
+ if(length < ab)
+ return 0;
+ length -= ab;
+
+ p++;
+ /* Check top bits in the second byte */
+ if((*p & 0xc0) != 0x80)
+ return 0;
+
+ /* Check for overlong sequences for each different length */
+ switch(ab){+ /* Check for xx00 000x */
+ case 1:
+ if((c & 0x3e) == 0)
+ return 0;
+ continue; /* We know there aren't any more bytes to check */
+
+ /* Check for 1110 0000, xx0x xxxx */
+ case 2:
+ if(c == 0xe0 && (*p & 0x20) == 0)
+ return 0;
+ break;
+
+ /* Check for 1111 0000, xx00 xxxx */
+ case 3:
+ if(c == 0xf0 && (*p & 0x30) == 0)
+ return 0;
+ break;
+
+ /* Check for 1111 1000, xx00 0xxx */
+ case 4:
+ if(c == 0xf8 && (*p & 0x38) == 0)
+ return 0;
+ break;
+
+ /* Check for leading 0xfe or 0xff and then for 1111 1100, xx00 00xx */
+ case 5:
+ if(c == 0xfe || c == 0xff || (c == 0xfc && (*p & 0x3c) == 0))
+ return 0;
+ break;
+ }
+
+ /* Check for valid bytes after the 2nd, if any; all must start 10 */
+ while(--ab > 0)
+ if((*(++p) & 0xc0) != 0x80)
+ return 0;
+ }
+
+ return 1;
+}
+
+int
+u8_reverse(char *dest, char *src, size_t len)
+{+ size_t si, di;
+
+ dest[di = len] = '\0';
+ for(si = 0; si < len;){+ switch((uint8_t)src[si]>>4){+ case 0xf:
+ di -= 4;
+ dest[di+0] = src[si++];
+ dest[di+1] = src[si++];
+ dest[di+2] = src[si++];
+ dest[di+3] = src[si++];
+ break;
+ case 0xe:
+ di -= 3;
+ dest[di+0] = src[si++];
+ dest[di+1] = src[si++];
+ dest[di+2] = src[si++];
+ break;
+ case 0xd:
+ case 0xc:
+ di -= 2;
+ dest[di+0] = src[si++];
+ dest[di+1] = src[si++];
+ break;
+ default:
+ di--;
+ dest[di+0] = src[si++];
+ break;
+ }
+ }
+ return 0;
+}
--- /dev/null
+++ b/src/utf8.h
@@ -1,0 +1,58 @@
+#pragma once
+
+/* is c the start of a utf8 sequence? */
+#define isutf(c) (((c)&0xC0) != 0x80)
+
+int u8_iswprint(Rune c) fl_constfn;
+
+/* byte offset to character number */
+size_t u8_charnum(const char *s, size_t offset) fl_purefn;
+
+/* next character without NUL character terminator */
+Rune u8_nextmemchar(const char *s, size_t *i);
+
+/* returns length of next utf-8 sequence */
+size_t u8_seqlen(const char *s) fl_purefn;
+
+char read_escape_control_char(char c) fl_constfn;
+
+/* given a wide character, convert it to an ASCII escape sequence stored in
+ buf, where buf is "sz" bytes. returns the number of characters output.
+ sz must be at least 3. */
+int u8_escape_rune(char *buf, size_t sz, Rune ch);
+
+/* convert UTF-8 "src" to escape sequences.
+
+ sz is buf size in bytes. must be at least 12.
+
+ if escape_quotes is nonzero, quote characters will be escaped.
+
+ if ascii is nonzero, the output is 7-bit ASCII, no UTF-8 survives.
+
+ starts at src[*pi], updates *pi to point to the first unprocessed
+ byte of the input.
+
+ end is one more than the last allowable value of *pi.
+
+ returns number of bytes placed in buf, including a NUL terminator.
+*/
+size_t u8_escape(char *buf, size_t sz, const char *src, size_t *pi, size_t end,
+ bool escape_quotes, bool ascii);
+
+/* utility predicates used by the above */
+bool octal_digit(char c) fl_constfn;
+bool hex_digit(char c) fl_constfn;
+
+/* same as the above, but searches a buffer of a given size instead of
+ a NUL-terminated string. */
+char *u8_memchr(char *s, Rune ch, size_t sz, size_t *charn);
+
+/* number of columns occupied by a string */
+size_t u8_strwidth(const char *s) fl_purefn;
+
+/* determine whether a sequence of bytes is valid UTF-8. length is in bytes */
+int u8_isvalid(const char *str, int length) fl_purefn;
+
+/* reverse a UTF-8 string. len is length in bytes. dest and src must both
+ be allocated to at least len+1 bytes. returns 1 for error, 0 otherwise */
+int u8_reverse(char *dest, char *src, size_t len);
--- /dev/null
+++ b/src/vm.inc
@@ -1,0 +1,938 @@
+OP(OP_LOADA0)
+ PUSH(FL(stack)[bp]);
+ NEXT_OP;
+
+OP(OP_LOADA1)
+ PUSH(FL(stack)[bp+1]);
+ NEXT_OP;
+
+OP(OP_LOADV)
+ v = fn_vals(FL(stack)[bp-1]);
+ assert(*ip < vector_size(v));
+ PUSH(vector_elt(v, *ip++));
+ NEXT_OP;
+
+OP(OP_BRF)
+ ip += POP() != FL_f ? 2 : GET_INT16(ip);
+ NEXT_OP;
+
+OP(OP_POP)
+ POPN(1);
+ NEXT_OP;
+
+OP(OP_TCALLL)
+ tail = true;
+ if(0){+OP(OP_CALLL)
+ tail = false;
+ }
+ n = GET_INT32(ip);
+ ip += 4;
+ if(0){+OP(OP_TCALL)
+ tail = true;
+ if(0){+OP(OP_CALL)
+ tail = false;
+ }
+ n = *ip++; // nargs
+ }
+LABEL(do_call):
+ FL(stack)[ipd] = (uintptr_t)ip;
+ func = FL(stack)[FL(sp)-n-1];
+ if(tag(func) == TAG_FUNCTION){+ if(func > (N_BUILTINS<<3)){+ if(tail){+ FL(curr_frame) = FL(stack)[FL(curr_frame)-3];
+ for(s = -1; s < (fixnum_t)n; s++)
+ FL(stack)[bp+s] = FL(stack)[FL(sp)-n+s];
+ FL(sp) = bp+n;
+ }
+ nargs = n;
+ goto apply_cl_top;
+ }else{+ i = uintval(func);
+ if(isbuiltin(func)){+ s = builtins[i].nargs;
+ if(s >= 0)
+ argcount(n, (unsigned)s);
+ else if(s != ANYARGS && (signed)n < -s)
+ argcount(n, (unsigned)-s);
+ // remove function arg
+ for(s = FL(sp)-n-1; s < (int)FL(sp)-1; s++)
+ FL(stack)[s] = FL(stack)[s+1];
+ FL(sp)--;
+ switch(i){+ case OP_LIST: goto LABEL(apply_list);
+ case OP_VECTOR: goto LABEL(apply_vector);
+ case OP_APPLY: goto LABEL(apply_apply);
+ case OP_ADD: goto LABEL(apply_add);
+ case OP_SUB: goto LABEL(apply_sub);
+ case OP_MUL: goto LABEL(apply_mul);
+ case OP_DIV: goto LABEL(apply_div);
+ case OP_AREF: goto LABEL(apply_aref);
+ case OP_ASET: goto LABEL(apply_aset);
+ case OP_LT: goto LABEL(apply_lt);
+ case OP_NUMEQ: goto LABEL(apply_numeq);
+ default:
+#if defined(COMPUTED_GOTO)
+ goto *ops[i];
+#else
+ op = i;
+ continue;
+#endif
+ }
+ }
+ }
+ }else if(fl_likely(iscbuiltin(func))){+ s = FL(sp) - n;
+ v = (((builtin_t*)ptr(func))[3])(&FL(stack)[s], n);
+ FL(sp) = s;
+ FL(stack)[s-1] = v;
+ NEXT_OP;
+ }
+ type_error("function", func);+
+OP(OP_LOADGL)
+ v = fn_vals(FL(stack)[bp-1]);
+ v = vector_elt(v, GET_INT32(ip));
+ ip += 4;
+ if(0){+OP(OP_LOADG)
+ v = fn_vals(FL(stack)[bp-1]);
+ assert(*ip < vector_size(v));
+ v = vector_elt(v, *ip);
+ ip++;
+ }
+ assert(issymbol(v));
+ sym = (symbol_t*)ptr(v);
+ if(fl_unlikely(sym->binding == UNBOUND)){+ FL(stack)[ipd] = (uintptr_t)ip;
+ unbound_error(v);
+ }
+ PUSH(sym->binding);
+ NEXT_OP;
+
+OP(OP_LOADA)
+ i = *ip++;
+ v = FL(stack)[bp+i];
+ PUSH(v);
+ NEXT_OP;
+
+OP(OP_LOADC)
+ i = *ip++;
+ v = FL(stack)[bp+nargs];
+ assert(isvector(v));
+ assert(i < vector_size(v));
+ PUSH(vector_elt(v, i));
+ NEXT_OP;
+
+OP(OP_BOX)
+ i = *ip++;
+ v = mk_cons();
+ car_(v) = FL(stack)[bp+i];
+ cdr_(v) = FL_nil;
+ FL(stack)[bp+i] = v;
+ NEXT_OP;
+
+OP(OP_BOXL)
+ i = GET_INT32(ip); ip += 4;
+ v = mk_cons();
+ car_(v) = FL(stack)[bp+i];
+ cdr_(v) = FL_nil;
+ FL(stack)[bp+i] = v;
+ NEXT_OP;
+
+OP(OP_SHIFT)
+ i = *ip++;
+ FL(stack)[FL(sp)-1-i] = FL(stack)[FL(sp)-1];
+ FL(sp) -= i;
+ NEXT_OP;
+
+OP(OP_RET)
+ v = POP();
+ FL(sp) = FL(curr_frame);
+ FL(curr_frame) = FL(stack)[FL(sp)-3];
+ if(FL(curr_frame) == top_frame)
+ return v;
+ FL(sp) -= 4+nargs;
+ ipd = FL(curr_frame)-1;
+ ip = (uint8_t*)FL(stack)[ipd];
+ nargs = FL(stack)[FL(curr_frame)-2];
+ bp = FL(curr_frame) - 4 - nargs;
+ FL(stack)[FL(sp)-1] = v;
+ NEXT_OP;
+
+OP(OP_DUP)
+ FL(stack)[FL(sp)] = FL(stack)[FL(sp)-1];
+ FL(sp)++;
+ NEXT_OP;
+
+OP(OP_CAR)
+ v = FL(stack)[FL(sp)-1];
+ if(fl_likely(iscons(v)))
+ v = car_(v);
+ else if(fl_unlikely(v != FL_nil)){+ FL(stack)[ipd] = (uintptr_t)ip;
+ type_error("cons", v);+ }
+ FL(stack)[FL(sp)-1] = v;
+ NEXT_OP;
+
+OP(OP_CDR)
+ v = FL(stack)[FL(sp)-1];
+ if(fl_likely(iscons(v)))
+ v = cdr_(v);
+ else if(fl_unlikely(v != FL_nil)){+ FL(stack)[ipd] = (uintptr_t)ip;
+ type_error("cons", v);+ }
+ FL(stack)[FL(sp)-1] = v;
+ NEXT_OP;
+
+OP(OP_CLOSURE)
+ n = *ip++;
+ assert(n > 0);
+ pv = alloc_words(n + 1);
+ v = tagptr(pv, TAG_VECTOR);
+ i = 0;
+ pv[i++] = fixnum(n);
+ do{+ pv[i] = FL(stack)[FL(sp)-n + i-1];
+ i++;
+ }while(i <= n);
+ POPN(n);
+ PUSH(v);
+ if(fl_unlikely((value_t*)FL(curheap) > (value_t*)FL(lim)-2))
+ fl_gc(0);
+ pv = (value_t*)FL(curheap);
+ FL(curheap) += 4*sizeof(value_t);
+ e = FL(stack)[FL(sp)-2]; // closure to copy
+ assert(isfunction(e));
+ pv[0] = ((value_t*)ptr(e))[0];
+ pv[1] = ((value_t*)ptr(e))[1];
+ pv[2] = FL(stack)[FL(sp)-1]; // env
+ pv[3] = ((value_t*)ptr(e))[3];
+ POPN(1);
+ FL(stack)[FL(sp)-1] = tagptr(pv, TAG_FUNCTION);
+ NEXT_OP;
+
+OP(OP_SETA)
+ v = FL(stack)[FL(sp)-1];
+ i = *ip++;
+ FL(stack)[bp+i] = v;
+ NEXT_OP;
+
+OP(OP_JMP)
+ ip += GET_INT16(ip);
+ NEXT_OP;
+
+OP(OP_LOADC0)
+ PUSH(vector_elt(FL(stack)[bp+nargs], 0));
+ NEXT_OP;
+
+OP(OP_CONSP)
+ FL(stack)[FL(sp)-1] = iscons(FL(stack)[FL(sp)-1]) ? FL_t : FL_f;
+ NEXT_OP;
+
+OP(OP_BRNE)
+ ip += FL(stack)[FL(sp)-2] != FL(stack)[FL(sp)-1] ? GET_INT16(ip) : 2;
+ POPN(2);
+ NEXT_OP;
+
+OP(OP_LOADT)
+ PUSH(FL_t);
+ NEXT_OP;
+
+OP(OP_LOADVOID)
+ PUSH(FL_void);
+ NEXT_OP;
+
+OP(OP_LOAD0)
+ PUSH(fixnum(0));
+ NEXT_OP;
+
+OP(OP_LOADC1)
+ PUSH(vector_elt(FL(stack)[bp+nargs], 1));
+ NEXT_OP;
+
+OP(OP_AREF2)
+ n = 2;
+ if(0){+OP(OP_AREF)
+ FL(stack)[ipd] = (uintptr_t)ip;
+ n = 3 + *ip++;
+ }
+LABEL(apply_aref):
+ v = FL(stack)[FL(sp)-n];
+ for(i = n-1; i > 0; i--){+ if(isarray(v)){+ FL(stack)[FL(sp)-i-1] = v;
+ v = cvalue_array_aref(&FL(stack)[FL(sp)-i-1]);
+ continue;
+ }
+ e = FL(stack)[FL(sp)-i];
+ isz = tosize(e);
+ if(isvector(v)){+ if(fl_unlikely(isz >= vector_size(v)))
+ bounds_error(v, e);
+ v = vector_elt(v, isz);
+ continue;
+ }
+ if(!iscons(v) && v != FL_nil)
+ type_error("sequence", v);+ for(value_t v0 = v;; isz--){+ if(isz == 0){+ v = car_(v);
+ break;
+ }
+ v = cdr_(v);
+ if(fl_unlikely(!iscons(v)))
+ bounds_error(v0, e);
+ }
+ }
+ POPN(n);
+ PUSH(v);
+ NEXT_OP;
+
+OP(OP_ATOMP)
+ FL(stack)[FL(sp)-1] = iscons(FL(stack)[FL(sp)-1]) ? FL_f : FL_t;
+ NEXT_OP;
+
+OP(OP_BRT)
+ ip += POP() != FL_f ? GET_INT16(ip) : 2;
+ NEXT_OP;
+
+OP(OP_BRNN)
+ ip += POP() != FL_nil ? GET_INT16(ip) : 2;
+ NEXT_OP;
+
+OP(OP_LOAD1)
+ PUSH(fixnum(1));
+ NEXT_OP;
+
+OP(OP_LT)
+ n = *ip++;
+LABEL(apply_lt):
+ {+ i = n;
+ value_t a = FL(stack)[FL(sp)-i], b;
+ for(v = FL_t; i > 1; a = b){+ i--;
+ b = FL(stack)[FL(sp)-i];
+ if(bothfixnums(a, b)){+ if((fixnum_t)a >= (fixnum_t)b){+ v = FL_f;
+ break;
+ }
+ }else{+ x = numeric_compare(a, b, false, false, false);
+ if(x > 1)
+ x = numval(fl_compare(a, b, false));
+ if(x >= 0){+ v = FL_f;
+ break;
+ }
+ }
+ }
+ POPN(n);
+ PUSH(v);
+ }
+ NEXT_OP;
+
+OP(OP_ADD2)
+LABEL(do_add2):
+ FL(stack)[ipd] = (uintptr_t)ip;
+ if(0){+OP(OP_SUB2)
+LABEL(do_sub2):
+ FL(stack)[ipd] = (uintptr_t)ip;
+ FL(stack)[FL(sp)-1] = fl_neg(FL(stack)[FL(sp)-1]);
+ }
+ {+ value_t a, b, q;
+ a = FL(stack)[FL(sp)-2];
+ b = FL(stack)[FL(sp)-1];
+ if(bothfixnums(a, b) && !sadd_overflow(numval(a), numval(b), &q) && fits_fixnum(q)){+ v = fixnum(q);
+ }else{+ v = fl_add_any(&FL(stack)[FL(sp)-2], 2);
+ }
+ }
+ POPN(1);
+ FL(stack)[FL(sp)-1] = v;
+ NEXT_OP;
+
+OP(OP_SETCDR)
+ v = FL(stack)[FL(sp)-2];
+ if(fl_unlikely(!iscons(v))){+ FL(stack)[ipd] = (uintptr_t)ip;
+ type_error("cons", v);+ }
+ cdr_(v) = FL(stack)[FL(sp)-1];
+ POPN(1);
+ NEXT_OP;
+
+OP(OP_LOADF)
+ PUSH(FL_f);
+ NEXT_OP;
+
+OP(OP_CONS)
+ if(FL(curheap) > FL(lim))
+ fl_gc(0);
+ c = (cons_t*)FL(curheap);
+ FL(curheap) += sizeof(cons_t);
+ c->car = FL(stack)[FL(sp)-2];
+ c->cdr = FL(stack)[FL(sp)-1];
+ FL(stack)[FL(sp)-2] = tagptr(c, TAG_CONS);
+ POPN(1);
+ NEXT_OP;
+
+OP(OP_EQ)
+ FL(stack)[FL(sp)-2] = FL(stack)[FL(sp)-2] == FL(stack)[FL(sp)-1] ? FL_t : FL_f;
+ POPN(1);
+ NEXT_OP;
+
+OP(OP_SYMBOLP)
+ FL(stack)[FL(sp)-1] = issymbol(FL(stack)[FL(sp)-1]) ? FL_t : FL_f;
+ NEXT_OP;
+
+OP(OP_NOT)
+ FL(stack)[FL(sp)-1] = FL(stack)[FL(sp)-1] == FL_f ? FL_t : FL_f;
+ NEXT_OP;
+
+OP(OP_CADR)
+ v = FL(stack)[FL(sp)-1];
+ if(fl_likely(iscons(v))){+ v = cdr_(v);
+ if(fl_likely(iscons(v)))
+ v = car_(v);
+ else
+ goto LABEL(cadr_nil);
+ }else{+LABEL(cadr_nil):
+ if(fl_unlikely(v != FL_nil)){+ FL(stack)[ipd] = (uintptr_t)ip;
+ type_error("cons", v);+ }
+ }
+ FL(stack)[FL(sp)-1] = v;
+ NEXT_OP;
+
+OP(OP_NEG)
+LABEL(do_neg):
+ FL(stack)[ipd] = (uintptr_t)ip;
+ FL(stack)[FL(sp)-1] = fl_neg(FL(stack)[FL(sp)-1]);
+ NEXT_OP;
+
+OP(OP_NANP)
+ {+ value_t q = FL(stack)[FL(sp)-1];
+ v = FL_f;
+ if(iscprim(q)){+ void *data = cp_data(ptr(q));
+ switch(cp_numtype(ptr(q))){+ case T_DOUBLE:
+ if(isnan(*(double*)data))
+ v = FL_t;
+ break;
+ case T_FLOAT:
+ if(isnan(*(float*)data))
+ v = FL_t;
+ break;
+ default:
+ break;
+ }
+ }
+ FL(stack)[FL(sp)-1] = v;
+ }
+ NEXT_OP;
+
+OP(OP_NULLP)
+ FL(stack)[FL(sp)-1] = FL(stack)[FL(sp)-1] == FL_nil ? FL_t : FL_f;
+ NEXT_OP;
+
+OP(OP_BOOLEANP)
+ v = FL(stack)[FL(sp)-1];
+ FL(stack)[FL(sp)-1] = (v == FL_t || v == FL_f) ? FL_t : FL_f;
+ NEXT_OP;
+
+OP(OP_NUMBERP)
+ v = FL(stack)[FL(sp)-1];
+ FL(stack)[FL(sp)-1] = fl_isnumber(v) ? FL_t : FL_f;
+ NEXT_OP;
+
+OP(OP_FIXNUMP)
+ FL(stack)[FL(sp)-1] = isfixnum(FL(stack)[FL(sp)-1]) ? FL_t : FL_f;
+ NEXT_OP;
+
+OP(OP_BOUNDP)
+ FL(stack)[ipd] = (uintptr_t)ip;
+ sym = tosymbol(FL(stack)[FL(sp)-1]);
+ FL(stack)[FL(sp)-1] = sym->binding == UNBOUND ? FL_f : FL_t;
+ NEXT_OP;
+
+OP(OP_BUILTINP)
+ v = FL(stack)[FL(sp)-1];
+ FL(stack)[FL(sp)-1] = (isbuiltin(v) || iscbuiltin(v)) ? FL_t : FL_f;
+ NEXT_OP;
+
+OP(OP_FUNCTIONP)
+ v = FL(stack)[FL(sp)-1];
+ FL(stack)[FL(sp)-1] =
+ ((tag(v) == TAG_FUNCTION &&
+ (isbuiltin(v) || v>(N_BUILTINS<<3))) ||
+ iscbuiltin(v)) ? FL_t : FL_f;
+ NEXT_OP;
+
+OP(OP_VECTORP)
+ FL(stack)[FL(sp)-1] = isvector(FL(stack)[FL(sp)-1]) ? FL_t : FL_f;
+ NEXT_OP;
+
+OP(OP_JMPL)
+ ip += GET_INT32(ip);
+ NEXT_OP;
+
+OP(OP_BRFL)
+ ip += POP() == FL_f ? GET_INT32(ip) : 4;
+ NEXT_OP;
+
+OP(OP_BRTL)
+ ip += POP() != FL_f ? GET_INT32(ip) : 4;
+ NEXT_OP;
+
+OP(OP_BRNEL)
+ ip += FL(stack)[FL(sp)-2] != FL(stack)[FL(sp)-1] ? GET_INT32(ip) : 4;
+ POPN(2);
+ NEXT_OP;
+
+OP(OP_BRNNL)
+ ip += POP() != FL_nil ? GET_INT32(ip) : 4;
+ NEXT_OP;
+
+OP(OP_BRN)
+ ip += POP() == FL_nil ? GET_INT16(ip) : 2;
+ NEXT_OP;
+
+OP(OP_BRNL)
+ ip += POP() == FL_nil ? GET_INT32(ip) : 4;
+ NEXT_OP;
+
+OP(OP_EQV)
+ if(FL(stack)[FL(sp)-2] == FL(stack)[FL(sp)-1])
+ v = FL_t;
+ else if(!leafp(FL(stack)[FL(sp)-2]) || !leafp(FL(stack)[FL(sp)-1]))
+ v = FL_f;
+ else
+ v = fl_compare(FL(stack)[FL(sp)-2], FL(stack)[FL(sp)-1], true) == 0 ? FL_t : FL_f;
+ FL(stack)[FL(sp)-2] = v;
+ POPN(1);
+ NEXT_OP;
+
+OP(OP_EQUAL)
+ if(FL(stack)[FL(sp)-2] == FL(stack)[FL(sp)-1])
+ v = FL_t;
+ else
+ v = fl_compare(FL(stack)[FL(sp)-2], FL(stack)[FL(sp)-1], true) == 0 ? FL_t : FL_f;
+ FL(stack)[FL(sp)-2] = v;
+ POPN(1);
+ NEXT_OP;
+
+OP(OP_SETCAR)
+ v = FL(stack)[FL(sp)-2];
+ if(fl_unlikely(!iscons(v))){+ FL(stack)[ipd] = (uintptr_t)ip;
+ type_error("cons", v);+ }
+ car_(v) = FL(stack)[FL(sp)-1];
+ POPN(1);
+ NEXT_OP;
+
+OP(OP_LIST)
+ n = *ip++;
+LABEL(apply_list):
+ if(n > 0){+ v = list(&FL(stack)[FL(sp)-n], n, 0);
+ POPN(n);
+ PUSH(v);
+ }else{+ PUSH(FL_nil);
+ }
+ NEXT_OP;
+
+OP(OP_TAPPLY)
+ tail = true;
+ if(0){+OP(OP_APPLY)
+ tail = false;
+ }
+ n = *ip++;
+LABEL(apply_apply):
+ v = POP(); // arglist
+ n = FL(sp)-(n-2); // n-2 == # leading arguments not in the list
+ while(iscons(v)){+ PUSHSAFE(car_(v));
+ v = cdr_(v);
+ }
+ if(v != FL_nil){+ FL(stack)[ipd] = (uintptr_t)ip;
+ lerrorf(FL_ArgError, "apply: last argument: not a list");
+ }
+ n = FL(sp)-n;
+ goto LABEL(do_call);
+
+OP(OP_ADD)
+ n = *ip++;
+ if(n == 2)
+ goto LABEL(do_add2);
+LABEL(apply_add):
+ FL(stack)[ipd] = (uintptr_t)ip;
+ v = fl_add_any(&FL(stack)[FL(sp)-n], n);
+ POPN(n);
+ PUSH(v);
+ NEXT_OP;
+
+OP(OP_SUB)
+ n = *ip++;
+LABEL(apply_sub):
+ if(n == 2)
+ goto LABEL(do_sub2);
+ if(n == 1)
+ goto LABEL(do_neg);
+ FL(stack)[ipd] = (uintptr_t)ip;
+ i = FL(sp)-n;
+ // we need to pass the full arglist on to fl_add_any
+ // so it can handle rest args properly
+ PUSH(FL(stack)[i]);
+ FL(stack)[i] = fixnum(0);
+ FL(stack)[i+1] = fl_neg(fl_add_any(&FL(stack)[i], n));
+ FL(stack)[i] = POP();
+ v = fl_add_any(&FL(stack)[i], 2);
+ POPN(n);
+ PUSH(v);
+ NEXT_OP;
+
+OP(OP_MUL)
+ n = *ip++;
+LABEL(apply_mul):
+ FL(stack)[ipd] = (uintptr_t)ip;
+ v = fl_mul_any(&FL(stack)[FL(sp)-n], n);
+ POPN(n);
+ PUSH(v);
+ NEXT_OP;
+
+OP(OP_DIV)
+ n = *ip++;
+LABEL(apply_div):
+ FL(stack)[ipd] = (uintptr_t)ip;
+ i = FL(sp)-n;
+ if(n == 1){+ FL(stack)[FL(sp)-1] = fl_div2(fixnum(1), FL(stack)[i]);
+ }else{+ if(n > 2){+ PUSH(FL(stack)[i]);
+ FL(stack)[i] = fixnum(1);
+ FL(stack)[i+1] = fl_mul_any(&FL(stack)[i], n);
+ FL(stack)[i] = POP();
+ }
+ v = fl_div2(FL(stack)[i], FL(stack)[i+1]);
+ POPN(n);
+ PUSH(v);
+ }
+ NEXT_OP;
+
+OP(OP_IDIV)
+ {+ value_t a = FL(stack)[FL(sp)-2];
+ value_t b = FL(stack)[FL(sp)-1];
+ if(bothfixnums(a, b)){+ if(b == 0){+ FL(stack)[ipd] = (uintptr_t)ip;
+ DivideByZeroError();
+ }
+ v = fixnum(numval(a) / numval(b));
+ }else{+ FL(stack)[ipd] = (uintptr_t)ip;
+ v = fl_idiv2(a, b);
+ }
+ POPN(1);
+ FL(stack)[FL(sp)-1] = v;
+ }
+ NEXT_OP;
+
+OP(OP_NUMEQ)
+ n = *ip++;
+LABEL(apply_numeq):
+ {+ i = n;
+ value_t a = FL(stack)[FL(sp)-i], b;
+ for(v = FL_t; i > 1; a = b){+ i--;
+ b = FL(stack)[FL(sp)-i];
+ if(bothfixnums(a, b)){+ if(a != b){+ v = FL_f;
+ break;
+ }
+ }else if(numeric_compare(a, b, true, false, true) != 0){+ v = FL_f;
+ break;
+ }
+ }
+ POPN(n);
+ PUSH(v);
+ }
+ NEXT_OP;
+
+OP(OP_COMPARE)
+ FL(stack)[FL(sp)-2] = fl_compare(FL(stack)[FL(sp)-2], FL(stack)[FL(sp)-1], false);
+ POPN(1);
+ NEXT_OP;
+
+OP(OP_ARGC)
+ n = *ip++;
+ if(0){+OP(OP_LARGC)
+ n = GET_INT32(ip);
+ ip += 4;
+ }
+ FL(stack)[ipd] = (uintptr_t)ip;
+ argcount(nargs, n);
+ NEXT_OP;
+
+OP(OP_VECTOR)
+ n = *ip++;
+LABEL(apply_vector):
+ v = alloc_vector(n, 0);
+ if(n){+ memcpy(&vector_elt(v, 0), &FL(stack)[FL(sp)-n], n*sizeof(value_t));
+ POPN(n);
+ }
+ PUSH(v);
+ NEXT_OP;
+
+OP(OP_ASET)
+ FL(stack)[ipd] = (uintptr_t)ip;
+ v = FL(stack)[FL(sp)-3];
+ n = 3;
+ if(0){+LABEL(apply_aset):
+ v = FL(stack)[FL(sp)-n];
+ for(i = n-1; i >= 3; i--){+ if(isarray(v)){+ FL(stack)[FL(sp)-i-1] = v;
+ v = cvalue_array_aref(&FL(stack)[FL(sp)-i-1]);
+ continue;
+ }
+ e = FL(stack)[FL(sp)-i];
+ isz = tosize(e);
+ if(isvector(v)){+ if(fl_unlikely(isz >= vector_size(v)))
+ bounds_error(v, e);
+ v = vector_elt(v, isz);
+ continue;
+ }
+ if(!iscons(v) && v != FL_nil)
+ type_error("sequence", v);+ for(value_t v0 = v;; isz--){+ if(isz == 0){+ v = car_(v);
+ break;
+ }
+ v = cdr_(v);
+ if(fl_unlikely(!iscons(v)))
+ bounds_error(v0, e);
+ }
+ }
+ FL(stack)[FL(sp)-3] = v;
+ }
+ e = FL(stack)[FL(sp)-2];
+ isz = tosize(e);
+ if(isvector(v)){+ if(fl_unlikely(isz >= vector_size(v)))
+ bounds_error(v, e);
+ vector_elt(v, isz) = (e = FL(stack)[FL(sp)-1]);
+ }else if(iscons(v) || v == FL_nil){+ for(value_t v0 = v;; isz--){+ if(isz == 0){+ car_(v) = (e = FL(stack)[FL(sp)-1]);
+ break;
+ }
+ v = cdr_(v);
+ if(fl_unlikely(!iscons(v)))
+ bounds_error(v0, e);
+ }
+ }else if(isarray(v)){+ e = cvalue_array_aset(&FL(stack)[FL(sp)-3]);
+ }else{+ type_error("sequence", v);+ }
+ POPN(n);
+ PUSH(e);
+ NEXT_OP;
+
+OP(OP_FOR)
+ FL(stack)[ipd] = (uintptr_t)ip;
+ s = tofixnum(FL(stack)[FL(sp)-3]);
+ hi = tofixnum(FL(stack)[FL(sp)-2]);
+ v = FL_void;
+ FL(sp) += 2;
+ n = FL(sp);
+ for(; s <= hi; s++){+ FL(stack)[FL(sp)-2] = FL(stack)[FL(sp)-3];
+ FL(stack)[FL(sp)-1] = fixnum(s);
+ v = _applyn(1);
+ FL(sp) = n;
+ }
+ POPN(4);
+ FL(stack)[FL(sp)-1] = v;
+ NEXT_OP;
+
+OP(OP_LOADNIL)
+ PUSH(FL_nil);
+ NEXT_OP;
+
+OP(OP_LOADI8)
+ s = (int8_t)*ip++;
+ PUSH(fixnum(s));
+ NEXT_OP;
+
+OP(OP_LOADVL)
+ v = fn_vals(FL(stack)[bp-1]);
+ v = vector_elt(v, GET_INT32(ip));
+ ip += 4;
+ PUSH(v);
+ NEXT_OP;
+
+OP(OP_SETGL)
+ v = fn_vals(FL(stack)[bp-1]);
+ v = vector_elt(v, GET_INT32(ip));
+ ip += 4;
+ if(0){+OP(OP_SETG)
+ v = fn_vals(FL(stack)[bp-1]);
+ assert(*ip < vector_size(v));
+ v = vector_elt(v, *ip);
+ ip++;
+ }
+ assert(issymbol(v));
+ sym = (symbol_t*)ptr(v);
+ v = FL(stack)[FL(sp)-1];
+ if(!isconstant(sym))
+ sym->binding = v;
+ NEXT_OP;
+
+OP(OP_LOADAL)
+ assert(nargs > 0);
+ i = GET_INT32(ip);
+ ip += 4;
+ v = FL(stack)[bp+i];
+ PUSH(v);
+ NEXT_OP;
+
+OP(OP_SETAL)
+ v = FL(stack)[FL(sp)-1];
+ i = GET_INT32(ip);
+ ip += 4;
+ FL(stack)[bp+i] = v;
+ NEXT_OP;
+
+OP(OP_LOADCL)
+ i = GET_INT32(ip);
+ ip += 4;
+ v = FL(stack)[bp+nargs];
+ PUSH(vector_elt(v, i));
+ NEXT_OP;
+
+OP(OP_VARGC)
+ i = *ip++;
+ if(0){+OP(OP_LVARGC)
+ i = GET_INT32(ip);
+ ip += 4;
+ }
+ s = (fixnum_t)nargs - (fixnum_t)i;
+ if(s > 0){+ v = list(&FL(stack)[bp+i], s, 0);
+ FL(stack)[bp+i] = v;
+ if(s > 1){+ FL(stack)[bp+i+1] = FL(stack)[bp+nargs+0];
+ FL(stack)[bp+i+2] = FL(stack)[bp+nargs+1];
+ FL(stack)[bp+i+3] = i+1;
+ FL(stack)[bp+i+4] = 0;
+ FL(sp) = bp+i+5;
+ FL(curr_frame) = FL(sp);
+ }
+ }else if(fl_unlikely(s < 0)){+ FL(stack)[ipd] = (uintptr_t)ip;
+ lerrorf(FL_ArgError, "too few arguments");
+ }else{+ FL(sp)++;
+ FL(stack)[FL(sp)-2] = i+1;
+ FL(stack)[FL(sp)-3] = FL(stack)[FL(sp)-4];
+ FL(stack)[FL(sp)-4] = FL(stack)[FL(sp)-5];
+ FL(stack)[FL(sp)-5] = FL_nil;
+ FL(curr_frame) = FL(sp);
+ }
+ ipd = FL(sp)-1;
+ nargs = i+1;
+ NEXT_OP;
+
+OP(OP_TRYCATCH)
+ FL(stack)[ipd] = (uintptr_t)ip;
+ v = do_trycatch();
+ POPN(1);
+ FL(stack)[FL(sp)-1] = v;
+ NEXT_OP;
+
+OP(OP_OPTARGS)
+ i = GET_INT32(ip);
+ ip += 4;
+ n = GET_INT32(ip);
+ ip += 4;
+ if(fl_unlikely(nargs < i)){+ FL(stack)[ipd] = (uintptr_t)ip;
+ lerrorf(FL_ArgError, "too few arguments");
+ }
+ if((int32_t)n > 0){+ if(fl_unlikely(nargs > n)){+ FL(stack)[ipd] = (uintptr_t)ip;
+ lerrorf(FL_ArgError, "too many arguments");
+ }
+ }else
+ n = -n;
+ if(fl_likely(n > nargs)){+ n -= nargs;
+ FL(sp) += n;
+ FL(stack)[FL(sp)-1] = FL(stack)[FL(sp)-n-1];
+ FL(stack)[FL(sp)-2] = nargs+n;
+ FL(stack)[FL(sp)-3] = FL(stack)[FL(sp)-n-3];
+ FL(stack)[FL(sp)-4] = FL(stack)[FL(sp)-n-4];
+ FL(curr_frame) = FL(sp);
+ ipd = FL(sp)-1;
+ for(i = 0; i < n; i++)
+ FL(stack)[bp+nargs+i] = UNBOUND;
+ nargs += n;
+ }
+ NEXT_OP;
+
+OP(OP_BRBOUND)
+ i = GET_INT32(ip);
+ ip += 4;
+ v = FL(stack)[bp+i];
+ PUSH(v != UNBOUND ? FL_t : FL_f);
+ NEXT_OP;
+
+OP(OP_KEYARGS)
+ v = fn_vals(FL(stack)[bp-1]);
+ v = vector_elt(v, 0);
+ i = GET_INT32(ip);
+ ip += 4;
+ n = GET_INT32(ip);
+ ip += 4;
+ s = GET_INT32(ip);
+ ip += 4;
+ FL(stack)[ipd] = (uintptr_t)ip;
+ nargs = process_keys(v, i, n, labs(s)-(i+n), bp, nargs, s<0);
+ ipd = FL(sp)-1;
+ NEXT_OP;
--- a/string.c
+++ /dev/null
@@ -1,409 +1,0 @@
-/*
- string functions
-*/
-#include "flisp.h"
-#include "operators.h"
-#include "cvalues.h"
-#include "print.h"
-#include "read.h"
-#include "equal.h"
-#include "iostream.h"
-
-fl_purefn
-BUILTIN("string?", stringp)-{- argcount(nargs, 1);
- return fl_isstring(args[0]) ? FL_t : FL_f;
-}
-
-BUILTIN("string-length", string_length)-{- size_t start = 0;
- if(nargs < 1 || nargs > 3)
- argcount(nargs, 1);
- if(!fl_isstring(args[0]))
- type_error("string", args[0]);- size_t len = cv_len(ptr(args[0]));
- size_t stop = len;
- if(nargs > 1){- start = tosize(args[1]);
- if(start > len)
- bounds_error(args[0], args[1]);
- if(nargs > 2){- stop = tosize(args[2]);
- if(stop > len)
- bounds_error(args[0], args[2]);
- if(stop <= start)
- return fixnum(0);
- }
- }
- char *str = cvalue_data(args[0]);
- return size_wrap(u8_charnum(str+start, stop-start));
-}
-
-BUILTIN("string-width", string_width)-{- argcount(nargs, 1);
- if(iscprim(args[0])){- cprim_t *cp = ptr(args[0]);
- if(cp_class(cp) == FL(runetype)){- int w = wcwidth(*(Rune*)cp_data(cp));
- return w < 0 ? FL_f : fixnum(w);
- }
- }
- return size_wrap(u8_strwidth(tostring(args[0])));
-}
-
-BUILTIN("string-reverse", string_reverse)-{- argcount(nargs, 1);
- if(!fl_isstring(args[0]))
- type_error("string", args[0]);- size_t len = cv_len(ptr(args[0]));
- value_t ns = cvalue_string(len);
- u8_reverse(cvalue_data(ns), cvalue_data(args[0]), len);
- return ns;
-}
-
-BUILTIN("string-encode", string_encode)-{- argcount(nargs, 1);
- if(iscvalue(args[0])){- cvalue_t *cv = ptr(args[0]);
- fltype_t *t = cv_class(cv);
- if(t->eltype == FL(runetype)){- size_t nr = cv_len(cv) / sizeof(Rune);
- Rune *r = (Rune*)cv_data(cv);
- size_t nb = runenlen(r, nr);
- value_t str = cvalue_string(nb);
- char *s = cvalue_data(str);
- for(size_t i = 0; i < nr; i++)
- s += runetochar(s, r+i);
- return str;
- }
- }
- type_error("rune array", args[0]);-}
-
-BUILTIN("string-decode", string_decode)-{- int term = 0;
- if(nargs == 2)
- term = args[1] != FL_f;
- else
- argcount(nargs, 1);
- if(!fl_isstring(args[0]))
- type_error("string", args[0]);- cvalue_t *cv = ptr(args[0]);
- char *ptr = (char*)cv_data(cv);
- size_t nb = cv_len(cv);
- size_t nc = utfnlen(ptr, nb);
- size_t newsz = nc*sizeof(Rune);
- if(term)
- newsz += sizeof(Rune);
- value_t runestr = cvalue(FL(runestringtype), newsz);
- ptr = cvalue_data(args[0]); // relocatable pointer
- Rune *r = cvalue_data(runestr);
- for(size_t i = 0; i < nb; i++)
- ptr += chartorune(r+i, ptr);
- if(term)
- r[nb] = 0;
- return runestr;
-}
-
-BUILTIN("string", string)-{- if(nargs == 1 && fl_isstring(args[0]))
- return args[0];
- value_t arg, buf = fn_builtin_buffer(nil, 0);
- fl_gc_handle(&buf);
- ios_t *s = value2c(ios_t*, buf);
- value_t oldpr = symbol_value(FL_printreadablysym);
- value_t oldpp = symbol_value(FL_printprettysym);
- set(FL_printreadablysym, FL_f);
- set(FL_printprettysym, FL_f);
- uint32_t i;
- FOR_ARGS(i, 0, arg, args){- USED(arg);
- fl_print(s, args[i]);
- }
- set(FL_printreadablysym, oldpr);
- set(FL_printprettysym, oldpp);
- value_t outp = stream_to_string(&buf);
- fl_free_gc_handles(1);
- return outp;
-}
-
-BUILTIN("string-split", string_split)-{- argcount(nargs, 2);
- char *s = tostring(args[0]);
- char *delim = tostring(args[1]);
- size_t len = cv_len(ptr(args[0]));
- size_t dlen = cv_len(ptr(args[1]));
- size_t ssz, tokend, tokstart, i = 0;
- value_t first = FL_nil, c = FL_nil, last;
- size_t junk;
- fl_gc_handle(&first);
- fl_gc_handle(&last);
-
- do{- // find and allocate next token
- tokstart = tokend = i;
- while(i < len && !u8_memchr(delim, u8_nextmemchar(s, &i), dlen, &junk))
- tokend = i;
- ssz = tokend - tokstart;
- last = c; // save previous cons cell
- c = fl_cons(cvalue_string(ssz), FL_nil);
-
- // we've done allocation; reload movable pointers
- s = cvalue_data(args[0]);
- delim = cvalue_data(args[1]);
-
- if(ssz)
- memmove(cvalue_data(car_(c)), &s[tokstart], ssz);
-
- // link new cell
- if(last == FL_nil)
- first = c; // first time, save first cons
- else
- ((cons_t*)ptr(last))->cdr = c;
-
- // note this tricky condition: if the string ends with a
- // delimiter, we need to go around one more time to add an
- // empty string. this happens when (i == len && tokend < i)
- }while(i < len || (i == len && (tokend != i)));
- fl_free_gc_handles(2);
- return first;
-}
-
-BUILTIN("string-sub", string_sub)-{- if(nargs != 2)
- argcount(nargs, 3);
- char *s = tostring(args[0]);
- size_t lenbytes = cv_len(ptr(args[0]));
- size_t startbytes, n, startchar = tosize(args[1]);
- for(startbytes = n = 0; n < startchar && startbytes < lenbytes; n++)
- startbytes += u8_seqlen(s+startbytes);
- if(n != startchar)
- bounds_error(args[0], args[1]);
- size_t endbytes = lenbytes;
- if(nargs == 3){- size_t endchar = tosize(args[2]);
- for(endbytes = startbytes; n < endchar && endbytes < lenbytes; n++)
- endbytes += u8_seqlen(s+endbytes);
- if(n != endchar)
- bounds_error(args[0], args[2]);
- }
- value_t ns = cvalue_string(endbytes-startbytes);
- s = cvalue_data(args[0]); // reload after alloc
- memmove(cvalue_data(ns), s+startbytes, endbytes-startbytes);
- return ns;
-}
-
-BUILTIN("string-char", string_char)-{- argcount(nargs, 2);
- char *s = tostring(args[0]);
- size_t lenbytes = cv_len(ptr(args[0]));
- size_t startbytes, n, startchar = tosize(args[1]);
- for(startbytes = n = 0; n < startchar && startbytes < lenbytes; n++)
- startbytes += u8_seqlen(s+startbytes);
- if(n != startchar)
- bounds_error(args[0], args[1]);
- Rune r;
- chartorune(&r, s+startbytes);
- return mk_rune(r);
-}
-
-BUILTIN("char-upcase", char_upcase)-{- argcount(nargs, 1);
- cprim_t *cp = ptr(args[0]);
- if(!iscprim(args[0]) || cp_class(cp) != FL(runetype))
- type_error("rune", args[0]);- return mk_rune(toupperrune(*(Rune*)cp_data(cp)));
-}
-
-BUILTIN("char-downcase", char_downcase)-{- argcount(nargs, 1);
- cprim_t *cp = ptr(args[0]);
- if(!iscprim(args[0]) || cp_class(cp) != FL(runetype))
- type_error("rune", args[0]);- return mk_rune(tolowerrune(*(Rune*)cp_data(cp)));
-}
-
-BUILTIN("char-titlecase", char_titlecase)-{- argcount(nargs, 1);
- cprim_t *cp = ptr(args[0]);
- if(!iscprim(args[0]) || cp_class(cp) != FL(runetype))
- type_error("rune", args[0]);- return mk_rune(totitlerune(*(Rune*)cp_data(cp)));
-}
-
-fl_purefn
-BUILTIN("char-alphabetic?", char_alphabeticp)-{- argcount(nargs, 1);
- cprim_t *cp = ptr(args[0]);
- if(!iscprim(args[0]) || cp_class(cp) != FL(runetype))
- type_error("rune", args[0]);- return isalpharune(*(Rune*)cp_data(cp)) ? FL_t : FL_f;
-}
-
-fl_purefn
-BUILTIN("char-lower-case?", char_lower_casep)-{- argcount(nargs, 1);
- cprim_t *cp = ptr(args[0]);
- if(!iscprim(args[0]) || cp_class(cp) != FL(runetype))
- type_error("rune", args[0]);- return islowerrune(*(Rune*)cp_data(cp)) ? FL_t : FL_f;
-}
-
-fl_purefn
-BUILTIN("char-upper-case?", char_upper_casep)-{- argcount(nargs, 1);
- cprim_t *cp = ptr(args[0]);
- if(!iscprim(args[0]) || cp_class(cp) != FL(runetype))
- type_error("rune", args[0]);- return isupperrune(*(Rune*)cp_data(cp)) ? FL_t : FL_f;
-}
-
-fl_purefn
-BUILTIN("char-title-case?", char_title_casep)-{- argcount(nargs, 1);
- cprim_t *cp = ptr(args[0]);
- if(!iscprim(args[0]) || cp_class(cp) != FL(runetype))
- type_error("rune", args[0]);- return istitlerune(*(Rune*)cp_data(cp)) ? FL_t : FL_f;
-}
-
-fl_purefn
-BUILTIN("char-numeric?", char_numericp)-{- argcount(nargs, 1);
- cprim_t *cp = ptr(args[0]);
- if(!iscprim(args[0]) || cp_class(cp) != FL(runetype))
- type_error("rune", args[0]);- return isdigitrune(*(Rune*)cp_data(cp)) ? FL_t : FL_f;
-}
-
-fl_purefn
-BUILTIN("char-whitespace?", char_whitespacep)-{- argcount(nargs, 1);
- cprim_t *cp = ptr(args[0]);
- if(!iscprim(args[0]) || cp_class(cp) != FL(runetype))
- type_error("rune", args[0]);- return isspacerune(*(Rune*)cp_data(cp)) ? FL_t : FL_f;
-}
-
-BUILTIN("string-find", string_find)-{- char cbuf[UTFmax+1];
- size_t start = 0;
- if(nargs == 3)
- start = tosize(args[2]);
- else
- argcount(nargs, 2);
- char *s = tostring(args[0]);
- size_t len = cv_len(ptr(args[0]));
- if(start > len)
- bounds_error(args[0], args[2]);
- char *needle; size_t needlesz;
-
- value_t v = args[1];
- cprim_t *cp = ptr(v);
- if(iscprim(v) && cp_class(cp) == FL(runetype)){- Rune r = *(Rune*)cp_data(cp);
- needlesz = runetochar(cbuf, &r);
- needle = cbuf;
- needle[needlesz] = 0;
- }else if(iscprim(v) && cp_class(cp) == FL(bytetype)){- needlesz = 1;
- needle = cbuf;
- needle[0] = *(char*)cp_data(cp);
- needle[needlesz] = 0;
- }else if(fl_isstring(v)){- cvalue_t *cv = ptr(v);
- needlesz = cv_len(cv);
- needle = (char*)cv_data(cv);
- }else{- type_error("string", args[1]);- }
- if(needlesz > len-start)
- return FL_f;
- if(needlesz == 0)
- return size_wrap(start);
- size_t i;
- for(i = start; i < len-needlesz+1; i++){- if(s[i] == needle[0] && memcmp(&s[i+1], needle+1, needlesz-1) == 0)
- return size_wrap(i);
- }
- return FL_f;
-}
-
-static unsigned long
-get_radix_arg(value_t arg)
-{- unsigned long radix = tosize(arg);
- if(radix < 2 || radix > 36)
- lerrorf(FL_ArgError, "invalid radix");
- return radix;
-}
-
-BUILTIN("number->string", number_2_string)-{- if(nargs < 1 || nargs > 2)
- argcount(nargs, 2);
- value_t n = args[0];
- int neg = 0;
- uint64_t num;
- if(isfixnum(n))
- num = numval(n);
- else if(!iscprim(n))
- type_error("integer", n);- else
- num = conv_to_uint64(cp_data(ptr(n)), cp_numtype(ptr(n)));
- if(numval(fl_compare(args[0], fixnum(0), false)) < 0){- num = -num;
- neg = 1;
- }
- unsigned long radix = 10;
- if(nargs == 2)
- radix = get_radix_arg(args[1]);
- char buf[128];
- char *str = uint2str(buf, sizeof(buf), num, radix);
- if(neg && str > &buf[0])
- *(--str) = '-';
- return string_from_cstr(str);
-}
-
-BUILTIN("string->number", string_2_number)-{- if(nargs < 1 || nargs > 2)
- argcount(nargs, 2);
- char *str = tostring(args[0]);
- value_t n;
- unsigned long radix = 0;
- if(nargs == 2)
- radix = get_radix_arg(args[1]);
- if(!fl_read_numtok(str, &n, (int)radix))
- return FL_f;
- return n;
-}
-
-fl_purefn
-BUILTIN("string-utf8?", string_utf8p)-{- argcount(nargs, 1);
- char *s = tostring(args[0]);
- size_t len = cv_len(ptr(args[0]));
- return u8_isvalid(s, len) ? FL_t : FL_f;
-}
--- a/sys_dos.c
+++ /dev/null
@@ -1,52 +1,0 @@
-#include "flisp.h"
-#include "timefuncs.h"
-
-double
-sec_realtime(void)
-{- return 0.0;
-}
-
-uint64_t
-nanosec_monotonic(void)
-{- return 0;
-}
-
-void
-timestring(double s, char *buf, int sz)
-{- time_t tme = (time_t)s;
- struct tm tm;
-
- localtime_r(&tme, &tm);
- strftime(buf, sz, "%c", &tm);
-}
-
-double
-parsetime(const char *s)
-{- return -1;
-}
-
-void
-sleep_ms(int ms)
-{- if(ms != 0){- struct timeval timeout;
- timeout.tv_sec = ms/1000;
- timeout.tv_usec = (ms % 1000) * 1000;
- select(0, nil, nil, nil, &timeout);
- }
-}
-
-static const uint8_t boot[] = {-#include "flisp.boot.h"
-};
-
-int
-main(int argc, char **argv)
-{- setlocale(LC_NUMERIC, "C");
- flmain(boot, sizeof(boot), argc, argv);
-}
--- a/sys_macos.c
+++ /dev/null
@@ -1,94 +1,0 @@
-#include <OSUtils.h>
-#include "flisp.h"
-#include "timefuncs.h"
-
-double
-sec_realtime(void)
-{- struct timeval now;
-
- if(gettimeofday(&now, nil) != 0)
- return 0.0;
- return (double)now.tv_sec + (double)now.tv_usec/1.0e6;
-}
-
-/*
- * nsec() is wallclock and can be adjusted by timesync
- * so need to use cycles() instead, but fall back to
- * nsec() in case we can't
- */
-uint64_t
-nanosec_monotonic(void)
-{- return 0;
-}
-
-void
-timestring(double s, char *buf, int sz)
-{- USED(s); USED(sz);
- buf[0] = 0;
-}
-
-double
-parsetime(const char *s)
-{- USED(s);
- return 0.0;
-}
-
-void
-sleep_ms(int ms)
-{- USED(ms);
-}
-
-int
-ftruncate(int f, off_t sz)
-{- USED(f); USED(sz);
- return -1;
-}
-
-char *
-getcwd(char *buf, size_t len)
-{- USED(buf); USED(len);
- return nil;
-}
-
-int
-chdir(const char *path)
-{- USED(path);
- return -1;
-}
-
-int
-access(const char *path, int amode)
-{- USED(path); USED(amode);
- return -1;
-}
-
-char os_version[10];
-
-static const uint8_t boot[] = {-#include "flisp.boot.h"
-};
-
-int
-main(int argc, char **argv)
-{- static SysEnvRec r;
- memset(&r, 0, sizeof(r));
- SysEnvirons(2, &r);
- snprintf(
- os_version, sizeof(boot),
- "%d.%d.%d",
- r.systemVersion>>8,
- (r.systemVersion>>4)&0xf,
- (r.systemVersion>>0)&0xf
- );
- flmain(boot, sizeof(boot), argc, argv);
-}
--- a/sys_plan9.c
+++ /dev/null
@@ -1,90 +1,0 @@
-#include "flisp.h"
-#include "timefuncs.h"
-#include <tos.h>
-
-double
-sec_realtime(void)
-{- vlong t = nsec();
- vlong ns = t % 1000000000LL;
- vlong s = (t - ns) / 1000000000LL;
- return (double)s + (double)ns/1.0e9;
-}
-
-/*
- * nsec() is wallclock and can be adjusted by timesync
- * so need to use cycles() instead, but fall back to
- * nsec() in case we can't
- */
-uint64_t
-nanosec_monotonic(void)
-{- static uint64_t fasthz, xstart;
- uint64_t x, div;
-
- if(fasthz == ~0ULL)
- return nsec() - xstart;
-
- if(fasthz == 0){- if(_tos->cyclefreq){- fasthz = _tos->cyclefreq;
- cycles(&xstart);
- } else {- fasthz = ~0ULL;
- xstart = nsec();
- }
- return 0;
- }
- cycles(&x);
- x -= xstart;
-
- /* this is ugly */
- for(div = 1000000000ULL; x < 0x1999999999999999ULL && div > 1 ; div /= 10ULL, x *= 10ULL);
-
- return x / (fasthz / div);
-}
-
-void
-timestring(double s, char *buf, int sz)
-{- Tm tm;
- snprint(buf, sz, "%τ", tmfmt(tmtime(&tm, s, tzload("local")), nil));-}
-
-double
-parsetime(const char *s)
-{- Tm tm;
- if(tmparse(&tm, "?WWW, ?MM ?DD hh:mm:ss ?Z YYYY", s, tzload("local"), nil) == nil)- return -1;
- return tmnorm(&tm);
-}
-
-void
-sleep_ms(int ms)
-{- if(ms != 0)
- sleep(ms);
-}
-
-int
-ftruncate(int f, off_t sz)
-{- Dir d;
-
- nulldir(&d);
- d.length = sz;
- return dirfwstat(f, &d) > 0 ? 0 : -1;
-}
-
-extern uchar bootcode[];
-extern ulong bootlen;
-
-void
-main(int argc, char **argv)
-{- argv0 = argv[0];
- setfcr(FPPDBL|FPRNR|FPOVFL);
- tmfmtinstall();
- flmain(bootcode, bootlen, argc, argv);
-}
--- a/sys_posix.c
+++ /dev/null
@@ -1,87 +1,0 @@
-#include "flisp.h"
-#include "timefuncs.h"
-
-double
-sec_realtime(void)
-{- struct timespec now;
- if(clock_gettime(CLOCK_REALTIME, &now) != 0)
- return 0;
- return (double)now.tv_sec + (double)now.tv_nsec/1.0e9;
-}
-
-uint64_t
-nanosec_monotonic(void)
-{- static int64_t z;
- struct timespec now;
-
- if(clock_gettime(CLOCK_MONOTONIC, &now) != 0)
- return 0;
- if(z == 0){- z = now.tv_sec*1000000000LL + now.tv_nsec;
- return 0;
- }
- return now.tv_sec*1000000000LL + now.tv_nsec - z;
-}
-
-void
-timestring(double s, char *buf, int sz)
-{- time_t tme = (time_t)s;
- struct tm tm;
-
- *buf = 0;
- if(localtime_r(&tme, &tm) != nil)
- strftime(buf, sz, "%a %b %e %H:%M:%S %Y", &tm);
-}
-
-double
-parsetime(const char *s)
-{- char *res;
- time_t t;
- struct tm tm;
-
- res = strptime(s, "%c", &tm);
- if(res != nil){- /* Not set by strptime(); tells mktime() to determine
- * whether daylight saving time is in effect
- */
- tm.tm_isdst = -1;
- t = mktime(&tm);
- if(t == (time_t)-1)
- return -1;
- return (double)t;
- }
- return -1;
-}
-
-void
-sleep_ms(int ms)
-{- if(ms != 0){- struct timeval timeout;
- timeout.tv_sec = ms/1000;
- timeout.tv_usec = (ms % 1000) * 1000;
- select(0, nil, nil, nil, &timeout);
- }
-}
-
-static const uint8_t boot[] = {-#include "flisp.boot.h"
-};
-
-char __os_version__[64];
-#include <sys/utsname.h>
-
-int
-main(int argc, char **argv)
-{- setlocale(LC_NUMERIC, "C");
- struct utsname u;
- __os_version__[0] = 0;
- if(uname(&u) == 0)
- snprintf(__os_version__, sizeof(__os_version__), "%s", u.release);
- flmain(boot, sizeof(boot), argc, argv);
-}
--- a/system.lsp
+++ /dev/null
@@ -1,1156 +1,0 @@
-; -*- scheme -*-
-; femtoLisp standard library
-; by Jeff Bezanson (C) 2009
-; Distributed under the BSD License
-
-;;; void
-
-(define (void . rest)
- "Return the constant #<void> while ignoring any arguments.
-#<void> is mainly used when a function has side effects but does not
-produce any meaningful value to return, so even though #t or nil could
-be returned instead, in case of #<void> alone, REPL will not print
-it."
- #.(void))
-
-(define (void? x)
- "Return #t if x is #<void> and #f otherwise."
- (eq? x #.(void)))
-
-;;; syntax environment
-
-(unless (bound? '*syntax-environment*)
- (define *syntax-environment* (table)))
-
-(define (set-syntax! s v) (put! *syntax-environment* s v))
-(define (symbol-syntax s) (get *syntax-environment* s #f))
-
-(define-macro (define-macro form . body)
- (let ((doc (value-get-doc body)))
- (when doc
- (symbol-set-doc (car form) doc (cdr form))
- (set! body (cdr body)))
- `(void (set-syntax! ',(car form)
- (λ ,(cdr form) ,@body)))))
-
-(define-macro (letrec binds . body)
- `((λ ,(map car binds)
- ,.(map (λ (b) `(set! ,@b)) binds)
- ,@body)
- ,.(map void binds)))
-
-(define-macro (let binds . body)
- (let ((lname #f))
- (when (symbol? binds)
- (set! lname binds)
- (set! binds (car body))
- (set! body (cdr body)))
- (let ((thelambda
- `(λ ,(map (λ (c) (if (cons? c) (car c) c))
- binds)
- ,@body))
- (theargs
- (map (λ (c) (if (cons? c) (cadr c) (void))) binds)))
- (cons (if lname
- `(letrec ((,lname ,thelambda)) ,lname)
- thelambda)
- theargs))))
-
-(define-macro (cond . clauses)
- (define (cond-clauses->if lst)
- (if (atom? lst)
- #f
- (let ((clause (car lst)))
- (if (or (eq? (car clause) 'else)
- (eq? (car clause) #t))
- (if (null? (cdr clause))
- (car clause)
- (cons 'begin (cdr clause)))
- (if (null? (cdr clause))
- ; test by itself
- (list 'or
- (car clause)
- (cond-clauses->if (cdr lst)))
- ; test => expression
- (if (eq? (cadr clause) '=>)
- (if (1arg-lambda? (caddr clause))
- ; test => (λ (x) ...)
- (let ((var (caadr (caddr clause))))
- `(let ((,var ,(car clause)))
- (if ,var ,(cons 'begin (cddr (caddr clause)))
- ,(cond-clauses->if (cdr lst)))))
- ; test => proc
- (let ((b (gensym)))
- `(let ((,b ,(car clause)))
- (if ,b
- (,(caddr clause) ,b)
- ,(cond-clauses->if (cdr lst))))))
- (list 'if
- (car clause)
- (cons 'begin (cdr clause))
- (cond-clauses->if (cdr lst)))))))))
- (cond-clauses->if clauses))
-
-;;; props
-
-;; This is implemented in a slightly different fashion as expected:
-;;
-;; *properties* : key → { symbol → value }-;;
-;; The assumption here is that keys will most likely be the same across multiple symbols
-;; so it makes more sense to reduce the number of subtables for the *properties* table.
-(unless (bound? '*properties*)
- (define *properties* (table)))
-
-(define (putprop sym key val)
- (let ((kt (get *properties* key #f)))
- (unless kt
- (let ((t (table)))
- (put! *properties* key t)
- (set! kt t)))
- (put! kt sym val)
- val))
-
-(define (getprop sym key (def #f))
- (let ((kt (get *properties* key #f)))
- (or (and kt (get kt sym def)) def)))
-
-(define (remprop sym key)
- (let ((kt (get *properties* key #f)))
- (and kt (has? kt sym) (del! kt sym))))
-
-;;; documentation
-
-(define (symbol-set-doc sym doc . funvars)
- (when doc
- (putprop sym '*doc* doc))
- (when (cons? funvars)
- (putprop sym '*funvars* (append (getprop sym '*funvars* nil)
- funvars))))
-
-;; chicken and egg - properties defined before symbol-set-doc
-(symbol-set-doc
- '*properties*
- "All properties of symbols recorded with putprop are recorded in this table.")
-
-(define-macro (help term)
- "Display documentation for the specified term, if available."
- (let* ((doc (getprop term '*doc*)))
- (if doc
- (begin
- (princ doc)
- (newline)
- (for-each (λ (funvars) (newline) (print (cons term funvars)))
- (getprop term '*funvars* nil))
- (newline))
- (begin
- (princ "no help for " (string term))
- (newline)))
- (void)))
-
-(define (value-get-doc body)
- (let ((first (car body))
- (rest (cdr body)))
- (and (string? first) (cons? rest) first)))
-
-;;; standard procedures
-
-(define (member item lst)
- (cond ((null? lst) #f)
- ((equal? (car lst) item) lst)
- (#t (member item (cdr lst)))))
-(define (memv item lst)
- (cond ((null? lst) #f)
- ((eqv? (car lst) item) lst)
- (#t (memv item (cdr lst)))))
-
-(define (assoc item lst)
- (cond ((null? lst) #f)
- ((equal? (caar lst) item) (car lst))
- (#t (assoc item (cdr lst)))))
-(define (assv item lst)
- (cond ((null? lst) #f)
- ((eqv? (caar lst) item) (car lst))
- (#t (assv item (cdr lst)))))
-
-(define (> a . rest)
- "Return #t if the arguments are in strictly decreasing order (previous
-one is greater than the next one)."
- (let loop ((a a) (rest rest))
- (or (null? rest)
- (and (< (car rest) a)
- (loop (car rest) (cdr rest))))))
-(define-macro (> a . rest)
- `(< ,@(reverse! rest) ,a))
-
-(define (<= a . rest)
- "Return #t if the arguments are in non-decreasing order (previous
-one is less than or equal to the next one)."
- (let loop ((a a) (rest rest))
- (or (null? rest)
- (unless (or (< (car rest) a)
- (nan? a))
- (loop (car rest) (cdr rest))))))
-
-(define (>= a . rest)
- "Return #t if the arguments are in non-increasing order (previous
-one is greater than or equal to the next one)."
- (let loop ((a a) (rest rest))
- (or (null? rest)
- (unless (or (< a (car rest))
- (nan? a))
- (loop (car rest) (cdr rest))))))
-
-(define-macro (/= a . rest)
- "Return #t if not all arguments are equal. Shorthand for (not (= …))."
- `(not (= ,a ,@rest)))
-
-(define (negative? x) (< x 0))
-(define (zero? x) (= x 0))
-(define (positive? x) (> x 0))
-(define (even? x) (= (logand x 1) 0))
-(define (odd? x) (not (even? x)))
-(define (identity x) x)
-(define (1+ n) (+ n 1))
-(define (1- n) (- n 1))
-(define (mod0 x y) (- x (* (div0 x y) y)))
-(define (div x y) (+ (div0 x y)
- (or (and (< x 0)
- (or (and (< y 0) 1)
- -1))
- 0)))
-(define (mod x y) (- x (* (div x y) y)))
-(define (random n)
- (if (integer? n)
- (mod (rand) n)
- (* (rand-double) n)))
-(define (abs x) (if (< x 0) (- x) x))
-(define (max x0 . xs)
- (if (null? xs) x0
- (foldl (λ (a b) (if (< a b) b a)) x0 xs)))
-(define (min x0 . xs)
- (if (null? xs) x0
- (foldl (λ (a b) (if (< a b) a b)) x0 xs)))
-(define (char? x) (eq? (typeof x) 'rune))
-(define (array? x) (or (vector? x)
- (let ((t (typeof x)))
- (and (cons? t) (eq? (car t) 'array)))))
-(define (closure? x) (and (function? x) (not (builtin? x))))
-
-(define (caar x) (car (car x)))
-(define (cdar x) (cdr (car x)))
-(define (cddr x) (cdr (cdr x)))
-(define (caaar x) (car (car (car x))))
-(define (caadr x) (car (car (cdr x))))
-(define (cadar x) (car (cdr (car x))))
-(define (caddr x) (car (cdr (cdr x))))
-(define (cdaar x) (cdr (car (car x))))
-(define (cdadr x) (cdr (car (cdr x))))
-(define (cddar x) (cdr (cdr (car x))))
-(define (cdddr x) (cdr (cdr (cdr x))))
-(define (caaaar x) (car (car (car (car x)))))
-(define (caaadr x) (car (car (car (cdr x)))))
-(define (caadar x) (car (car (cdr (car x)))))
-(define (caaddr x) (car (car (cdr (cdr x)))))
-(define (cadaar x) (car (cdr (car (car x)))))
-(define (cadadr x) (car (cdr (car (cdr x)))))
-(define (caddar x) (car (cdr (cdr (car x)))))
-(define (cadddr x) (car (cdr (cdr (cdr x)))))
-(define (cdaaar x) (cdr (car (car (car x)))))
-(define (cdaadr x) (cdr (car (car (cdr x)))))
-(define (cdadar x) (cdr (car (cdr (car x)))))
-(define (cdaddr x) (cdr (car (cdr (cdr x)))))
-(define (cddaar x) (cdr (cdr (car (car x)))))
-(define (cddadr x) (cdr (cdr (car (cdr x)))))
-(define (cdddar x) (cdr (cdr (cdr (car x)))))
-(define (cddddr x) (cdr (cdr (cdr (cdr x)))))
-
-(let ((*values* (list '*values*)))
- (set! values
- (λ vs
- (if (and (cons? vs) (null? (cdr vs)))
- (car vs)
- (cons *values* vs))))
- (set! call-with-values
- (λ (producer consumer)
- (let ((res (producer)))
- (if (and (cons? res) (eq? *values* (car res)))
- (apply consumer (cdr res))
- (consumer res))))))
-
-;;; list utilities
-
-(define (every pred lst)
- (or (atom? lst)
- (and (pred (car lst))
- (every pred (cdr lst)))))
-
-(define (any pred lst)
- (and (cons? lst)
- (or (pred (car lst))
- (any pred (cdr lst)))))
-
-(define (list? a) (or (null? a) (and (cons? a) (list? (cdr a)))))
-
-(define (list-tail lst n)
- (if (<= n 0) lst
- (list-tail (cdr lst) (- n 1))))
-
-(define (list-head lst n)
- (if (<= n 0) ()
- (cons (car lst)
- (list-head (cdr lst) (- n 1)))))
-
-(define (list-ref lst n)
- (car (list-tail lst n)))
-
-(define (length= lst n)
- "Bounded length test.
-Use this instead of (= (length lst) n), since it avoids unnecessary
-work and always terminates."
- (cond ((< n 0) #f)
- ((= n 0) (atom? lst))
- ((atom? lst) (= n 0))
- (else (length= (cdr lst) (- n 1)))))
-
-(define (length> lst n)
- (cond ((< n 0) lst)
- ((= n 0) (and (cons? lst) lst))
- ((atom? lst) (< n 0))
- (else (length> (cdr lst) (- n 1)))))
-
-(define (last-pair l)
- (if (atom? (cdr l))
- l
- (last-pair (cdr l))))
-
-(define (lastcdr l)
- (if (atom? l)
- l
- (cdr (last-pair l))))
-
-(define (to-proper l)
- (cond ((null? l) l)
- ((atom? l) (list l))
- (else (cons (car l) (to-proper (cdr l))))))
-
-(define (map! f lst)
- (prog1 lst
- (while (cons? lst)
- (set-car! lst (f (car lst)))
- (set! lst (cdr lst)))))
-
-(define (filter pred lst)
- (define (filter- f lst acc)
- (cdr
- (prog1 acc
- (while (cons? lst)
- (when (pred (car lst))
- (set! acc
- (cdr (set-cdr! acc (cons (car lst) ())))))
- (set! lst (cdr lst))))))
- (filter- pred lst (list ())))
-
-(define (partition pred lst)
- (define (partition- pred lst yes no)
- (let ((vals
- (prog1
- (cons yes no)
- (while (cons? lst)
- (if (pred (car lst))
- (set! yes (cdr (set-cdr! yes (cons (car lst) ()))))
- (set! no (cdr (set-cdr! no (cons (car lst) ())))))
- (set! lst (cdr lst))))))
- (values (cdr (car vals)) (cdr (cdr vals)))))
- (partition- pred lst (list ()) (list ())))
-
-(define (count f l)
- (define (count- f l n)
- (if (null? l)
- n
- (count- f (cdr l) (if (f (car l))
- (+ n 1)
- n))))
- (count- f l 0))
-
-(define (nestlist f zero n)
- (if (<= n 0) ()
- (cons zero (nestlist f (f zero) (- n 1)))))
-
-(define (foldr f zero lst)
- (if (null? lst) zero
- (f (car lst) (foldr f zero (cdr lst)))))
-
-(define (foldl f zero lst)
- (if (null? lst) zero
- (foldl f (f (car lst) zero) (cdr lst))))
-
-(define (reverse- zero lst)
- (if (null? lst) zero
- (reverse- (cons (car lst) zero) (cdr lst))))
-
-(define (reverse lst) (reverse- () lst))
-
-(define (reverse!- prev l)
- (while (cons? l)
- (set! l (prog1 (cdr l)
- (set-cdr! l (prog1 prev
- (set! prev l))))))
- prev)
-
-(define (reverse! l) (reverse!- () l))
-
-(define (copy-tree l)
- (if (atom? l) l
- (cons (copy-tree (car l))
- (copy-tree (cdr l)))))
-
-(define (delete-duplicates lst)
- (if (length> lst 20)
- (let ((t (table)))
- (let loop ((l lst) (acc '()))
- (if (atom? l)
- (reverse! acc)
- (if (has? t (car l))
- (loop (cdr l) acc)
- (begin
- (put! t (car l) #t)
- (loop (cdr l) (cons (car l) acc)))))))
- (if (atom? lst)
- lst
- (let ((elt (car lst))
- (tail (cdr lst)))
- (if (member elt tail)
- (delete-duplicates tail)
- (cons elt
- (delete-duplicates tail)))))))
-
-;;; backquote
-
-(define (revappend l1 l2) (reverse- l2 l1))
-(define (nreconc l1 l2) (reverse!- l2 l1))
-
-(define (self-evaluating? x)
- (or (and (atom? x)
- (not (symbol? x)))
- (and (constant? x)
- (symbol? x)
- (eq? x (top-level-value x)))))
-
-(define-macro (quasiquote x) (bq-process x 0))
-
-(define (splice-form? x)
- (or (and (cons? x) (or (eq? (car x) 'unquote-splicing)
- (eq? (car x) 'unquote-nsplicing)
- (and (eq? (car x) 'unquote)
- (length> x 2))))
- (eq? x 'unquote)))
-
-;; bracket without splicing
-(define (bq-bracket1 x d)
- (if (and (cons? x) (eq? (car x) 'unquote))
- (if (= d 0)
- (cadr x)
- (list cons ''unquote
- (bq-process (cdr x) (- d 1))))
- (bq-process x d)))
-
-(define (bq-bracket x d)
- (cond ((atom? x) (list list (bq-process x d)))
- ((eq? (car x) 'unquote)
- (if (= d 0)
- (cons list (cdr x))
- (list list (list cons ''unquote
- (bq-process (cdr x) (- d 1))))))
- ((eq? (car x) 'unquote-splicing)
- (if (= d 0)
- (list 'copy-list (cadr x))
- (list list (list list ''unquote-splicing
- (bq-process (cadr x) (- d 1))))))
- ((eq? (car x) 'unquote-nsplicing)
- (if (= d 0)
- (cadr x)
- (list list (list list ''unquote-nsplicing
- (bq-process (cadr x) (- d 1))))))
- (else (list list (bq-process x d)))))
-
-(define (bq-process x d)
- (cond ((symbol? x) (list 'quote x))
- ((vector? x)
- (let ((body (bq-process (vector->list x) d)))
- (if (eq? (car body) list)
- (cons vector (cdr body))
- (list apply vector body))))
- ((atom? x) x)
- ((eq? (car x) 'quasiquote)
- (list list ''quasiquote (bq-process (cadr x) (+ d 1))))
- ((eq? (car x) 'unquote)
- (if (and (= d 0) (length= x 2))
- (cadr x)
- (list cons ''unquote (bq-process (cdr x) (- d 1)))))
- ((not (any splice-form? x))
- (let ((lc (lastcdr x))
- (forms (map (λ (x) (bq-bracket1 x d)) x)))
- (if (null? lc)
- (cons list forms)
- (if (null? (cdr forms))
- (list cons (car forms) (bq-process lc d))
- (nconc (cons list* forms) (list (bq-process lc d)))))))
- (else
- (let loop ((p x) (q ()))
- (cond ((null? p) ;; proper list
- (cons 'nconc (reverse! q)))
- ((cons? p)
- (cond ((eq? (car p) 'unquote)
- ;; (... . ,x)
- (cons 'nconc
- (nreconc q
- (if (= d 0)
- (cdr p)
- (list (list list ''unquote)
- (bq-process (cdr p)
- (- d 1)))))))
- (else
- (loop (cdr p) (cons (bq-bracket (car p) d) q)))))
- (else
- ;; (... . x)
- (cons 'nconc (reverse! (cons (bq-process p d) q)))))))))
-
-;;; standard macros
-
-(define (quote-value v)
- (if (self-evaluating? v)
- v
- (list 'quote v)))
-
-(define-macro (let* binds . body)
- (if (atom? binds) `((λ () ,@body))
- `((λ (,(caar binds))
- ,@(if (cons? (cdr binds))
- `((let* ,(cdr binds) ,@body))
- body))
- ,(cadar binds))))
-
-(define-macro (when c . body) (list 'if c (cons 'begin body) #f))
-(define-macro (unless c . body) (list 'if c #f (cons 'begin body)))
-
-(define-macro (case key . clauses)
- (define (vals->cond key v)
- (cond ((eq? v 'else) 'else)
- ((null? v) #f)
- ((symbol? v) `(eq? ,key ,(quote-value v)))
- ((atom? v) `(eqv? ,key ,(quote-value v)))
- ((null? (cdr v)) `(eqv? ,key ,(quote-value (car v))))
- ((every symbol? v)
- `(memq ,key ',v))
- (else `(memv ,key ',v))))
- (let ((g (gensym)))
- `(let ((,g ,key))
- (cond ,.(map (λ (clause)
- (cons (vals->cond g (car clause))
- (cdr clause)))
- clauses)))))
-
-(define-macro (do vars test-spec . commands)
- (let ((loop (gensym))
- (test-expr (car test-spec))
- (vars (map car vars))
- (inits (map cadr vars))
- (steps (map (λ (x)
- (if (cons? (cddr x))
- (caddr x)
- (car x)))
- vars)))
- `(letrec ((,loop (λ ,vars
- (if ,test-expr
- (begin
- ,@(cdr test-spec))
- (begin
- ,@commands
- (,loop ,.steps))))))
- (,loop ,.inits))))
-
-; SRFI 8
-(define-macro (receive formals expr . body)
- `(call-with-values (λ () ,expr)
- (λ ,formals ,@body)))
-
-(define-macro (dotimes var . body)
- (let ((v (car var))
- (cnt (cadr var)))
- `(for 0 (- ,cnt 1)
- (λ (,v) ,@body))))
-
-(define (map-int f n)
- (if (<= n 0)
- nil
- (let ((first (cons (f 0) ()))
- (acc ()))
- (set! acc first)
- (for 1 (1- n)
- (λ (i) (set-cdr! acc (cons (f i) ()))
- (set! acc (cdr acc))))
- first)))
-
-(define (iota n) (map-int identity n))
-
-(define-macro (with-bindings binds . body)
- (let ((vars (map car binds))
- (vals (map cadr binds))
- (olds (map (λ (x) (gensym)) binds)))
- `(let ,(map list olds vars)
- ,@(map (λ (v val) `(set! ,v ,val)) vars vals)
- (unwind-protect
- (begin ,@body)
- (begin ,@(map (λ (v old) `(set! ,v ,old)) vars olds))))))
-
-;;; exceptions
-
-(define (error . args) (raise (cons 'error args)))
-
-(define-macro (throw tag value) `(raise (list 'thrown-value ,tag ,value)))
-(define-macro (catch tag expr)
- (let ((e (gensym)))
- `(trycatch ,expr
- (λ (,e) (if (and (cons? ,e)
- (eq? (car ,e) 'thrown-value)
- (eq? (cadr ,e) ,tag))
- (caddr ,e)
- (raise ,e))))))
-
-(define-macro (unwind-protect expr finally)
- (let ((e (gensym))
- (thk (gensym)))
- `(let ((,thk (λ () ,finally)))
- (prog1 (trycatch ,expr
- (λ (,e) (begin (,thk) (raise ,e))))
- (,thk)))))
-
-;;; debugging utilities
-
-(define-macro (assert expr) `(if ,expr #t (raise '(assert-failed ,expr))))
-
-(define traced?
- (letrec ((sample-traced-lambda (λ args (begin (write (cons 'x args))
- (newline)
- (apply #.apply args)))))
- (λ (f)
- (and (closure? f)
- (equal? (function:code f)
- (function:code sample-traced-lambda))))))
-
-(define (trace sym)
- (let* ((func (top-level-value sym))
- (args (gensym)))
- (when (not (traced? func))
- (set-top-level-value! sym
- (eval
- `(λ ,args
- (begin (write (cons ',sym ,args))
- (newline)
- (apply ',func ,args)))))))
- (void))
-
-(define (untrace sym)
- (let ((func (top-level-value sym)))
- (when (traced? func)
- (set-top-level-value! sym
- (aref (function:vals func) 3))))
- (void))
-
-(define-macro (time expr)
- (let ((t0 (gensym)))
- `(let ((,t0 (time-now)))
- (prog1
- ,expr
- (princ "Elapsed time: " (- (time-now) ,t0) " seconds" *linefeed*)))))
-
-;;; text I/O
-
-(define (print . args) (for-each write args))
-(define (princ . args)
- (with-bindings ((*print-readably* #f))
- (for-each write args)))
-
-(define (newline (port *output-stream*))
- (io-write port *linefeed*)
- (void))
-
-(define (io-readline s) (io-readuntil s #\linefeed))
-
-; call f on a stream until the stream runs out of data
-(define (read-all-of f s)
- (let loop ((lines ())
- (curr (f s)))
- (if (io-eof? s)
- (reverse! lines)
- (loop (cons curr lines) (f s)))))
-
-(define (io-readlines s) (read-all-of io-readline s))
-(define (read-all s) (read-all-of read s))
-
-(define (io-readall s)
- (let ((b (buffer)))
- (io-copy b s)
- (iostream->string b)))
-
-(define-macro (with-output-to stream . body)
- `(with-bindings ((*output-stream* ,stream))
- ,@body))
-(define-macro (with-input-from stream . body)
- `(with-bindings ((*input-stream* ,stream))
- ,@body))
-
-;;; vector functions
-
-(define (list->vector l) (apply vector l))
-(define (vector->list v)
- (let ((n (length v))
- (l ()))
- (for 1 n
- (λ (i)
- (set! l (cons (aref v (- n i)) l))))
- l))
-
-(define (vector-map f v)
- (let* ((n (length v))
- (nv (vector-alloc n)))
- (for 0 (- n 1)
- (λ (i)
- (aset! nv i (f (aref v i)))))
- nv))
-
-;;; table functions
-
-(define (table-pairs t)
- (table-foldl (λ (k v z) (cons (cons k v) z))
- () t))
-(define (table-keys t)
- (table-foldl (λ (k v z) (cons k z))
- () t))
-(define (table-values t)
- (table-foldl (λ (k v z) (cons v z))
- () t))
-(define (table-clone t)
- (let ((nt (table)))
- (table-foldl (λ (k v z) (put! nt k v))
- () t)
- nt))
-(define (table-invert t)
- (let ((nt (table)))
- (table-foldl (λ (k v z) (put! nt v k))
- () t)
- nt))
-
-;;; string functions
-
-(define (string-tail s n) (string-sub s n))
-
-(define (string-trim s at-start at-end)
- (define (trim-start s chars i L)
- (if (and (< i L) (string-find chars (string-char s i)))
- (trim-start s chars (1+ i) L)
- i))
- (define (trim-end s chars i)
- (if (and (> i 0) (string-find chars (string-char s (1- i))))
- (trim-end s chars (1- i))
- i))
- (let ((L (string-length s)))
- (string-sub s
- (trim-start s at-start 0 L)
- (trim-end s at-end L))))
-
-(define (string-map f s)
- (let ((b (buffer))
- (n (string-length s)))
- (let ((i 0))
- (while (< i n)
- (begin (io-putc b (f (string-char s i)))
- (set! i (1+ i)))))
- (iostream->string b)))
-
-(define (string-rep s k)
- (cond ((< k 4)
- (cond ((<= k 0) "")
- ((= k 1) (string s))
- ((= k 2) (string s s))
- (else (string s s s))))
- ((odd? k) (string s (string-rep s (- k 1))))
- (else (string-rep (string s s) (/ k 2)))))
-
-(define (string-lpad s n c) (string (string-rep c (- n (string-length s))) s))
-(define (string-rpad s n c) (string s (string-rep c (- n (string-length s)))))
-
-(define (print-to-string v)
- (let ((b (buffer)))
- (write v b)
- (iostream->string b)))
-
-(define (string-join strlist sep)
- (if (null? strlist) ""
- (let ((b (buffer)))
- (io-write b (car strlist))
- (for-each (λ (s) (io-write b sep)
- (io-write b s))
- (cdr strlist))
- (iostream->string b))))
-
-;;; toplevel
-
-(define (macrocall? e) (and (symbol? (car e))
- (symbol-syntax (car e))))
-
-(define (macroexpand-1 e)
- (if (atom? e) e
- (let ((f (macrocall? e)))
- (if f (apply f (cdr e))
- e))))
-
-(define (expand e)
- ; symbol resolves to toplevel; i.e. has no shadowing definition
- (define (top? s env) (not (or (bound? s) (assq s env))))
-
- (define (splice-begin body)
- (cond ((atom? body) body)
- ((equal? body '((begin)))
- body)
- ((and (cons? (car body))
- (eq? (caar body) 'begin))
- (append (splice-begin (cdar body)) (splice-begin (cdr body))))
- (else
- (cons (car body) (splice-begin (cdr body))))))
-
- (define *expanded* (list '*expanded*))
-
- (define (expand-body body env)
- (if (atom? body) body
- (let* ((body (if (top? 'begin env)
- (splice-begin body)
- body))
- (def? (top? 'define env))
- (dvars (if def? (get-defined-vars body) ()))
- (env (nconc (map list dvars) env)))
- (if (not def?)
- (map (λ (x) (expand-in x env)) body)
- (let* ((ex-nondefs ; expand non-definitions
- (let loop ((body body))
- (cond ((atom? body) body)
- ((and (cons? (car body))
- (eq? 'define (caar body)))
- (cons (car body) (loop (cdr body))))
- (else
- (let ((form (expand-in (car body) env)))
- (set! env (nconc
- (map list (get-defined-vars form))
- env))
- (cons
- (cons *expanded* form)
- (loop (cdr body))))))))
- (body ex-nondefs))
- (while (cons? body) ; now expand deferred definitions
- (if (not (eq? *expanded* (caar body)))
- (set-car! body (expand-in (car body) env))
- (set-car! body (cdar body)))
- (set! body (cdr body)))
- ex-nondefs)))))
-
- (define (expand-lambda-list l env)
- (if (atom? l) l
- (cons (if (and (cons? (car l)) (cons? (cdr (car l))))
- (list (caar l) (expand-in (cadar l) env))
- (car l))
- (expand-lambda-list (cdr l) env))))
-
- (define (l-vars l)
- (cond ((atom? l) (list l))
- ((cons? (car l)) (cons (caar l) (l-vars (cdr l))))
- (else (cons (car l) (l-vars (cdr l))))))
-
- (define (expand-lambda e env)
- (let ((formals (cadr e))
- (name (lastcdr e))
- (body (cddr e))
- (vars (l-vars (cadr e))))
- (let ((env (nconc (map list vars) env)))
- `(λ ,(expand-lambda-list formals env)
- ,.(expand-body body env)
- . ,name))))
-
- (define (expand-define e env)
- (if (or (null? (cdr e)) (atom? (cadr e)))
- (if (null? (cddr e))
- e
- (let ((name (cadr e))
- (doc (value-get-doc (cddr e))))
- (when doc
- (set! e (cdr e))
- (symbol-set-doc name doc))
- `(define ,name ,(expand-in (caddr e) env))))
- (let* ((formals (cdadr e))
- (name (caadr e))
- (body (cddr e))
- (doc (value-get-doc body))
- (vars (l-vars formals))
- (menv (nconc (map list vars) env)))
- (when doc
- (set! body (cdr body))
- (symbol-set-doc name doc formals))
- `(define ,(cons name (expand-lambda-list formals menv))
- ,.(expand-body body menv)))))
-
- (define (expand-let-syntax e env)
- (let ((binds (cadr e)))
- (cons 'begin
- (expand-body (cddr e)
- (nconc
- (map (λ (bind)
- (list (car bind)
- ((compile-thunk
- (expand-in (cadr bind) env)))
- env))
- binds)
- env)))))
-
- ; given let-syntax definition environment (menv) and environment
- ; at the point of the macro use (lenv), return the environment to
- ; expand the macro use in. TODO
- (define (local-expansion-env menv lenv) menv)
-
- (define (expand-in e env)
- (if (atom? e) e
- (let* ((head (car e))
- (bnd (assq head env))
- (default (λ ()
- (let loop ((e e))
- (if (atom? e) e
- (cons (if (atom? (car e))
- (car e)
- (expand-in (car e) env))
- (loop (cdr e))))))))
- (cond ((and bnd (cons? (cdr bnd))) ; local macro
- (expand-in (apply (cadr bnd) (cdr e))
- (local-expansion-env (caddr bnd) env)))
- ((macrocall? e) => (λ (f)
- (expand-in (apply f (cdr e)) env)))
- ((or bnd ; bound lexical or toplevel var
- (not (symbol? head))
- (bound? head))
- (default))
- ((eq? head 'quote) e)
- ((eq? head 'λ) (expand-lambda e env))
- ((eq? head 'lambda) (expand-lambda e env))
- ((eq? head 'define) (expand-define e env))
- ((eq? head 'let-syntax) (expand-let-syntax e env))
- (else (default))))))
- (expand-in e ()))
-
-(define (eval x) ((compile-thunk (expand x))))
-
-(define (load-process x) (eval x))
-
-(define (load filename)
- (let ((F (file filename :read)))
- (trycatch
- (let next (prev E v)
- (if (not (io-eof? F))
- (next (read F)
- prev
- (begin (load-process E) (void)))
- (begin (io-close F)
- ; evaluate last form in almost-tail position
- (void (load-process E)))))
- (λ (e)
- (io-close F)
- (raise `(load-error ,filename ,e))))))
-
-(define (repl)
- (define (prompt)
- (*prompt*)
- (io-flush *output-stream*)
- (let ((v (trycatch (read)
- (λ (e) (io-discardbuffer *input-stream*)
- (raise e)))))
- (and (not (io-eof? *input-stream*))
- (let ((V (load-process v)))
- (unless (void? V) (print V) (newline))
- (void (set! that V))))))
- (define (reploop)
- (when (trycatch (prompt)
- (λ (e)
- (top-level-exception-handler e)
- #t))
- (reploop)))
- (reploop)
- (newline))
-
-(define (top-level-exception-handler e)
- (with-output-to *stderr*
- (print-exception e)
- (print-stack-trace (stacktrace))))
-
-(define (print-stack-trace st)
- (define (find-in-f f tgt path)
- (let ((path (cons (function:name f) path)))
- (if (eq? (function:code f) (function:code tgt))
- (throw 'ffound path)
- (let ((v (function:vals f)))
- (for 0 (1- (length v))
- (λ (i) (when (closure? (aref v i))
- (find-in-f (aref v i) tgt path))))))))
- (define (fn-name f e)
- (let ((p (catch 'ffound
- (begin
- (for-each (λ (topfun)
- (find-in-f topfun f ()))
- e)
- #f))))
- (if p
- (string-join (map string (reverse! p)) "/")
- "λ")))
- (let ((st (reverse! (if (length> st 3)
- (list-tail st (if *interactive* 5 4))
- st)))
- (e (filter closure? (map (λ (s) (and (bound? s)
- (top-level-value s)))
- (environment))))
- (n 0))
- (for-each
- (λ (f)
- (princ "(" (fn-name (aref f 1) e))- (for-each (λ (p) (princ " ") (print p))
- (cdr (cdr (vector->list f))))
- (princ ")" *linefeed*)
- (when (= n 0)
- (disassemble (aref f 1) (aref f 0)))
- (set! n (+ n 1)))
- st)))
-
-(define (print-exception e)
- (cond ((and (cons? e)
- (eq? (car e) 'type-error)
- (length= e 3))
- (princ "type error: expected " (cadr e) ", got " (typeof (caddr e)) ": ")
- (print (caddr e)))
-
- ((and (cons? e)
- (eq? (car e) 'bounds-error)
- (length= e 3))
- (princ "index " (caddr e) " out of bounds for ")
- (print (cadr e)))
-
- ((and (cons? e)
- (eq? (car e) 'unbound-error)
- (length= e 2))
- (princ "eval: variable " (cadr e) " has no value"))
-
- ((and (cons? e)
- (eq? (car e) 'error))
- (princ "error: ")
- (apply princ (cdr e)))
-
- ((and (cons? e)
- (eq? (car e) 'load-error))
- (print-exception (caddr e))
- (princ "in file " (cadr e)))
-
- ((and (list? e)
- (length= e 2))
- (print (car e))
- (princ ": ")
- (let ((msg (cadr e)))
- ((if (or (string? msg) (symbol? msg))
- princ print)
- msg)))
-
- (else (princ "*** Unhandled exception: ")
- (print e)))
-
- (princ *linefeed*))
-
-(define (simple-sort l)
- (if (or (null? l) (null? (cdr l))) l
- (let ((piv (car l)))
- (receive (less grtr)
- (partition (λ (x) (< x piv)) (cdr l))
- (nconc (simple-sort less)
- (list piv)
- (simple-sort grtr))))))
-
-(define (make-system-image fname)
- (let ((f (file fname :write :create :truncate))
- (z (file (string fname ".builtin") :write :create :truncate))
- (b (buffer))
- (excludes '(*linefeed* *directory-separator* *argv* that
- *print-pretty* *print-width* *print-readably*
- *print-level* *print-length* *os-name* *interactive*
- *prompt* *os-version*)))
- (with-bindings ((*print-pretty* #t)
- (*print-readably* #t))
- (let* ((syms
- (filter (λ (s)
- (and (bound? s)
- (not (constant? s))
- (or (not (builtin? (top-level-value s)))
- (not (equal? (string s) ; alias of builtin
- (string (top-level-value s)))))
- (not (memq s excludes))
- (not (iostream? (top-level-value s)))))
- (simple-sort (environment))))
- (data (apply nconc (map list syms (map top-level-value syms)))))
- (write data b)
- (write data f)
- (io-write f *linefeed*))
- (let* ((size (sizeof b))
- (packed (lz-pack (iostream->string b) 10))
- (hdr (array 'byte 0
- (logand 0xff size)
- (ash size -8)
- (ash size -16)
- (ash size -24))))
- (io-write z hdr)
- (io-write z packed))
- (io-close f)
- (io-close z))))
-
-; initialize globals that need to be set at load time
-(define (__init_globals)
- (let ((defprompt (if (equal? *os-name* "macos")
- (λ () (princ "\x1b[0m\x1b[1m#;> \x1b[0m"))
- (λ () (princ "#;> ")))))
- (set! *prompt*
- "Function called by REPL to signal the user input is required.
-Default function prints \"#;> \"." defprompt))
- (set! *directory-separator* (or (and (equal? *os-name* "dos") "\\") "/"))
- (set! *linefeed* "\n")
- (set! *output-stream* *stdout*)
- (set! *input-stream* *stdin*)
- (set! *error-stream* *stderr*))
-
-(define (__script fname)
- (trycatch (load fname)
- (λ (e) (begin (top-level-exception-handler e)
- (exit 1)))))
-
-(define (__rcscript)
- (let* ((homevar (case *os-name*
- (("unknown") #f)- (("plan9") "home")- (("macos") (princ "\x1b]0;femtolisp v0.999\007") #f)- (else "HOME")))
- (home (and homevar (os-getenv homevar)))
- (fname (and home (string home *directory-separator* ".flisprc"))))
- (when (and fname (path-exists? fname)) (load fname))))
-
-(define (__start argv)
- (__init_globals)
- (if (cons? (cdr argv))
- (begin (set! *argv* (cdr argv))
- (set! *interactive* #f)
- (__script (cadr argv)))
- (begin (set! *argv* argv)
- (set! *interactive* #t)
- (__rcscript)
- (repl)))
- (exit 0))
-
-#.(load "docs_extra.lsp")
--- a/table.c
+++ /dev/null
@@ -1,208 +1,0 @@
-#include "flisp.h"
-#include "equalhash.h"
-#include "cvalues.h"
-#include "types.h"
-#include "print.h"
-#include "table.h"
-
-#define inline_space sizeof(((htable_t*)nil)->_space)
-
-static void
-print_htable(value_t v, ios_t *f)
-{- htable_t *h = cvalue_data(v);
- size_t i;
- int first = 1;
- fl_print_str(f, "#table(");- for(i = 0; i < h->size; i += 2){- if(h->table[i+1] != HT_NOTFOUND){- if(!first)
- fl_print_str(f, " ");
- fl_print_child(f, (value_t)h->table[i]);
- fl_print_chr(f, ' ');
- fl_print_child(f, (value_t)h->table[i+1]);
- first = 0;
- }
- }
- fl_print_chr(f, ')');
-}
-
-static void
-print_traverse_htable(value_t self)
-{- htable_t *h = cvalue_data(self);
- size_t i;
- for(i = 0; i < h->size; i += 2){- if(h->table[i+1] != HT_NOTFOUND){- print_traverse((value_t)h->table[i]);
- print_traverse((value_t)h->table[i+1]);
- }
- }
-}
-
-static void
-free_htable(value_t self)
-{- htable_t *h = cvalue_data(self);
- htable_free(h);
-}
-
-static void
-relocate_htable(value_t oldv, value_t newv)
-{- htable_t *oldh = cvalue_data(oldv);
- htable_t *h = cvalue_data(newv);
- if(oldh->table == &oldh->_space[0])
- h->table = &h->_space[0];
- h->i = oldh->i;
- for(size_t i = 0; i < h->size; i++){- if(h->table[i] != HT_NOTFOUND)
- h->table[i] = (void*)relocate((value_t)h->table[i]);
- }
-}
-
-static cvtable_t table_vtable = {- print_htable,
- relocate_htable,
- free_htable,
- print_traverse_htable,
-};
-
-bool
-ishashtable(value_t v)
-{- return iscvalue(v) && cv_class(ptr(v)) == FL(tabletype);
-}
-
-fl_purefn
-BUILTIN("table?", tablep)-{- argcount(nargs, 1);
- return ishashtable(args[0]) ? FL_t : FL_f;
-}
-
-htable_t *
-totable(value_t v)
-{- if(!ishashtable(v))
- type_error("table", v);- return cvalue_data(v);
-}
-
-BUILTIN("table", table)-{- size_t cnt = (size_t)nargs;
- if(cnt & 1)
- lerrorf(FL_ArgError, "arguments must come in pairs");
- value_t nt;
- // prevent small tables from being added to finalizer list
- if(cnt <= HT_N_INLINE)
- nt = cvalue_nofinalizer(FL(tabletype), sizeof(htable_t));
- else
- nt = cvalue(FL(tabletype), sizeof(htable_t)-inline_space);
- htable_t *h = cvalue_data(nt);
- htable_new(h, cnt/2);
- size_t i;
- value_t k = FL_nil, arg;
- FOR_ARGS(i, 0, arg, args){- if(i & 1)
- equalhash_put(h, (void*)k, (void*)arg);
- else
- k = arg;
- }
- if(h->table != &h->_space[0] && cnt <= HT_N_INLINE){- cvalue_t *cv = ptr(nt);
- add_finalizer(cv);
- cv->len = sizeof(htable_t) - inline_space;
- }
- return nt;
-}
-
-// (put! table key value)
-BUILTIN("put!", put)-{- argcount(nargs, 3);
- htable_t *h = totable(args[0]);
- void **table0 = h->table;
- equalhash_put(h, (void*)args[1], (void*)args[2]);
- // register finalizer if we outgrew inline space
- if(table0 == &h->_space[0] && h->table != &h->_space[0]){- cvalue_t *cv = ptr(args[0]);
- add_finalizer(cv);
- cv->len = sizeof(htable_t) - inline_space;
- }
- return args[0];
-}
-
-_Noreturn
-static void
-key_error(value_t key)
-{- lerrorf(fl_list2(FL_KeyError, key), "key not found");
-}
-
-// (get table key [default])
-fl_purefn
-BUILTIN("get", get)-{- if(nargs != 3)
- argcount(nargs, 2);
- htable_t *h = totable(args[0]);
- value_t v = (value_t)equalhash_get(h, (void*)args[1]);
- if(v == (value_t)HT_NOTFOUND){- if(nargs == 3)
- return args[2];
- key_error(args[1]);
- }
- return v;
-}
-
-// (has? table key)
-fl_purefn
-BUILTIN("has?", has)-{- argcount(nargs, 2);
- htable_t *h = totable(args[0]);
- return equalhash_has(h, (void*)args[1]) ? FL_t : FL_f;
-}
-
-// (del! table key)
-BUILTIN("del!", del)-{- argcount(nargs, 2);
- htable_t *h = totable(args[0]);
- if(!equalhash_remove(h, (void*)args[1]))
- key_error(args[1]);
- return args[0];
-}
-
-BUILTIN("table-foldl", table_foldl)-{- argcount(nargs, 3);
- value_t f = args[0], zero = args[1], t = args[2];
- htable_t *h = totable(t);
- size_t n = h->size;
- void **table = h->table;
- fl_gc_handle(&f);
- fl_gc_handle(&zero);
- fl_gc_handle(&t);
- for(size_t i = 0; i < n; i += 2){- if(table[i+1] != HT_NOTFOUND){- zero = fl_applyn(3, f, (value_t)table[i], (value_t)table[i+1], zero);
- // reload pointer
- h = cvalue_data(t);
- if(h->size != n)
- lerrorf(FL_EnumerationError, "table modified");
- table = h->table;
- }
- }
- fl_free_gc_handles(3);
- return zero;
-}
-
-void
-table_init(void)
-{- FL_tablesym = symbol("table", false);- FL(tabletype) = define_opaque_type(FL_tablesym, sizeof(htable_t), &table_vtable, nil);
-}
--- a/table.h
+++ /dev/null
@@ -1,3 +1,0 @@
-bool ishashtable(value_t v) fl_purefn;
-htable_t *totable(value_t v) fl_purefn;
-void table_init(void);
--- a/timefuncs.h
+++ /dev/null
@@ -1,7 +1,0 @@
-#pragma once
-
-double sec_realtime(void);
-uint64_t nanosec_monotonic(void);
-void timestring(double s, char *buf, int sz);
-double parsetime(const char *s);
-void sleep_ms(int ms);
--- /dev/null
+++ b/tools/boot2h.sh
@@ -1,0 +1,3 @@
+#!/bin/sh
+set -e
+od -t x1 -v -A n $* | sed -E 's/^[^ ]*[ ]+/ /g;s/[ ]+([^ ]+)/0x\1,/g'
--- /dev/null
+++ b/tools/bootstrap.sh
@@ -1,0 +1,14 @@
+#!/bin/sh
+test -e
+F="$(pwd)/build/flisp"
+test -x $F || { meson setup -Dbuildtype=debug build . && ninja -C build || exit 1; }+test -x $F || { echo no $F found; exit 1; }+cd src && \
+$F ../tools/gen.lsp && \
+cp ../boot/flisp.boot ../boot/flisp.boot.bak && \
+$F ../tools/mkboot0.lsp builtins.lsp instructions.lsp system.lsp compiler.lsp > ../boot/flisp.boot && \
+cp ../boot/flisp.boot ../boot/flisp.boot.builtin && \
+ninja -C ../build && \
+cd ../boot && \
+$F ../tools/mkboot1.lsp && \
+ninja -C ../build || { cp flisp.boot.bak flisp.boot; exit 1; }--- /dev/null
+++ b/tools/builtins2h.sh
@@ -1,0 +1,7 @@
+#!/bin/sh
+set -e
+awk -F '[()]' '\
+ /^fl_.*fn/ {attr=$1; next} \+ /^_Noreturn/ {attr=$1; next} \+ /^BUILTIN[_]?/ {printf "BUILTIN_FN(%s, %s)\n", $2, attr} \+ {attr=""}' $* | sort--- /dev/null
+++ b/tools/disenv.lsp
@@ -1,0 +1,10 @@
+#!/usr/bin/env flisp
+(for-each (lambda (e)
+ (let ((v (top-level-value e)))
+ (when (and (function? v)
+ (not (builtin? v)))
+ (print e)
+ (newline)
+ (disassemble v)
+ (newline))))
+ (environment))
--- /dev/null
+++ b/tools/gen.lsp
@@ -1,0 +1,179 @@
+(define opcodes '(
+ ; C opcode, lisp compiler opcode, arg count, builtin lambda, DOC (NEW)
+ OP_LOADA0 loada0 #f 0 ()
+ OP_LOADA1 loada1 #f 0 ()
+ OP_LOADV loadv #f 0 ()
+ OP_BRF brf #f 0 ()
+ OP_POP pop #f 0 ()
+ OP_CALL call #f 0 ()
+ OP_TCALL tcall #f 0 ()
+ OP_LOADG loadg #f 0 ()
+ OP_LOADA loada #f 0 ()
+ OP_LOADC loadc #f 0 ()
+ OP_RET ret #f 0 ()
+ OP_DUP dup #f 0 ()
+ OP_CAR car 1 (λ (x) (car x)) (
+ ((lst) "Returns the first element of a list or nil if not available."))
+ OP_CDR cdr 1 (λ (x) (cdr x)) (
+ ((lst) "Returns the tail of a list or nil if not available."))
+ OP_CLOSURE closure #f 0 ()
+ OP_SETA seta #f 0 ()
+ OP_JMP jmp #f 0 ()
+ OP_LOADC0 loadc0 #f 0 ()
+ OP_CONSP cons? 1 (λ (x) (cons? x)) (
+ ((value) "Returns #t if the value is a cons cell."))
+ OP_BRNE brne #f 0 ()
+ OP_LOADT loadt #f 0 ()
+ OP_LOAD0 load0 #f 0 ()
+ OP_LOADC1 loadc1 #f 0 ()
+ OP_AREF2 aref2 #f 0 ()
+ OP_ATOMP atom? 1 (λ (x) (atom? x)) ()
+ OP_BRT brt #f 0 ()
+ OP_BRNN brnn #f 0 ()
+ OP_LOAD1 load1 #f 0 ()
+ OP_LT < -1 (λ rest (apply < rest)) ()
+ OP_ADD2 add2 #f 0 ()
+ OP_SETCDR set-cdr! 2 (λ (x y) (set-cdr! x y)) ()
+ OP_LOADF loadf #f 0 ()
+ OP_CONS cons 2 (λ (x y) (cons x y)) ()
+ OP_EQ eq? 2 (λ (x y) (eq? x y)) ()
+ OP_SYMBOLP symbol? 1 (λ (x) (symbol? x)) ()
+ OP_NOT not 1 (λ (x) (not x)) ()
+ OP_CADR cadr 1 (λ (x) (cadr x)) ()
+ OP_NEG neg #f 0 ()
+ OP_NULLP null? 1 (λ (x) (null? x)) ()
+ OP_BOOLEANP boolean? 1 (λ (x) (boolean? x)) ()
+ OP_NUMBERP number? 1 (λ (x) (number? x)) ()
+ OP_FIXNUMP fixnum? 1 (λ (x) (fixnum? x)) ()
+ OP_BOUNDP bound? 1 (λ (x) (bound? x)) ()
+ OP_BUILTINP builtin? 1 (λ (x) (builtin? x)) ()
+ OP_FUNCTIONP function? 1 (λ (x) (function? x)) ()
+ OP_VECTORP vector? 1 (λ (x) (vector? x)) ()
+ OP_SHIFT shift #f 0 ()
+ OP_SETCAR set-car! 2 (λ (x y) (set-car! x y)) ()
+ OP_JMPL jmp.l #f 0 ()
+ OP_BRFL brf.l #f 0 ()
+ OP_BRTL brt.l #f 0 ()
+ OP_EQV eqv? 2 (λ (x y) (eqv? x y)) ()
+ OP_EQUAL equal? 2 (λ (x y) (equal? x y)) ()
+ OP_LIST list ANYARGS (λ rest rest) ()
+ OP_APPLY apply -2 (λ rest (apply apply rest)) ()
+ OP_ADD + ANYARGS (λ rest (apply + rest)) (
+ ((number…) "Return sum of the numbers or 0 with no arguments."))
+ OP_SUB - -1 (λ rest (apply - rest)) ()
+ OP_MUL * ANYARGS (λ rest (apply * rest)) (
+ ((number…) "Return product of the numbers or 1 with no arguments."))
+ OP_DIV / -1 (λ rest (apply / rest)) ()
+ OP_IDIV div0 2 (λ rest (apply div0 rest)) ()
+ OP_NUMEQ = -1 (λ rest (apply = rest)) ()
+ OP_COMPARE compare 2 (λ (x y) (compare x y)) ()
+ OP_ARGC argc #f 0 ()
+ OP_VECTOR vector ANYARGS (λ rest (apply vector rest)) ()
+ OP_ASET aset! -3 (λ rest (apply aset! rest)) ()
+ OP_LOADNIL loadnil #f 0 ()
+ OP_LOADI8 loadi8 #f 0 ()
+ OP_LOADVL loadv.l #f 0 ()
+ OP_LOADGL loadg.l #f 0 ()
+ OP_LOADAL loada.l #f 0 ()
+ OP_LOADCL loadc.l #f 0 ()
+ OP_SETG setg #f 0 ()
+ OP_SETGL setg.l #f 0 ()
+ OP_SETAL seta.l #f 0 ()
+ OP_VARGC vargc #f 0 ()
+ OP_TRYCATCH trycatch #f 0 ()
+ OP_FOR for 3 (λ (a b f) (for a b (λ (x) (f x)))) ()
+ OP_TAPPLY tapply #f 0 ()
+ OP_SUB2 sub2 #f 0 ()
+ OP_LARGC largc #f 0 ()
+ OP_LVARGC lvargc #f 0 ()
+ OP_CALLL call.l #f 0 ()
+ OP_TCALLL tcall.l #f 0 ()
+ OP_BRNEL brne.l #f 0 ()
+ OP_BRNNL brnn.l #f 0 ()
+ OP_BRN brn #f 0 ()
+ OP_BRNL brn.l #f 0 ()
+ OP_OPTARGS optargs #f 0 ()
+ OP_BRBOUND brbound #f 0 ()
+ OP_KEYARGS keyargs #f 0 ()
+ OP_BOX box #f 0 ()
+ OP_BOXL box.l #f 0 ()
+ OP_AREF aref -2 (λ rest (apply aref rest)) ()
+ OP_LOADVOID loadvoid #f 0 ()
+ OP_NANP nan? 1 (λ (x) (nan? x)) ()
+ OP_EOF_OBJECT dummy_eof #f 0 ()
+))
+
+(define (for-each-n f lst n)
+ (when (and (> n 0) (cons? lst))
+ (apply f (list-head lst n))
+ (for-each-n f (list-tail lst n) n)))
+
+(let ((c-header (file "opcodes.h" :write :create :truncate))
+ (c-code (file "opcodes.c" :write :create :truncate))
+ (instructions (file "instructions.lsp" :write :create :truncate))
+ (builtins (file "builtins.lsp" :write :create :truncate))
+ (builtins-doc (file "docs_ops.lsp" :write :create :truncate))
+ (e (table))
+ (cl (table))
+ (ac (table))
+ (lms ())
+ (i 0))
+ (begin
+ (io-write c-header "typedef enum {\n")+ (for-each-n
+ (λ (cop lop argc f docs)
+ (begin
+ (io-write c-header "\t")
+ (write cop c-header)
+ (io-write c-header ",\n")
+ (for-each (λ (doc)
+ (let ((docform (append `(,lop) (car doc))))
+ (write (append `(doc-for ,docform)
+ (list (cadr doc)))
+ builtins-doc)
+ (io-write builtins-doc "\n")))
+ docs)
+ (put! e lop i)
+ (when argc
+ (put! cl cop (list lop argc))
+ (when (and (number? argc) (>= argc 0))
+ (put! ac lop argc)))
+ (set! lms (cons f lms))
+ (set! i (1+ i))))
+ opcodes 5)
+ (io-close builtins-doc)
+ (io-write c-header "\tN_OPCODES\n}opcode_t;\n\n")
+ (io-write c-header "extern const Builtin builtins[N_OPCODES];\n")
+ (io-close c-header)
+ (io-write c-code "#include \"flisp.h\"\n\n")
+ (io-write c-code "const Builtin builtins[N_OPCODES] = {\n")+ (for-each
+ (λ (c la) (begin (io-write c-code "\t[")
+ (write c c-code)
+ (io-write c-code "] = {\"")+ (write (car la) c-code)
+ (io-write c-code "\", ")
+ (write (cadr la) c-code)
+ (io-write c-code "},\n")))
+ cl)
+ (io-write c-code "};\n")
+ (io-close c-code)
+
+ (write `(define Instructions
+ "VM instructions mapped to their encoded byte representation."
+ ,e)
+ instructions)
+ (io-write instructions "\n\n")
+ (write `(define arg-counts
+ "VM instructions mapped to their expected arguments count."
+ ,ac)
+ instructions)
+ (io-write instructions "\n")
+ (io-close instructions)
+ (set! lms (cons vector (reverse! lms)))
+ (write `(define *builtins*
+ "VM instructions as closures."
+ ,lms)
+ builtins)
+ (io-write builtins "\n")
+ (io-close builtins)))
--- /dev/null
+++ b/tools/mkboot0.lsp
@@ -1,0 +1,30 @@
+; -*- scheme -*-
+
+(define update-compiler
+ (let ((C ()))
+ (with-bindings
+ ((eval (λ (x) (set! C (cons (compile-thunk (expand x)) C)))))
+ (begin
+ (load "instructions.lsp")
+ (load "compiler.lsp")))
+ (λ () (begin
+ (for-each (λ (x) (x)) (reverse! C))
+ (set! update-compiler (λ () ()))))))
+
+(define (compile-file inf)
+ (let ((in (file inf :read)))
+ (let next ((E (read in)))
+ (if (not (io-eof? in))
+ (begin
+ (print (compile-thunk (expand E)))
+ (newline)
+ (next (read in)))))
+ (io-close in)))
+
+(define (do-boot0)
+ (for-each (λ (file)
+ (compile-file file))
+ (cdr *argv*)))
+
+(update-compiler)
+(do-boot0)
--- /dev/null
+++ b/tools/mkboot1.lsp
@@ -1,0 +1,9 @@
+; -*- scheme -*-
+
+(load "../src/builtins.lsp")
+(load "../src/instructions.lsp")
+(load "../src/system.lsp")
+#.(load "../src/docs_extra.lsp")
+#.(load "../src/docs_ops.lsp")
+(load "../src/compiler.lsp")
+(make-system-image "flisp.boot")
--- /dev/null
+++ b/tools/ops2h.sh
@@ -1,0 +1,3 @@
+#!/bin/sh
+set -e
+sed -nE 's/.*(OP_[A-Z0-9]+).*/GOTO_OP_OFFSET(\1),/p' $* | sort -u
--- a/types.c
+++ /dev/null
@@ -1,94 +1,0 @@
-#include "flisp.h"
-#include "cvalues.h"
-#include "equalhash.h"
-#include "types.h"
-
-fltype_t *
-get_type(value_t t)
-{- fltype_t *ft;
- if(issymbol(t)){- ft = ((symbol_t*)ptr(t))->type;
- if(ft != nil)
- return ft;
- }
- void **bp = equalhash_bp(&FL(TypeTable), (void*)t);
- if(*bp != HT_NOTFOUND){- assert(*bp != nil);
- return *bp;
- }
-
- bool isarray = iscons(t) && car_(t) == FL_arraysym && iscons(cdr_(t));
- size_t sz;
- if(isarray && !iscons(cdr_(cdr_(t)))){- // special case: incomplete array type
- sz = 0;
- }else{- sz = ctype_sizeof(t);
- }
-
- ft = MEM_CALLOC(1, sizeof(fltype_t));
- assert(ft != nil);
- ft->type = t;
- ft->numtype = NONNUMERIC;
- if(issymbol(t)){- ft->numtype = sym_to_numtype(t);
- assert(valid_numtype(ft->numtype));
- ((symbol_t*)ptr(t))->type = ft;
- }
- ft->size = sz;
- if(iscons(t)){- if(isarray){- fltype_t *eltype = get_type(car_(cdr_(t)));
- assert(eltype != nil);
- if(eltype->size == 0){- MEM_FREE(ft);
- lerrorf(FL_ArgError, "invalid array element type");
- }
- ft->elsz = eltype->size;
- ft->eltype = eltype;
- ft->init = cvalue_array_init;
- //eltype->artype = ft; -- this is a bad idea since some types carry array sizes
- }
- }
- *bp = ft;
- return ft;
-}
-
-fltype_t *
-get_array_type(value_t eltype)
-{- fltype_t *et = get_type(eltype);
- if(et->artype == nil)
- et->artype = get_type(fl_list2(FL_arraysym, eltype));
- return et->artype;
-}
-
-fltype_t *
-define_opaque_type(value_t sym, size_t sz, cvtable_t *vtab, cvinitfunc_t init)
-{- fltype_t *ft = MEM_CALLOC(1, sizeof(fltype_t));
- assert(ft != nil);
- ft->type = sym;
- ft->numtype = NONNUMERIC;
- ft->size = sz;
- ft->vtable = vtab;
- ft->init = init;
- return ft;
-}
-
-void
-relocate_typetable(void)
-{- htable_t *h = &FL(TypeTable);
- size_t i;
- void *nv;
- for(i = 0; i < h->size; i += 2){- if(h->table[i] != HT_NOTFOUND){- nv = (void*)relocate((value_t)h->table[i]);
- h->table[i] = nv;
- if(h->table[i+1] != HT_NOTFOUND)
- ((fltype_t*)h->table[i+1])->type = (value_t)nv;
- }
- }
-}
--- a/types.h
+++ /dev/null
@@ -1,6 +1,0 @@
-#pragma once
-
-fltype_t *get_type(value_t t);
-fltype_t *get_array_type(value_t eltype);
-fltype_t *define_opaque_type(value_t sym, size_t sz, cvtable_t *vtab, cvinitfunc_t init);
-void relocate_typetable(void);
--- a/utf8.c
+++ /dev/null
@@ -1,319 +1,0 @@
-/*
- Basic UTF-8 manipulation routines
- by Jeff Bezanson
- placed in the public domain Fall 2005
-
- This code is designed to provide the utilities you need to manipulate
- UTF-8 as an internal string encoding. These functions do not perform the
- error checking normally needed when handling UTF-8 data, so if you happen
- to be from the Unicode Consortium you will want to flay me alive.
- I do this because error checking can be performed at the boundaries (I/O),
- with these routines reserved for higher performance on data known to be
- valid.
- A UTF-8 validation routine is included.
-*/
-
-#include "flisp.h"
-
-static const uint32_t offsetsFromUTF8[6] = {- 0x00000000U, 0x00003080U, 0x000E2080U,
- 0x03C82080U, 0xFA082080U, 0x82082080U
-};
-
-static const char trailingBytesForUTF8[256] = {- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
- 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
- 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 3,3,3,3,3,3,3,3,4,4,4,4,5,5,5,5
-};
-
-// straight from musl
-int
-u8_iswprint(Rune c)
-{- if(c < 0xff)
- return ((c+1) & 0x7f) >= 0x21;
- if(c < 0x2028 || c-0x202a < 0xd800-0x202a || c-0xe000 < 0xfff9-0xe000)
- return 1;
- return !(c-0xfffc > Runemax-0xfffc || (c&0xfffe) == 0xfffe);
-}
-
-/* returns length of next utf-8 sequence */
-size_t
-u8_seqlen(const char *s)
-{- return trailingBytesForUTF8[(uint8_t)s[0]] + 1;
-}
-
-/* byte offset => charnum */
-size_t
-u8_charnum(const char *s, size_t offset)
-{- size_t charnum = 0, i = 0;
-
- while(i < offset){- if((s[i++] & 0x80) != 0 && !isutf(s[++i]) && !isutf(s[++i]))
- i++;
- charnum++;
- }
- return charnum;
-}
-
-size_t
-u8_strwidth(const char *s)
-{- size_t i, w;
- Rune r;
-
- for(i = w = 0; s[i];){- i += chartorune(&r, s+i);
- w += wcwidth(r);
- }
- return w;
-}
-
-/* next character without NUL character terminator */
-Rune
-u8_nextmemchar(const char *s, size_t *i)
-{- size_t sz = trailingBytesForUTF8[(uint8_t)s[*i]];
- Rune ch = 0;
- for(size_t j = 0; j <= sz; j++){- ch <<= 6;
- ch += (uint8_t)s[(*i)++];
- };
- return ch - offsetsFromUTF8[sz];
-}
-
-bool
-octal_digit(char c)
-{- return c >= '0' && c <= '7';
-}
-
-bool
-hex_digit(char c)
-{- return (c >= '0' && c <= '9') || (c >= 'a' && c <= 'f') || (c >= 'A' && c <= 'F');
-}
-
-char
-read_escape_control_char(char c)
-{- switch(c){- case 'n': return '\n';
- case 't': return '\t';
- case 'a': return '\a';
- case 'b': return '\b';
- case 'e': return 0x1b;
- case 'f': return '\f';
- case 'r': return '\r';
- case 'v': return '\v';
- }
- return c;
-}
-
-static inline int
-buf_put2c(char *buf, const char *src)
-{- buf[0] = src[0];
- buf[1] = src[1];
- buf[2] = '\0';
- return 2;
-}
-
-int
-u8_escape_rune(char *buf, size_t sz, Rune ch)
-{- assert(sz > 12);
- if(ch >= 0x20 && ch < 0x7f){- buf[0] = ch;
- buf[1] = '\0';
- return 1;
- }
- if(ch > 0xffff)
- return snprintf(buf, sz, "\\U%.8"PRIx32, ch);
- if(ch >= Runeself)
- return snprintf(buf, sz, "\\u%04"PRIx32, ch);
- switch(ch){- case '\n': return buf_put2c(buf, "\\n");
- case '\t': return buf_put2c(buf, "\\t");
- case '\\': return buf_put2c(buf, "\\\\");
- case '\a': return buf_put2c(buf, "\\a");
- case '\b': return buf_put2c(buf, "\\b");
- case 0x1b: return buf_put2c(buf, "\\e");
- case '\f': return buf_put2c(buf, "\\f");
- case '\r': return buf_put2c(buf, "\\r");
- case '\v': return buf_put2c(buf, "\\v");
- }
- return snprintf(buf, sz, "\\x%02"PRIx32, ch);
-}
-
-size_t
-u8_escape(char *buf, size_t sz, const char *src, size_t *pi, size_t end, bool escape_quotes, bool ascii)
-{- size_t i = *pi, i0;
- Rune ch;
- char *start = buf;
- char *blim = start + sz-11;
- assert(sz > 11);
-
- while(i < end && buf < blim){- // sz-11: leaves room for longest escape sequence
- if(escape_quotes && src[i] == '"'){- buf += buf_put2c(buf, "\\\"");
- i++;
- }else if(src[i] == '\\'){- buf += buf_put2c(buf, "\\\\");
- i++;
- }else{- i0 = i;
- ch = u8_nextmemchar(src, &i);
- if(ascii || !u8_iswprint(ch)){- buf += u8_escape_rune(buf, sz - (buf-start), ch);
- }else{- i = i0;
- do{- *buf++ = src[i++];
- }while(!isutf(src[i]));
- }
- }
- }
- *buf++ = '\0';
- *pi = i;
- return buf - start;
-}
-
-char *
-u8_memchr(char *s, Rune ch, size_t sz, size_t *charn)
-{- size_t i = 0, lasti = 0;
- Rune c;
- int csz;
-
- *charn = 0;
- while(i < sz){- c = csz = 0;
- do{- c <<= 6;
- c += (uint8_t)s[i++];
- csz++;
- }while(i < sz && !isutf(s[i]));
- c -= offsetsFromUTF8[csz-1];
-
- if(c == ch)
- return (char*)&s[lasti];
- lasti = i;
- (*charn)++;
- }
- return nil;
-}
-
-/* based on the valid_utf8 routine from the PCRE library by Philip Hazel
-
- length is in bytes, since without knowing whether the string is valid
- it's hard to know how many characters there are! */
-int
-u8_isvalid(const char *str, int length)
-{- const uint8_t *p, *pend = (const uint8_t*)str + length;
- uint8_t c;
- int ab;
-
- for(p = (const uint8_t*)str; p < pend; p++){- c = *p;
- if(c < 128)
- continue;
- if((c & 0xc0) != 0xc0)
- return 0;
- ab = trailingBytesForUTF8[c];
- if(length < ab)
- return 0;
- length -= ab;
-
- p++;
- /* Check top bits in the second byte */
- if((*p & 0xc0) != 0x80)
- return 0;
-
- /* Check for overlong sequences for each different length */
- switch(ab){- /* Check for xx00 000x */
- case 1:
- if((c & 0x3e) == 0)
- return 0;
- continue; /* We know there aren't any more bytes to check */
-
- /* Check for 1110 0000, xx0x xxxx */
- case 2:
- if(c == 0xe0 && (*p & 0x20) == 0)
- return 0;
- break;
-
- /* Check for 1111 0000, xx00 xxxx */
- case 3:
- if(c == 0xf0 && (*p & 0x30) == 0)
- return 0;
- break;
-
- /* Check for 1111 1000, xx00 0xxx */
- case 4:
- if(c == 0xf8 && (*p & 0x38) == 0)
- return 0;
- break;
-
- /* Check for leading 0xfe or 0xff and then for 1111 1100, xx00 00xx */
- case 5:
- if(c == 0xfe || c == 0xff || (c == 0xfc && (*p & 0x3c) == 0))
- return 0;
- break;
- }
-
- /* Check for valid bytes after the 2nd, if any; all must start 10 */
- while(--ab > 0)
- if((*(++p) & 0xc0) != 0x80)
- return 0;
- }
-
- return 1;
-}
-
-int
-u8_reverse(char *dest, char *src, size_t len)
-{- size_t si, di;
-
- dest[di = len] = '\0';
- for(si = 0; si < len;){- switch((uint8_t)src[si]>>4){- case 0xf:
- di -= 4;
- dest[di+0] = src[si++];
- dest[di+1] = src[si++];
- dest[di+2] = src[si++];
- dest[di+3] = src[si++];
- break;
- case 0xe:
- di -= 3;
- dest[di+0] = src[si++];
- dest[di+1] = src[si++];
- dest[di+2] = src[si++];
- break;
- case 0xd:
- case 0xc:
- di -= 2;
- dest[di+0] = src[si++];
- dest[di+1] = src[si++];
- break;
- default:
- di--;
- dest[di+0] = src[si++];
- break;
- }
- }
- return 0;
-}
--- a/utf8.h
+++ /dev/null
@@ -1,58 +1,0 @@
-#pragma once
-
-/* is c the start of a utf8 sequence? */
-#define isutf(c) (((c)&0xC0) != 0x80)
-
-int u8_iswprint(Rune c) fl_constfn;
-
-/* byte offset to character number */
-size_t u8_charnum(const char *s, size_t offset) fl_purefn;
-
-/* next character without NUL character terminator */
-Rune u8_nextmemchar(const char *s, size_t *i);
-
-/* returns length of next utf-8 sequence */
-size_t u8_seqlen(const char *s) fl_purefn;
-
-char read_escape_control_char(char c) fl_constfn;
-
-/* given a wide character, convert it to an ASCII escape sequence stored in
- buf, where buf is "sz" bytes. returns the number of characters output.
- sz must be at least 3. */
-int u8_escape_rune(char *buf, size_t sz, Rune ch);
-
-/* convert UTF-8 "src" to escape sequences.
-
- sz is buf size in bytes. must be at least 12.
-
- if escape_quotes is nonzero, quote characters will be escaped.
-
- if ascii is nonzero, the output is 7-bit ASCII, no UTF-8 survives.
-
- starts at src[*pi], updates *pi to point to the first unprocessed
- byte of the input.
-
- end is one more than the last allowable value of *pi.
-
- returns number of bytes placed in buf, including a NUL terminator.
-*/
-size_t u8_escape(char *buf, size_t sz, const char *src, size_t *pi, size_t end,
- bool escape_quotes, bool ascii);
-
-/* utility predicates used by the above */
-bool octal_digit(char c) fl_constfn;
-bool hex_digit(char c) fl_constfn;
-
-/* same as the above, but searches a buffer of a given size instead of
- a NUL-terminated string. */
-char *u8_memchr(char *s, Rune ch, size_t sz, size_t *charn);
-
-/* number of columns occupied by a string */
-size_t u8_strwidth(const char *s) fl_purefn;
-
-/* determine whether a sequence of bytes is valid UTF-8. length is in bytes */
-int u8_isvalid(const char *str, int length) fl_purefn;
-
-/* reverse a UTF-8 string. len is length in bytes. dest and src must both
- be allocated to at least len+1 bytes. returns 1 for error, 0 otherwise */
-int u8_reverse(char *dest, char *src, size_t len);
--- a/vm.inc
+++ /dev/null
@@ -1,938 +1,0 @@
-OP(OP_LOADA0)
- PUSH(FL(stack)[bp]);
- NEXT_OP;
-
-OP(OP_LOADA1)
- PUSH(FL(stack)[bp+1]);
- NEXT_OP;
-
-OP(OP_LOADV)
- v = fn_vals(FL(stack)[bp-1]);
- assert(*ip < vector_size(v));
- PUSH(vector_elt(v, *ip++));
- NEXT_OP;
-
-OP(OP_BRF)
- ip += POP() != FL_f ? 2 : GET_INT16(ip);
- NEXT_OP;
-
-OP(OP_POP)
- POPN(1);
- NEXT_OP;
-
-OP(OP_TCALLL)
- tail = true;
- if(0){-OP(OP_CALLL)
- tail = false;
- }
- n = GET_INT32(ip);
- ip += 4;
- if(0){-OP(OP_TCALL)
- tail = true;
- if(0){-OP(OP_CALL)
- tail = false;
- }
- n = *ip++; // nargs
- }
-LABEL(do_call):
- FL(stack)[ipd] = (uintptr_t)ip;
- func = FL(stack)[FL(sp)-n-1];
- if(tag(func) == TAG_FUNCTION){- if(func > (N_BUILTINS<<3)){- if(tail){- FL(curr_frame) = FL(stack)[FL(curr_frame)-3];
- for(s = -1; s < (fixnum_t)n; s++)
- FL(stack)[bp+s] = FL(stack)[FL(sp)-n+s];
- FL(sp) = bp+n;
- }
- nargs = n;
- goto apply_cl_top;
- }else{- i = uintval(func);
- if(isbuiltin(func)){- s = builtins[i].nargs;
- if(s >= 0)
- argcount(n, (unsigned)s);
- else if(s != ANYARGS && (signed)n < -s)
- argcount(n, (unsigned)-s);
- // remove function arg
- for(s = FL(sp)-n-1; s < (int)FL(sp)-1; s++)
- FL(stack)[s] = FL(stack)[s+1];
- FL(sp)--;
- switch(i){- case OP_LIST: goto LABEL(apply_list);
- case OP_VECTOR: goto LABEL(apply_vector);
- case OP_APPLY: goto LABEL(apply_apply);
- case OP_ADD: goto LABEL(apply_add);
- case OP_SUB: goto LABEL(apply_sub);
- case OP_MUL: goto LABEL(apply_mul);
- case OP_DIV: goto LABEL(apply_div);
- case OP_AREF: goto LABEL(apply_aref);
- case OP_ASET: goto LABEL(apply_aset);
- case OP_LT: goto LABEL(apply_lt);
- case OP_NUMEQ: goto LABEL(apply_numeq);
- default:
-#if defined(COMPUTED_GOTO)
- goto *ops[i];
-#else
- op = i;
- continue;
-#endif
- }
- }
- }
- }else if(fl_likely(iscbuiltin(func))){- s = FL(sp) - n;
- v = (((builtin_t*)ptr(func))[3])(&FL(stack)[s], n);
- FL(sp) = s;
- FL(stack)[s-1] = v;
- NEXT_OP;
- }
- type_error("function", func);-
-OP(OP_LOADGL)
- v = fn_vals(FL(stack)[bp-1]);
- v = vector_elt(v, GET_INT32(ip));
- ip += 4;
- if(0){-OP(OP_LOADG)
- v = fn_vals(FL(stack)[bp-1]);
- assert(*ip < vector_size(v));
- v = vector_elt(v, *ip);
- ip++;
- }
- assert(issymbol(v));
- sym = (symbol_t*)ptr(v);
- if(fl_unlikely(sym->binding == UNBOUND)){- FL(stack)[ipd] = (uintptr_t)ip;
- unbound_error(v);
- }
- PUSH(sym->binding);
- NEXT_OP;
-
-OP(OP_LOADA)
- i = *ip++;
- v = FL(stack)[bp+i];
- PUSH(v);
- NEXT_OP;
-
-OP(OP_LOADC)
- i = *ip++;
- v = FL(stack)[bp+nargs];
- assert(isvector(v));
- assert(i < vector_size(v));
- PUSH(vector_elt(v, i));
- NEXT_OP;
-
-OP(OP_BOX)
- i = *ip++;
- v = mk_cons();
- car_(v) = FL(stack)[bp+i];
- cdr_(v) = FL_nil;
- FL(stack)[bp+i] = v;
- NEXT_OP;
-
-OP(OP_BOXL)
- i = GET_INT32(ip); ip += 4;
- v = mk_cons();
- car_(v) = FL(stack)[bp+i];
- cdr_(v) = FL_nil;
- FL(stack)[bp+i] = v;
- NEXT_OP;
-
-OP(OP_SHIFT)
- i = *ip++;
- FL(stack)[FL(sp)-1-i] = FL(stack)[FL(sp)-1];
- FL(sp) -= i;
- NEXT_OP;
-
-OP(OP_RET)
- v = POP();
- FL(sp) = FL(curr_frame);
- FL(curr_frame) = FL(stack)[FL(sp)-3];
- if(FL(curr_frame) == top_frame)
- return v;
- FL(sp) -= 4+nargs;
- ipd = FL(curr_frame)-1;
- ip = (uint8_t*)FL(stack)[ipd];
- nargs = FL(stack)[FL(curr_frame)-2];
- bp = FL(curr_frame) - 4 - nargs;
- FL(stack)[FL(sp)-1] = v;
- NEXT_OP;
-
-OP(OP_DUP)
- FL(stack)[FL(sp)] = FL(stack)[FL(sp)-1];
- FL(sp)++;
- NEXT_OP;
-
-OP(OP_CAR)
- v = FL(stack)[FL(sp)-1];
- if(fl_likely(iscons(v)))
- v = car_(v);
- else if(fl_unlikely(v != FL_nil)){- FL(stack)[ipd] = (uintptr_t)ip;
- type_error("cons", v);- }
- FL(stack)[FL(sp)-1] = v;
- NEXT_OP;
-
-OP(OP_CDR)
- v = FL(stack)[FL(sp)-1];
- if(fl_likely(iscons(v)))
- v = cdr_(v);
- else if(fl_unlikely(v != FL_nil)){- FL(stack)[ipd] = (uintptr_t)ip;
- type_error("cons", v);- }
- FL(stack)[FL(sp)-1] = v;
- NEXT_OP;
-
-OP(OP_CLOSURE)
- n = *ip++;
- assert(n > 0);
- pv = alloc_words(n + 1);
- v = tagptr(pv, TAG_VECTOR);
- i = 0;
- pv[i++] = fixnum(n);
- do{- pv[i] = FL(stack)[FL(sp)-n + i-1];
- i++;
- }while(i <= n);
- POPN(n);
- PUSH(v);
- if(fl_unlikely((value_t*)FL(curheap) > (value_t*)FL(lim)-2))
- fl_gc(0);
- pv = (value_t*)FL(curheap);
- FL(curheap) += 4*sizeof(value_t);
- e = FL(stack)[FL(sp)-2]; // closure to copy
- assert(isfunction(e));
- pv[0] = ((value_t*)ptr(e))[0];
- pv[1] = ((value_t*)ptr(e))[1];
- pv[2] = FL(stack)[FL(sp)-1]; // env
- pv[3] = ((value_t*)ptr(e))[3];
- POPN(1);
- FL(stack)[FL(sp)-1] = tagptr(pv, TAG_FUNCTION);
- NEXT_OP;
-
-OP(OP_SETA)
- v = FL(stack)[FL(sp)-1];
- i = *ip++;
- FL(stack)[bp+i] = v;
- NEXT_OP;
-
-OP(OP_JMP)
- ip += GET_INT16(ip);
- NEXT_OP;
-
-OP(OP_LOADC0)
- PUSH(vector_elt(FL(stack)[bp+nargs], 0));
- NEXT_OP;
-
-OP(OP_CONSP)
- FL(stack)[FL(sp)-1] = iscons(FL(stack)[FL(sp)-1]) ? FL_t : FL_f;
- NEXT_OP;
-
-OP(OP_BRNE)
- ip += FL(stack)[FL(sp)-2] != FL(stack)[FL(sp)-1] ? GET_INT16(ip) : 2;
- POPN(2);
- NEXT_OP;
-
-OP(OP_LOADT)
- PUSH(FL_t);
- NEXT_OP;
-
-OP(OP_LOADVOID)
- PUSH(FL_void);
- NEXT_OP;
-
-OP(OP_LOAD0)
- PUSH(fixnum(0));
- NEXT_OP;
-
-OP(OP_LOADC1)
- PUSH(vector_elt(FL(stack)[bp+nargs], 1));
- NEXT_OP;
-
-OP(OP_AREF2)
- n = 2;
- if(0){-OP(OP_AREF)
- FL(stack)[ipd] = (uintptr_t)ip;
- n = 3 + *ip++;
- }
-LABEL(apply_aref):
- v = FL(stack)[FL(sp)-n];
- for(i = n-1; i > 0; i--){- if(isarray(v)){- FL(stack)[FL(sp)-i-1] = v;
- v = cvalue_array_aref(&FL(stack)[FL(sp)-i-1]);
- continue;
- }
- e = FL(stack)[FL(sp)-i];
- isz = tosize(e);
- if(isvector(v)){- if(fl_unlikely(isz >= vector_size(v)))
- bounds_error(v, e);
- v = vector_elt(v, isz);
- continue;
- }
- if(!iscons(v) && v != FL_nil)
- type_error("sequence", v);- for(value_t v0 = v;; isz--){- if(isz == 0){- v = car_(v);
- break;
- }
- v = cdr_(v);
- if(fl_unlikely(!iscons(v)))
- bounds_error(v0, e);
- }
- }
- POPN(n);
- PUSH(v);
- NEXT_OP;
-
-OP(OP_ATOMP)
- FL(stack)[FL(sp)-1] = iscons(FL(stack)[FL(sp)-1]) ? FL_f : FL_t;
- NEXT_OP;
-
-OP(OP_BRT)
- ip += POP() != FL_f ? GET_INT16(ip) : 2;
- NEXT_OP;
-
-OP(OP_BRNN)
- ip += POP() != FL_nil ? GET_INT16(ip) : 2;
- NEXT_OP;
-
-OP(OP_LOAD1)
- PUSH(fixnum(1));
- NEXT_OP;
-
-OP(OP_LT)
- n = *ip++;
-LABEL(apply_lt):
- {- i = n;
- value_t a = FL(stack)[FL(sp)-i], b;
- for(v = FL_t; i > 1; a = b){- i--;
- b = FL(stack)[FL(sp)-i];
- if(bothfixnums(a, b)){- if((fixnum_t)a >= (fixnum_t)b){- v = FL_f;
- break;
- }
- }else{- x = numeric_compare(a, b, false, false, false);
- if(x > 1)
- x = numval(fl_compare(a, b, false));
- if(x >= 0){- v = FL_f;
- break;
- }
- }
- }
- POPN(n);
- PUSH(v);
- }
- NEXT_OP;
-
-OP(OP_ADD2)
-LABEL(do_add2):
- FL(stack)[ipd] = (uintptr_t)ip;
- if(0){-OP(OP_SUB2)
-LABEL(do_sub2):
- FL(stack)[ipd] = (uintptr_t)ip;
- FL(stack)[FL(sp)-1] = fl_neg(FL(stack)[FL(sp)-1]);
- }
- {- value_t a, b, q;
- a = FL(stack)[FL(sp)-2];
- b = FL(stack)[FL(sp)-1];
- if(bothfixnums(a, b) && !sadd_overflow(numval(a), numval(b), &q) && fits_fixnum(q)){- v = fixnum(q);
- }else{- v = fl_add_any(&FL(stack)[FL(sp)-2], 2);
- }
- }
- POPN(1);
- FL(stack)[FL(sp)-1] = v;
- NEXT_OP;
-
-OP(OP_SETCDR)
- v = FL(stack)[FL(sp)-2];
- if(fl_unlikely(!iscons(v))){- FL(stack)[ipd] = (uintptr_t)ip;
- type_error("cons", v);- }
- cdr_(v) = FL(stack)[FL(sp)-1];
- POPN(1);
- NEXT_OP;
-
-OP(OP_LOADF)
- PUSH(FL_f);
- NEXT_OP;
-
-OP(OP_CONS)
- if(FL(curheap) > FL(lim))
- fl_gc(0);
- c = (cons_t*)FL(curheap);
- FL(curheap) += sizeof(cons_t);
- c->car = FL(stack)[FL(sp)-2];
- c->cdr = FL(stack)[FL(sp)-1];
- FL(stack)[FL(sp)-2] = tagptr(c, TAG_CONS);
- POPN(1);
- NEXT_OP;
-
-OP(OP_EQ)
- FL(stack)[FL(sp)-2] = FL(stack)[FL(sp)-2] == FL(stack)[FL(sp)-1] ? FL_t : FL_f;
- POPN(1);
- NEXT_OP;
-
-OP(OP_SYMBOLP)
- FL(stack)[FL(sp)-1] = issymbol(FL(stack)[FL(sp)-1]) ? FL_t : FL_f;
- NEXT_OP;
-
-OP(OP_NOT)
- FL(stack)[FL(sp)-1] = FL(stack)[FL(sp)-1] == FL_f ? FL_t : FL_f;
- NEXT_OP;
-
-OP(OP_CADR)
- v = FL(stack)[FL(sp)-1];
- if(fl_likely(iscons(v))){- v = cdr_(v);
- if(fl_likely(iscons(v)))
- v = car_(v);
- else
- goto LABEL(cadr_nil);
- }else{-LABEL(cadr_nil):
- if(fl_unlikely(v != FL_nil)){- FL(stack)[ipd] = (uintptr_t)ip;
- type_error("cons", v);- }
- }
- FL(stack)[FL(sp)-1] = v;
- NEXT_OP;
-
-OP(OP_NEG)
-LABEL(do_neg):
- FL(stack)[ipd] = (uintptr_t)ip;
- FL(stack)[FL(sp)-1] = fl_neg(FL(stack)[FL(sp)-1]);
- NEXT_OP;
-
-OP(OP_NANP)
- {- value_t q = FL(stack)[FL(sp)-1];
- v = FL_f;
- if(iscprim(q)){- void *data = cp_data(ptr(q));
- switch(cp_numtype(ptr(q))){- case T_DOUBLE:
- if(isnan(*(double*)data))
- v = FL_t;
- break;
- case T_FLOAT:
- if(isnan(*(float*)data))
- v = FL_t;
- break;
- default:
- break;
- }
- }
- FL(stack)[FL(sp)-1] = v;
- }
- NEXT_OP;
-
-OP(OP_NULLP)
- FL(stack)[FL(sp)-1] = FL(stack)[FL(sp)-1] == FL_nil ? FL_t : FL_f;
- NEXT_OP;
-
-OP(OP_BOOLEANP)
- v = FL(stack)[FL(sp)-1];
- FL(stack)[FL(sp)-1] = (v == FL_t || v == FL_f) ? FL_t : FL_f;
- NEXT_OP;
-
-OP(OP_NUMBERP)
- v = FL(stack)[FL(sp)-1];
- FL(stack)[FL(sp)-1] = fl_isnumber(v) ? FL_t : FL_f;
- NEXT_OP;
-
-OP(OP_FIXNUMP)
- FL(stack)[FL(sp)-1] = isfixnum(FL(stack)[FL(sp)-1]) ? FL_t : FL_f;
- NEXT_OP;
-
-OP(OP_BOUNDP)
- FL(stack)[ipd] = (uintptr_t)ip;
- sym = tosymbol(FL(stack)[FL(sp)-1]);
- FL(stack)[FL(sp)-1] = sym->binding == UNBOUND ? FL_f : FL_t;
- NEXT_OP;
-
-OP(OP_BUILTINP)
- v = FL(stack)[FL(sp)-1];
- FL(stack)[FL(sp)-1] = (isbuiltin(v) || iscbuiltin(v)) ? FL_t : FL_f;
- NEXT_OP;
-
-OP(OP_FUNCTIONP)
- v = FL(stack)[FL(sp)-1];
- FL(stack)[FL(sp)-1] =
- ((tag(v) == TAG_FUNCTION &&
- (isbuiltin(v) || v>(N_BUILTINS<<3))) ||
- iscbuiltin(v)) ? FL_t : FL_f;
- NEXT_OP;
-
-OP(OP_VECTORP)
- FL(stack)[FL(sp)-1] = isvector(FL(stack)[FL(sp)-1]) ? FL_t : FL_f;
- NEXT_OP;
-
-OP(OP_JMPL)
- ip += GET_INT32(ip);
- NEXT_OP;
-
-OP(OP_BRFL)
- ip += POP() == FL_f ? GET_INT32(ip) : 4;
- NEXT_OP;
-
-OP(OP_BRTL)
- ip += POP() != FL_f ? GET_INT32(ip) : 4;
- NEXT_OP;
-
-OP(OP_BRNEL)
- ip += FL(stack)[FL(sp)-2] != FL(stack)[FL(sp)-1] ? GET_INT32(ip) : 4;
- POPN(2);
- NEXT_OP;
-
-OP(OP_BRNNL)
- ip += POP() != FL_nil ? GET_INT32(ip) : 4;
- NEXT_OP;
-
-OP(OP_BRN)
- ip += POP() == FL_nil ? GET_INT16(ip) : 2;
- NEXT_OP;
-
-OP(OP_BRNL)
- ip += POP() == FL_nil ? GET_INT32(ip) : 4;
- NEXT_OP;
-
-OP(OP_EQV)
- if(FL(stack)[FL(sp)-2] == FL(stack)[FL(sp)-1])
- v = FL_t;
- else if(!leafp(FL(stack)[FL(sp)-2]) || !leafp(FL(stack)[FL(sp)-1]))
- v = FL_f;
- else
- v = fl_compare(FL(stack)[FL(sp)-2], FL(stack)[FL(sp)-1], true) == 0 ? FL_t : FL_f;
- FL(stack)[FL(sp)-2] = v;
- POPN(1);
- NEXT_OP;
-
-OP(OP_EQUAL)
- if(FL(stack)[FL(sp)-2] == FL(stack)[FL(sp)-1])
- v = FL_t;
- else
- v = fl_compare(FL(stack)[FL(sp)-2], FL(stack)[FL(sp)-1], true) == 0 ? FL_t : FL_f;
- FL(stack)[FL(sp)-2] = v;
- POPN(1);
- NEXT_OP;
-
-OP(OP_SETCAR)
- v = FL(stack)[FL(sp)-2];
- if(fl_unlikely(!iscons(v))){- FL(stack)[ipd] = (uintptr_t)ip;
- type_error("cons", v);- }
- car_(v) = FL(stack)[FL(sp)-1];
- POPN(1);
- NEXT_OP;
-
-OP(OP_LIST)
- n = *ip++;
-LABEL(apply_list):
- if(n > 0){- v = list(&FL(stack)[FL(sp)-n], n, 0);
- POPN(n);
- PUSH(v);
- }else{- PUSH(FL_nil);
- }
- NEXT_OP;
-
-OP(OP_TAPPLY)
- tail = true;
- if(0){-OP(OP_APPLY)
- tail = false;
- }
- n = *ip++;
-LABEL(apply_apply):
- v = POP(); // arglist
- n = FL(sp)-(n-2); // n-2 == # leading arguments not in the list
- while(iscons(v)){- PUSHSAFE(car_(v));
- v = cdr_(v);
- }
- if(v != FL_nil){- FL(stack)[ipd] = (uintptr_t)ip;
- lerrorf(FL_ArgError, "apply: last argument: not a list");
- }
- n = FL(sp)-n;
- goto LABEL(do_call);
-
-OP(OP_ADD)
- n = *ip++;
- if(n == 2)
- goto LABEL(do_add2);
-LABEL(apply_add):
- FL(stack)[ipd] = (uintptr_t)ip;
- v = fl_add_any(&FL(stack)[FL(sp)-n], n);
- POPN(n);
- PUSH(v);
- NEXT_OP;
-
-OP(OP_SUB)
- n = *ip++;
-LABEL(apply_sub):
- if(n == 2)
- goto LABEL(do_sub2);
- if(n == 1)
- goto LABEL(do_neg);
- FL(stack)[ipd] = (uintptr_t)ip;
- i = FL(sp)-n;
- // we need to pass the full arglist on to fl_add_any
- // so it can handle rest args properly
- PUSH(FL(stack)[i]);
- FL(stack)[i] = fixnum(0);
- FL(stack)[i+1] = fl_neg(fl_add_any(&FL(stack)[i], n));
- FL(stack)[i] = POP();
- v = fl_add_any(&FL(stack)[i], 2);
- POPN(n);
- PUSH(v);
- NEXT_OP;
-
-OP(OP_MUL)
- n = *ip++;
-LABEL(apply_mul):
- FL(stack)[ipd] = (uintptr_t)ip;
- v = fl_mul_any(&FL(stack)[FL(sp)-n], n);
- POPN(n);
- PUSH(v);
- NEXT_OP;
-
-OP(OP_DIV)
- n = *ip++;
-LABEL(apply_div):
- FL(stack)[ipd] = (uintptr_t)ip;
- i = FL(sp)-n;
- if(n == 1){- FL(stack)[FL(sp)-1] = fl_div2(fixnum(1), FL(stack)[i]);
- }else{- if(n > 2){- PUSH(FL(stack)[i]);
- FL(stack)[i] = fixnum(1);
- FL(stack)[i+1] = fl_mul_any(&FL(stack)[i], n);
- FL(stack)[i] = POP();
- }
- v = fl_div2(FL(stack)[i], FL(stack)[i+1]);
- POPN(n);
- PUSH(v);
- }
- NEXT_OP;
-
-OP(OP_IDIV)
- {- value_t a = FL(stack)[FL(sp)-2];
- value_t b = FL(stack)[FL(sp)-1];
- if(bothfixnums(a, b)){- if(b == 0){- FL(stack)[ipd] = (uintptr_t)ip;
- DivideByZeroError();
- }
- v = fixnum(numval(a) / numval(b));
- }else{- FL(stack)[ipd] = (uintptr_t)ip;
- v = fl_idiv2(a, b);
- }
- POPN(1);
- FL(stack)[FL(sp)-1] = v;
- }
- NEXT_OP;
-
-OP(OP_NUMEQ)
- n = *ip++;
-LABEL(apply_numeq):
- {- i = n;
- value_t a = FL(stack)[FL(sp)-i], b;
- for(v = FL_t; i > 1; a = b){- i--;
- b = FL(stack)[FL(sp)-i];
- if(bothfixnums(a, b)){- if(a != b){- v = FL_f;
- break;
- }
- }else if(numeric_compare(a, b, true, false, true) != 0){- v = FL_f;
- break;
- }
- }
- POPN(n);
- PUSH(v);
- }
- NEXT_OP;
-
-OP(OP_COMPARE)
- FL(stack)[FL(sp)-2] = fl_compare(FL(stack)[FL(sp)-2], FL(stack)[FL(sp)-1], false);
- POPN(1);
- NEXT_OP;
-
-OP(OP_ARGC)
- n = *ip++;
- if(0){-OP(OP_LARGC)
- n = GET_INT32(ip);
- ip += 4;
- }
- FL(stack)[ipd] = (uintptr_t)ip;
- argcount(nargs, n);
- NEXT_OP;
-
-OP(OP_VECTOR)
- n = *ip++;
-LABEL(apply_vector):
- v = alloc_vector(n, 0);
- if(n){- memcpy(&vector_elt(v, 0), &FL(stack)[FL(sp)-n], n*sizeof(value_t));
- POPN(n);
- }
- PUSH(v);
- NEXT_OP;
-
-OP(OP_ASET)
- FL(stack)[ipd] = (uintptr_t)ip;
- v = FL(stack)[FL(sp)-3];
- n = 3;
- if(0){-LABEL(apply_aset):
- v = FL(stack)[FL(sp)-n];
- for(i = n-1; i >= 3; i--){- if(isarray(v)){- FL(stack)[FL(sp)-i-1] = v;
- v = cvalue_array_aref(&FL(stack)[FL(sp)-i-1]);
- continue;
- }
- e = FL(stack)[FL(sp)-i];
- isz = tosize(e);
- if(isvector(v)){- if(fl_unlikely(isz >= vector_size(v)))
- bounds_error(v, e);
- v = vector_elt(v, isz);
- continue;
- }
- if(!iscons(v) && v != FL_nil)
- type_error("sequence", v);- for(value_t v0 = v;; isz--){- if(isz == 0){- v = car_(v);
- break;
- }
- v = cdr_(v);
- if(fl_unlikely(!iscons(v)))
- bounds_error(v0, e);
- }
- }
- FL(stack)[FL(sp)-3] = v;
- }
- e = FL(stack)[FL(sp)-2];
- isz = tosize(e);
- if(isvector(v)){- if(fl_unlikely(isz >= vector_size(v)))
- bounds_error(v, e);
- vector_elt(v, isz) = (e = FL(stack)[FL(sp)-1]);
- }else if(iscons(v) || v == FL_nil){- for(value_t v0 = v;; isz--){- if(isz == 0){- car_(v) = (e = FL(stack)[FL(sp)-1]);
- break;
- }
- v = cdr_(v);
- if(fl_unlikely(!iscons(v)))
- bounds_error(v0, e);
- }
- }else if(isarray(v)){- e = cvalue_array_aset(&FL(stack)[FL(sp)-3]);
- }else{- type_error("sequence", v);- }
- POPN(n);
- PUSH(e);
- NEXT_OP;
-
-OP(OP_FOR)
- FL(stack)[ipd] = (uintptr_t)ip;
- s = tofixnum(FL(stack)[FL(sp)-3]);
- hi = tofixnum(FL(stack)[FL(sp)-2]);
- v = FL_void;
- FL(sp) += 2;
- n = FL(sp);
- for(; s <= hi; s++){- FL(stack)[FL(sp)-2] = FL(stack)[FL(sp)-3];
- FL(stack)[FL(sp)-1] = fixnum(s);
- v = _applyn(1);
- FL(sp) = n;
- }
- POPN(4);
- FL(stack)[FL(sp)-1] = v;
- NEXT_OP;
-
-OP(OP_LOADNIL)
- PUSH(FL_nil);
- NEXT_OP;
-
-OP(OP_LOADI8)
- s = (int8_t)*ip++;
- PUSH(fixnum(s));
- NEXT_OP;
-
-OP(OP_LOADVL)
- v = fn_vals(FL(stack)[bp-1]);
- v = vector_elt(v, GET_INT32(ip));
- ip += 4;
- PUSH(v);
- NEXT_OP;
-
-OP(OP_SETGL)
- v = fn_vals(FL(stack)[bp-1]);
- v = vector_elt(v, GET_INT32(ip));
- ip += 4;
- if(0){-OP(OP_SETG)
- v = fn_vals(FL(stack)[bp-1]);
- assert(*ip < vector_size(v));
- v = vector_elt(v, *ip);
- ip++;
- }
- assert(issymbol(v));
- sym = (symbol_t*)ptr(v);
- v = FL(stack)[FL(sp)-1];
- if(!isconstant(sym))
- sym->binding = v;
- NEXT_OP;
-
-OP(OP_LOADAL)
- assert(nargs > 0);
- i = GET_INT32(ip);
- ip += 4;
- v = FL(stack)[bp+i];
- PUSH(v);
- NEXT_OP;
-
-OP(OP_SETAL)
- v = FL(stack)[FL(sp)-1];
- i = GET_INT32(ip);
- ip += 4;
- FL(stack)[bp+i] = v;
- NEXT_OP;
-
-OP(OP_LOADCL)
- i = GET_INT32(ip);
- ip += 4;
- v = FL(stack)[bp+nargs];
- PUSH(vector_elt(v, i));
- NEXT_OP;
-
-OP(OP_VARGC)
- i = *ip++;
- if(0){-OP(OP_LVARGC)
- i = GET_INT32(ip);
- ip += 4;
- }
- s = (fixnum_t)nargs - (fixnum_t)i;
- if(s > 0){- v = list(&FL(stack)[bp+i], s, 0);
- FL(stack)[bp+i] = v;
- if(s > 1){- FL(stack)[bp+i+1] = FL(stack)[bp+nargs+0];
- FL(stack)[bp+i+2] = FL(stack)[bp+nargs+1];
- FL(stack)[bp+i+3] = i+1;
- FL(stack)[bp+i+4] = 0;
- FL(sp) = bp+i+5;
- FL(curr_frame) = FL(sp);
- }
- }else if(fl_unlikely(s < 0)){- FL(stack)[ipd] = (uintptr_t)ip;
- lerrorf(FL_ArgError, "too few arguments");
- }else{- FL(sp)++;
- FL(stack)[FL(sp)-2] = i+1;
- FL(stack)[FL(sp)-3] = FL(stack)[FL(sp)-4];
- FL(stack)[FL(sp)-4] = FL(stack)[FL(sp)-5];
- FL(stack)[FL(sp)-5] = FL_nil;
- FL(curr_frame) = FL(sp);
- }
- ipd = FL(sp)-1;
- nargs = i+1;
- NEXT_OP;
-
-OP(OP_TRYCATCH)
- FL(stack)[ipd] = (uintptr_t)ip;
- v = do_trycatch();
- POPN(1);
- FL(stack)[FL(sp)-1] = v;
- NEXT_OP;
-
-OP(OP_OPTARGS)
- i = GET_INT32(ip);
- ip += 4;
- n = GET_INT32(ip);
- ip += 4;
- if(fl_unlikely(nargs < i)){- FL(stack)[ipd] = (uintptr_t)ip;
- lerrorf(FL_ArgError, "too few arguments");
- }
- if((int32_t)n > 0){- if(fl_unlikely(nargs > n)){- FL(stack)[ipd] = (uintptr_t)ip;
- lerrorf(FL_ArgError, "too many arguments");
- }
- }else
- n = -n;
- if(fl_likely(n > nargs)){- n -= nargs;
- FL(sp) += n;
- FL(stack)[FL(sp)-1] = FL(stack)[FL(sp)-n-1];
- FL(stack)[FL(sp)-2] = nargs+n;
- FL(stack)[FL(sp)-3] = FL(stack)[FL(sp)-n-3];
- FL(stack)[FL(sp)-4] = FL(stack)[FL(sp)-n-4];
- FL(curr_frame) = FL(sp);
- ipd = FL(sp)-1;
- for(i = 0; i < n; i++)
- FL(stack)[bp+nargs+i] = UNBOUND;
- nargs += n;
- }
- NEXT_OP;
-
-OP(OP_BRBOUND)
- i = GET_INT32(ip);
- ip += 4;
- v = FL(stack)[bp+i];
- PUSH(v != UNBOUND ? FL_t : FL_f);
- NEXT_OP;
-
-OP(OP_KEYARGS)
- v = fn_vals(FL(stack)[bp-1]);
- v = vector_elt(v, 0);
- i = GET_INT32(ip);
- ip += 4;
- n = GET_INT32(ip);
- ip += 4;
- s = GET_INT32(ip);
- ip += 4;
- FL(stack)[ipd] = (uintptr_t)ip;
- nargs = process_keys(v, i, n, labs(s)-(i+n), bp, nargs, s<0);
- ipd = FL(sp)-1;
- NEXT_OP;