shithub: femtolisp

--- a/docs_extra.lsp

+++ b/docs_extra.lsp

@@ -1,4 +1,4 @@

-(define-macro (doc-for term doc)

+(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))))

@@ -21,7 +21,8 @@

 trade-off between time/space and ratio.  Level 10 is optimal but very

 slow.")

-(doc-for (lz-unpack data :to destination :size decompressed-bytes)

+(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

--- a/flisp.boot

+++ b/flisp.boot

@@ -14,14 +14,15 @@

 	      #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 0)

-	    *properties* #table(*funvars* #table(lz-unpack (data :to destination :size

-								 decompressed-bytes)  void? (x)  length= (lst

-  n)  help (term)  void rest  *prompt* nil  lz-pack (data (level 0))  vm-stats nil)  *doc* #table(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."  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."  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."  *prompt* "Function called by REPL to signal the user input is required.\nDefault function prints \"#;> \"."  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."  *properties* "All properties of symbols recorded with putprop are recorded in this table."))

+	    *properties* #table(*funvars* #table(lz-unpack ((data :to destination)

+							    (data :size decompressed-bytes))  void? ((x))  length= ((lst

+  n))  help ((term))  void (rest)  *prompt* (nil)  lz-pack ((data (level 0)))  vm-stats (nil))  *doc* #table(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."  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."  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."  *prompt* "Function called by REPL to signal the user input is required.\nDefault function prints \"#;> \"."  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."  *properties* "All properties of symbols recorded with putprop are recorded in this table."))

 	    *runestring-type* (array rune) *string-type* (array byte)

 	    *syntax-environment* #table(unwind-protect #fn("A000n220502050218722q1e3e2e1232402286e12587e12686e2e3e3e387e1e3e3:" #(#fn(gensym)

-  let λ prog1 trycatch begin raise))  help #fn("<000n170021527002252853\\0738551474504863B07450475086P51@30O47450@B0732627051524745047860:" #(getprop

-  *doc* *funvars* princ newline print "no help for " #fn(string) void))  with-output-to #fn("<000z12021e1220e2e1e12315163:" #(#fn(nconc)

-  with-bindings *output-stream* #fn(copy-list)))  catch #fn("@000n220502112286e123242586e2262786e22829e2e3262:86e20e3e42;86e22<86e2e4e3e3:" #(#fn(gensym)

+  let λ prog1 trycatch begin raise))  help #fn(";000n17002152853W072855147350424250>170026q535247350@B0722728051524735047960:" #(getprop

+  *doc* princ newline #fn(for-each) #fn("7000n17050471A0P61:" #(newline print)) *funvars* "no help for "

+  #fn(string) void))  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))  with-input-from #fn("<000z12021e1220e2e1e12315163:" #(#fn(nconc)

   with-bindings *input-stream* #fn(copy-list)))  unless #fn("<000z1200O211Pe4:" #(if begin))  letrec #fn(">000z1202021e12273052e122240522515154e1222605262:" #(#fn(nconc)

@@ -401,8 +402,8 @@

   #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:O:" #(putprop

-  *doc* *funvars*) symbol-set-doc)

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

--- a/system.lsp

+++ b/system.lsp

@@ -107,9 +107,12 @@

 ;;; documentation

-(define (symbol-set-doc sym doc (funvars #f))

-  (putprop sym '*doc* doc)

-  (when funvars (putprop sym '*funvars* funvars)))

+(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

@@ -116,27 +119,25 @@

   '*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)))

-(define-macro (help term)

-  "Display documentation for the specified term, if available."

-  (let* ((doc     (getprop term '*doc*))

-         (funvars (getprop term '*funvars*)))

-  (if doc

-    (begin

-      (princ doc)

-      (newline)

-      (when funvars

-        (newline)

-        (print (cons term funvars)))

-      (newline))

-    (begin

-      (princ "no help for " (string term))

-      (newline)))

-  (void)))

 ;;; void