shithub: femtolisp

--- a/system.lsp

+++ b/system.lsp

@@ -3,6 +3,8 @@

 ; 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 }

@@ -12,6 +14,58 @@

 (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

@@ -24,6 +78,8 @@

   "Return #t if x is #<void> and #f otherwise."

   (eq? x #.(void)))

+;;; syntax environment

 (unless (bound? '*syntax-environment*)

   (define *syntax-environment* (table)))

@@ -96,7 +152,7 @@

                             (cond-clauses->if (cdr lst)))))))))

   (cond-clauses->if clauses))

-; standard procedures ---------------------------------------------------------

+;;; standard procedures

 (define (member item lst)

   (cond ((null? lst)             #f)

@@ -195,7 +251,7 @@

                 (apply consumer (cdr res))

                 (consumer res))))))

-; list utilities --------------------------------------------------------------

+;;; list utilities

 (define (every pred lst)

   (or (atom? lst)

@@ -223,7 +279,6 @@

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

@@ -343,7 +398,7 @@

                 (cons elt

                       (delete-duplicates tail)))))))

-; backquote -------------------------------------------------------------------

+;;; backquote

 (define (revappend l1 l2) (reverse-  l2 l1))

 (define (nreconc   l1 l2) (reverse!- l2 l1))

@@ -434,7 +489,7 @@

                   ;; (... . x)

                   (cons 'nconc (reverse! (cons (bq-process p d) q)))))))))

-; standard macros -------------------------------------------------------------

+;;; standard macros

 (define (quote-value v)

   (if (self-evaluating? v)

@@ -522,7 +577,7 @@

         (begin ,@body)

         (begin ,@(map (λ (v old) `(set! ,v ,old)) vars olds))))))

-; exceptions ------------------------------------------------------------------

+;;; exceptions

 (define (error . args) (raise (cons 'error args)))

@@ -544,7 +599,7 @@

                         (λ (,e) (begin (,thk) (raise ,e))))

               (,thk)))))

-; debugging utilities ---------------------------------------------------------

+;;; debugging utilities

 (define-macro (assert expr) `(if ,expr #t (raise '(assert-failed ,expr))))

@@ -582,7 +637,7 @@

         ,expr

         (princ "Elapsed time: " (- (time-now) ,t0) " seconds" *linefeed*)))))

-; text I/O --------------------------------------------------------------------

+;;; text I/O

 (define (print . args) (for-each write args))

 (define (princ . args)

@@ -618,7 +673,7 @@

   `(with-bindings ((*input-stream* ,stream))

                   ,@body))

-; vector functions ------------------------------------------------------------

+;;; vector functions

 (define (list->vector l) (apply vector l))

 (define (vector->list v)

@@ -637,7 +692,7 @@

            (aset! nv i (f (aref v i)))))

     nv))

-; table functions -------------------------------------------------------------

+;;; table functions

 (define (table-pairs t)

   (table-foldl (λ (k v z) (cons (cons k v) z))

@@ -659,7 +714,7 @@

                  () t)

     nt))

-; string functions ------------------------------------------------------------

+;;; string functions

 (define (string-tail s n) (string-sub s n))

@@ -712,59 +767,7 @@

                   (cdr strlist))

         (iostream->string b))))

-; props -----------------------------------------------------------------------

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

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

-; toplevel --------------------------------------------------------------------

+;;; toplevel

 (define (macrocall? e) (and (symbol? (car e))

                             (symbol-syntax (car e))))