shithub: femtolisp

--- a/flisp.boot

+++ b/flisp.boot

@@ -14,9 +14,10 @@

 	      #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(void? (x)  length= (lst n)  void rest  help (term))  *doc* #table(void? "Return #t if x is #<void> and #f otherwise."  length= "Bounded length test.\n\nUse this instead of (= (length lst) n), since it avoids unnecessary\nwork and always terminates."  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."  help "Display documentation for the specified term, if available."  *properties* "All properties of symbols recorded with putprop are recorded in this table."))

+	    *properties* #table(*funvars* #table(void? (x)  length= (lst n)  help (term)  void rest)  *doc* #table(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."  *properties* "All properties of symbols recorded with putprop are recorded in this table."))

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

-	    *syntax-environment* #table(when #fn(";000z1200211POe4:" #(if begin))  help #fn("<000n170021527002252853\\0738551474504863B07450475086P51@30O47450@B0732627051524745047860:" #(getprop

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

   trycatch λ if and cons? eq? car quote thrown-value cadr caddr raise))  let* #fn("@000z10H3E02021e1qe12215153e1:2021e173051e1e1220=B3H02024e10=e12215153e1@301515375051e2:" #(#fn(nconc)

@@ -36,9 +37,8 @@

   #fn("7000n22001e3:" #(set!)) unwind-protect begin #fn("7000n22001e3:" #(set!))))  define-macro #fn("@000z170151863D0710<860=5341=?1@30O422230<e22425e10=e12615153e3:" #(value-get-doc

   symbol-set-doc set-syntax! quote #fn(nconc) λ #fn(copy-list)))  receive #fn("?000z22021q1e32221e10e123825153e3:" #(call-with-values

   λ #fn(nconc) #fn(copy-list)))  dotimes #fn("A000z10<0T20E2187Ke32223e186e1e12415153e4:" #(for -

-  #fn(nconc) λ #fn(copy-list)))  unwind-protect #fn("A000n220502050218722q1e3e2e1232402286e12587e12686e2e3e3e387e1e3e3:" #(#fn(gensym)

-  let λ prog1 trycatch begin raise))  throw #fn("9000n220212223e201e4e2:" #(raise list quote

-									    thrown-value))  quasiquote #fn("7000n1700E62:" #(bq-process)))

+  #fn(nconc) λ #fn(copy-list)))  quasiquote #fn("7000n1700E62:" #(bq-process))  throw #fn("9000n220212223e201e4e2:" #(raise

+  list quote thrown-value))  when #fn(";000z1200211POe4:" #(if begin)))

 	    1+ #fn("6000n10KM:" #() 1+) 1-

 	    #fn("6000n10K~:" #() 1-) 1arg-lambda? #fn("7000n10B;3E04700<51;3:04710TK62:" #(is-lambda?

   length=) 1arg-lambda?)

@@ -383,7 +383,7 @@

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

+	    symbol-set-doc #fn("9000\x8720003000\x882000I60O?24700211534823<0700228263:O:" #(putprop

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

 	    symbol-syntax #fn("8000n120710O63:" #(#fn(get)

 						  *syntax-environment*) symbol-syntax)

--- a/system.lsp

+++ b/system.lsp

@@ -3,81 +3,6 @@

 ; by Jeff Bezanson (C) 2009

 ; Distributed under the BSD License

-;;; 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 #f))

-  (putprop sym '*doc* doc)

-  (if funvars (putprop sym '*funvars* 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 (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

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

@@ -151,6 +76,81 @@

                             (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 #f))

+  (putprop sym '*doc* doc)

+  (when funvars (putprop sym '*funvars* 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 (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

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

 ;;; standard procedures