ref: ca55a3382bd47c42827184b02ed514b54e97e46d
parent: e0508d01357b9062eabac8c7fe4cdb6ea7c57fc8
author: Sigrid Solveig Haflínudóttir <sigrid@ftrv.se>
date: Fri Dec 20 17:06:35 EST 2024
docs: always set the props regardless of environment, set the fun vars separately Also: * make *properties* visible. * allow documentation with (set! x "docs" ...) References: https://todo.sr.ht/~ft/femtolisp/16
--- a/compiler.lsp
+++ b/compiler.lsp
@@ -512,9 +512,17 @@
(while (compile-while g env (cadr x) (cons 'begin (cddr x))))
(return (compile-in g env #t (cadr x))
(emit g 'ret))
- (set! (unless (symbol? (cadr x))
- (error "set!: second argument must be a symbol"))
- (compile-set! g env (cadr x) (caddr x)))
+ (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"))
--- a/flisp.boot
+++ b/flisp.boot
@@ -14,7 +14,9 @@
#fn("6000n201l:" #()) #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)- *empty-string* "" *runestring-type* (array rune) *string-type* (array byte)
+ *empty-string* "" *properties*
+ #table(*funvars* #table(help (e)) *doc* #table(help "Display documentation for a function or symbol, if available."))
+ *runestring-type* (array rune) *string-type* (array byte)
*syntax-environment* #table(when #fn(";000z1200211POe4:" #(if begin)) 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)@@ -92,8 +94,8 @@
#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 #3=#fn("5000n10=T:" #() caddr) call-with-values- #fn("7000n205086B3@0A86<C90186=}2:18661:" #() #(#2=(*values*))) capture-var! #fn("<000n27005171186E5387;IG042286510r323861e152p4:" #(bcode:cenv+ #fn("5000n10==T:" #() cadddr) caddr #2=#fn("5000n10=T:" #() caddr) call-with-values+ #fn("7000n205086B3@0A86<C90186=}2:18661:" #() #(#1=(*values*))) capture-var! #fn("<000n27005171186E5387;IG042286510r323861e152p4:" #(bcode:cenvindex-of #fn(length) #fn(nconc)) capture-var!)
cdaaar #fn("5000n10<<<=:" #() cdaaar) cdaadr #fn("5000n10T<=:" #() cdaadr) cdaar #fn("5000n10<<=:" #() cdaar) cdadar@@ -129,7 +131,7 @@
encode-byte-code bcode:code const-to-idx-vec bcode:cenv) compile-f-)
compile-if #fn("A000n470051700517005183T718351728351B3;0738351@6074508;DC=07501828<64:8;OC=07501828=64:7501O8;895547602789534780885247501828<544823<07602952@;07602:8:534780895247501828=5447808:62:" #(make-labelcaddr cdddr cadddr void compile-in emit brf mark-label ret jmp) compile-if)
- compile-in #fn(">000\x8740005000\x884000I60O?4483R3<0700183D64:83H3\xaf083EC:07102262:83KC:07102362:83DC:07102462:83OC:07102562:83qC:07102662:7783513<0710288363:2983513C07:01822;2<51e164:7102=8363:83<2>C<07?0183=63:83<RS;ID0483<Z;I;047@83<1523=07A01828364:83<892BCS07C83T513>07:018283T64:7102=83T63:892DC=07E01828364:892FC>07G018283=64:892HC;07I018363:892JCD07K2L183>22M01>262:892NC@07O018283=8465:892PC>07Q018283=64:892RCE07S0183T2F7T8351P64:892UCE07:01D83T5447102V62:892WCT083TR360O@807X2Y5147Z0183T7[835164:892\\Cp07:01O2Jq83Te35447]7[835151360O@807X2^5147:01O7[83515447102\\62:7A01828364:" #(compile-sym+ compile-in #fn("B000\x8740005000\x884000I60O?4483R3<0700183D64:83H3\xaf083EC:07102262:83KC:07102362:83DC:07102462:83OC:07102562:83qC:07102662:7783513<0710288363:2983513C07:01822;2<51e164:7102=8363:83<2>C<07?0183=63:83<RS;ID0483<Z;I;047@83<1523=07A01828364:83<892BCS07C83T513>07:018283T64:7102=83T63:892DC=07E01828364:892FC>07G018283=64:892HC;07I018363:892JCD07K2L183>22M01>262:892NC@07O018283=8465:892PC>07Q018283=64:892RCE07S0183T2F7T8351P64:892UCE07:01D83T5447102V62:892WC\x93083T7T83517X8;518:R360O@807Y2Z5148<3`08;=?;47[8:8<8;<B;3G047\\8;<<51;3:047]8;<5153@30O47^018:8;<64:892_Cp07:01O2Jq83Te35447`7a835151360O@807Y2b5147:01O7a83515447102_62:7A01828364:" #(compile-symemit load0 load1 loadt loadf loadnil fits-i8 loadi8 #fn(eof-object?) compile-in #fn(top-level-value)
eof-object loadv aset! compile-aset! in-env? compile-app quote self-evaluating? if compile-if
begin compile-begin prog1 compile-prog1 λ call-with-values #fn("7000n070AF62:" #(compile-f-))@@ -136,8 +138,8 @@
#fn("9000n270A2105341\x85K02223AF>2152470A242515163:D:" #(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! error "set!: second argument must be a symbol"
- compile-set! caddr trycatch 1arg-lambda? "trycatch: second form must be a 1-argument lambda") compile-in)
+ 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=7005188T71018953728;737488518;528:537508=524268=1<521=P7708>827488515447808<U524798<E523A082I<07:02;8<63:D:" #(bcode:spcompile-arglist vars-to-env complex-bindings caddr box-vars #fn(nconc) compile-in bcode:stack >
emit shift) compile-let)
@@ -207,7 +209,7 @@
#fn("9000z020210P61:" #(#fn(raise) error) error) eval #fn("7000n170710515160:" #(compile-thunkexpand) eval)
even? #fn("7000n1200K52El:" #(#fn(logand)) even?) every- #fn("7000n21H;ID0401<51;3:047001=62:" #(every) every) expand #fn("I000n1DDDDDDDDDDDDD\x8a5\x8a6\x8a7\x8a8\x8a9\x8a:\x8a;\x8a<\x8a=\x8a>\x8a?\x8a@\x8aA8520_4862186>1_48722e1_4882385868A87>4_489248A89>2_48:258:>1_48;268:8988>3_48<27_48=28_48>298=8<8A8:8988>6_48?2:888A>2_48@2;_48A2<8A8@8;8>8?>5_48A<0q62:" #(#fn("7000n20Z;I904200152S:" #(#fn(assq)) top?)+ #fn("7000n21H;ID0401<51;3:047001=62:" #(every) every) expand #fn("F000n1DDDDDDDDDDD\x8a5\x8a6\x8a7\x8a8\x8a9\x8a:\x8a;\x8a<\x8a=\x8a>\x8a?8520_4862186>1_48722e1_4882385868?87>4_489248?89>2_48:258:>1_48;268:8988>3_48<278?8:8988>4_48=28888?>2_48>29_48?2:8?8>8;8<8=>5_48?<0q62:" #(#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:D\x8a:8:278:928993>4_48:<^186518:D8;B3c0493<788;51QIC08;92<8;<89<52_@;08;798;51_48;=?;@\xfb/48::" #(begin@@ -218,14 +220,11 @@
#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("=000\x8730004000\x883000I60O?3482JN070021833@022123083P53@30163:O:" #(putprop *doc* #fn(string)- "\n\n") document)
- #fn("8000n10<0=208551;3=0486B;350485:" #(#fn(string?)) getdoc)- #fn("D000n20=V;I6040TH3q070051J400:0TA<7005151873C0F<868715340=?0@30O4218692<72051152e3:73051740517005193<8651A<885125267789521528:3F0F<878:18654488=?8@30O42521e18794<868;52Pe195<888;5263:" #(cddr- 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("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:87;I?0486RS;I60486Z3708860:73051893>0A<890=f2162:8624C400:8625C:092<0162:8625C:092<0162:8626C:093<0162:8627C:094<0162:8860:" #(#fn(assq) #fn(":000n0D\x8a48420AF84>3_484<^19261:" #(#fn("8000n10H3400:0<H3700<@90A<0<F5292<0=51P:" #())))caddr macrocall? quote λ define let-syntax) expand-in)) expand)
@@ -237,10 +236,10 @@
#fn("9000n382J401:700082<15282=63:" #(foldl) foldl) foldr #fn(":000n382J401:082<700182=5362:" #(foldr) foldr) get-defined-vars #fn("7000n170A<05161:" #(delete-duplicates) #(#0=(#fn("8000n10H340q:0<20Cj00=B3d00TR;37040Te1;IS040TB;3E0471051R;3:0471051e1;I404q:0<22C?07324A<0=52}2:q:" #(definecaadr begin nconc #fn(map)) #(#0#)))))
- getprop #fn(":000\x8720003000\x882000I60O?2420A1O5387;3<04208708253;I50482:" #(#fn(get)) #(#1=#table()))- help #fn("=000n10\\3:020051@300717285232425052532662:" #(#fn(function:name) princ- getprop *doc* #fn(string) "no help for "
- "\n") help)
+ getprop #fn(":000\x8720003000\x882000I60O?2420711O5387;3<04208708253;I50482:" #(#fn(get)+ *properties*) getprop)
+ help #fn("?000n10\\853:020051@3007186225271862352873X0748751475504883C075504768688P51@30O@>074272886515247560:" #(#fn(function:name)+ getprop *doc* *funvars* princ newline print "no help for " #fn(string)) help)
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?)
@@ -340,9 +339,9 @@
printable? #fn("6000n120051;I80421051S:" #(#fn(iostream?)#fn(eof-object?)) printable?)
procedure? #.function? putprop
- #fn(";000n320A1O5387360O@E0215022A18853488?7^14228708253482:" #(#fn(get)- #fn(table)
- #fn(put!)) #(#1#))
+ #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)
@@ -353,9 +352,8 @@
#fn(ash)) ref-int16-LE)
ref-int32-LE #fn("<000n2202101EMGE522101KMGr8522101r2MGr@522101r3MGrH52g461:" #(#fn(int32)#fn(ash)) ref-int32-LE)
- remprop #fn("8000n220A1O5386;3F042186052;3:042286062:" #(#fn(get)- #fn(has?)
- #fn(del!)) #(#1#))
+ remprop #fn("8000n220711O5386;3F042286052;3:042386062:" #(#fn(get) *properties* #fn(has?)+ #fn(del!)) remprop)
repl #fn(":000n0DD\x8a4\x8a58420_485218485>2_485<5047260:" #(#fn("8000n0702151422735142425{267751S;3F04788451798551485w:4D:" #(princ "> " #fn(io-flush) *output-stream* #fn("5000n02060:" #(#fn(read))) #fn("6000n1207151422061:" #(#fn(io-discardbuffer) *input-stream* #fn(raise)))@@ -389,6 +387,8 @@
#fn(string-char) 1+) trim-start) #fn(":000n37082E523R021122073825152523?0A<0173825163:82:" #(> #fn(string-find)#fn(string-char) 1-) trim-end) #fn(string-length)
#fn(string-sub)) string-trim)
+ symbol-set-doc #fn("9000\x8720003000\x882000I60O?24700211534823<0700228263:D:" #(putprop+ *doc* *funvars*) symbol-set-doc)
symbol-syntax #fn("8000n120710O63:" #(#fn(get)*syntax-environment*) symbol-syntax)
table-clone #fn("9000n12050212285>1q053485:" #(#fn(table)@@ -416,7 +416,8 @@
x newline #.apply)))))
untrace #fn("9000n1200517185513A0220238551r2G62:D:" #(#fn(top-level-value) traced? #fn(set-top-level-value!)#fn(function:vals)) untrace)
- values #fn("8000z00B3:00=J500<:A0P:" #() #(#2#)) vars-to-env+ value-get-doc #fn("8000n10<0=208551;3=0486B;350485:" #(#fn(string?)) value-get-doc)+ values #fn("8000z00B3:00=J500<:A0P:" #() #(#1#)) vars-to-env #fn(":000n32021182>2072230515163:" #(#fn(map) #fn("9000n2700210A52SS1FM63:" #(vinfo #fn(memq)))iota #fn(length)) vars-to-env)
@@ -426,5 +427,5 @@
#fn(vector-alloc)
#fn("9000n1A0F920G51p:" #())) vector-map) vinfo #fn("7000n30182e3:" #() vinfo) vinfo:heap? #.cadr vinfo:index- #3# vinfo:sym #.car void
+ #2# vinfo:sym #.car void
#fn("5000n0D:" #() void) zero? #fn("6000n10El:" #() zero?))--- a/system.lsp
+++ b/system.lsp
@@ -702,33 +702,55 @@
;;
;; 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.
-(let ((*properties* (table)))
- (set! 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)))
- (set! getprop
- (λ (sym key (def #f))
- (let ((kt (get *properties* key #f)))
- (or (and kt (get kt sym def)) def))))
- (set! remprop
- (λ (sym key)
- (let ((kt (get *properties* key #f)))
- (and kt (has? kt sym) (del! kt sym))))))
+(define *properties* (table))
-; toplevel --------------------------------------------------------------------
+(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 #f))
+ (putprop sym '*doc* doc)
+ (if funvars (putprop sym '*funvars* funvars)))
+
+(define (value-get-doc body)
+ (let ((first (car body))
+ (rest (cdr body)))
+ (and (string? first) (cons? rest) first)))
+
(define (help e)
- (let ((name (if (function? e)
- (function:name e)
- e)))
- (princ (getprop name '*doc* (string "no help for " e)) "\n")))
+ "Display documentation for a function or symbol, if available."
+ (let* ((func? (function? e))
+ (name (if func? (function:name e) e))
+ (doc (getprop name '*doc*))
+ (funvars (getprop name '*funvars*)))
+ (if doc
+ (begin
+ (princ doc)
+ (newline)
+ (when funvars
+ (newline)
+ (print (cons name funvars))))
+ (begin
+ (princ "no help for " (string name))))
+ (newline)))
+; toplevel --------------------------------------------------------------------
+
(define (macrocall? e) (and (symbol? (car e))
(symbol-syntax (car e))))
@@ -808,36 +830,25 @@
,.(expand-body body env)
. ,name))))
- (define (document sym doc env (formals #f))
- (when (null? env)
- (putprop sym '*doc* (if formals
- (string doc "\n\n" (cons sym formals))
- doc))))
-
- (define (getdoc body)
- (let ((first (car body))
- (rest (cdr body)))
- (and (string? first) (cons? rest) first)))
-
(define (expand-define e env)
(if (or (null? (cdr e)) (atom? (cadr e)))
(if (null? (cddr e))
e
(let ((name (cadr e))
- (doc (getdoc (cddr e))))
+ (doc (value-get-doc (cddr e))))
(when doc
- (document name doc env)
- (set! e (cdr e)))
+ (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))
- (doc (getdoc body))
(menv (nconc (map list vars) env)))
(when doc
- (document name doc env formals)
- (set! body (cdr body)))
+ (set! body (cdr body))
+ (symbol-set-doc name doc formals))
`(define ,(cons name (expand-lambda-list formals menv))
,.(expand-body body menv)))))