New Lisp functions ASSOC, EFFACE, MAPLIST

README.md

@@ -1,6 +1,6 @@
 # beowulf
 
-LISP 1.5 is to all Lisp dialects as Beowulf is to Emglish literature.
+LISP 1.5 is to all Lisp dialects as Beowulf is to English literature.
 
 ## What this is
 

resources/lisp1.5.lsp

@@ -11,6 +11,11 @@
   (APPEND LAMBDA
     (X Y) (COND ((NULL X) Y) ((QUOTE T) (CONS (CAR X) (APPEND (CDR X) Y)))))
   (APPLY)
+  (ASSOC LAMBDA (X L) 
+    (COND 
+      ((NULL L) (QUOTE NIL)) 
+      ((AND (CONSP (CAR L)) (EQ (CAAR L) X)) (CDAR L)) 
+      ((QUOTE T) (ASSOC X (CDR L)))))
   (ATOM)
   (CAR)
   (CAAAAR LAMBDA (X) (CAR (CAR (CAR (CAR X)))))
@@ -43,6 +48,7 @@
   (CDDR LAMBDA (X) (CDR (CDR X)))
   (CDR)
   (CONS)
+  (CONSP)
   (COPY
     LAMBDA
     (X)
@@ -53,6 +59,11 @@
   (DIFFERENCE)
   (DIVIDE
     LAMBDA (X Y) (CONS (QUOTIENT X Y) (CONS (REMAINDER X Y) (QUOTE NIL))))
+  (DOC)
+  (EFFACE 
+    LAMBDA (X L) (COND ((NULL L) (QUOTE NIL)) 
+                    ((EQUAL X (CAR L)) (CDR L)) 
+                    ((QUOTE T) (RPLACD L (EFFACE X (CDR L))))))
   (ERROR)
   (EQ)
   (EQUAL)
@@ -78,6 +89,7 @@
       ((QUOTE T) (INTERSECTION (CDR X) Y))))
   (LENGTH LAMBDA (L) (COND ((EQ NIL L) 0) (T (ADD1 (LENGTH (CDR L))))))
   (LESSP)
+  (MAPLIST LAMBDA (L F) (COND ((NULL L) NIL) ((QUOTE T) (CONS (F (CAR L)) (MAPLIST (CDR L) F)))))
   (MEMBER
     LAMBDA
     (A X)

resources/mexpr/assoc.mexpr.lsp

@@ -0,0 +1,7 @@
+;; Not present in Lisp 1.5(!)
+
+assoc[x; l] = [null[l] -> NIL;
+            and[consp[car[l]]; eq[caar[l]; x]] -> cdar[l];
+            T -> assoc[x; cdr[l]]]
+
+;; (ASSOC 'C (PAIR '(A B C D E F) (RANGE 1 6)))

resources/mexpr/efface.mexpr.lsp

@@ -0,0 +1,6 @@
+;; page 63. I'm not at all sure why an implementation using RPLACD is preferred
+;; over a pure functional implementation here.
+
+efface[x; l] = [null[l] -> NIL; 
+            equal[x; car[l]] -> cdr[l];
+            T -> rplacd[l; efface[x; cdr[l]]]]

resources/mexpr/maplist.mexpr.lsp

@@ -0,0 +1,4 @@
+;; page 63
+
+maplist[l; f] = [null[l] -> nil;
+                T -> cons[f[car[l]]; maplist[cdr[l]; f]]]

src/beowulf/bootstrap.clj

@@ -13,7 +13,7 @@
             [beowulf.cons-cell :refer [make-beowulf-list make-cons-cell
                                        pretty-print T F]]
             [beowulf.host :refer [ADD1 AND ASSOC ATOM ATOM? CAR CDR CONS DEFINE 
-                                  DIFFERENCE EQ EQUAL ERROR FIXP GENSYM 
+                                  DIFFERENCE DOC EQ EQUAL ERROR FIXP GENSYM 
                                   GREATERP lax? LESSP LIST NUMBERP OBLIST
                                   PAIRLIS PLUS QUOTIENT REMAINDER RPLACA RPLACD SET 
                                   TIMES TRACE traced? UNTRACE]]
@@ -256,6 +256,7 @@
           CONS (safe-apply CONS args)
           DEFINE (DEFINE (CAR args))
           DIFFERENCE (DIFFERENCE (CAR args) (CADR args))
+          DOC (DOC (first args))
           EQ (safe-apply EQ args)
           EQUAL (safe-apply EQUAL args)
           ERROR (safe-apply ERROR args)

src/beowulf/core.clj

@@ -118,5 +118,7 @@
               (case (:cause data)
                 :quit nil
                 ;; default
-                (pprint data))
+                (do
+                  (println "ERROR: " (.getMessage e))
+                  (pprint data)))
               (println e))))))))

src/beowulf/gendoc.clj

@@ -3,12 +3,12 @@
    
    NOTE: this is *very* hacky. You almost certainly do not want to 
    use this!"
-  (:require [beowulf.io :refer [default-sysout SYSIN]]
+  (:require ;; [beowulf.io :refer [default-sysout SYSIN]]
-            [beowulf.host :refer [ASSOC]]
+   [beowulf.manual :refer [format-page-references index
-            [beowulf.manual :refer [format-page-references index *manual-url*]]
+                           *manual-url* page-url]]
-            [beowulf.oblist :refer [NIL oblist]]
+   [beowulf.oblist :refer [NIL oblist]]
-            [clojure.java.browse :refer [browse-url]]
+   [clojure.java.browse :refer [browse-url]]
-            [clojure.string :refer [join replace upper-case]]))
+   [clojure.string :refer [join replace upper-case]]))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
@@ -31,16 +31,18 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (def host-functions
-  "Functions which we can infer are written in Clojure."
+  "Functions which we can infer are written in Clojure. We need to collect these 
-  (reduce
+   at run-time, not compile time, hence memoised function, not variable."
-   merge
+  (memoize
-   {}
+   (fn [] (reduce
-   (map
+           merge
-    ns-publics
+           {}
-    ['beowulf.bootstrap
+           (map
-     'beowulf.host
+            ns-publics
-     'beowulf.io
+            ['beowulf.bootstrap
-     'beowulf.read])))
+             'beowulf.host
+             'beowulf.io
+             'beowulf.read])))))
 
 ;; OK, this, improbably, works. There's probably a better way...
 ;; (:doc (meta (eval (read-string (str "#'" "beowulf.read" "/" "READ")))))
@@ -60,7 +62,7 @@
 
 
 (defn- get-metadata-for-entry [entry key]
-  (let [fn (host-functions (symbol (first entry)))]
+  (let [fn ((host-functions) (symbol (first entry)))]
     (get-metadata-for-function fn key)))
 
 (defn infer-type
@@ -70,7 +72,7 @@
   (cond
     (= (second entry) 'LAMBDA) "Lisp function"
     (= (second entry) 'LABEL) "Labeled form"
-    (host-functions (first entry)) (if (fn? (eval (symbol (host-functions (first entry)))))
+    ((host-functions) (first entry)) (if (fn? (eval (symbol ((host-functions) (first entry)))))
                                      "Host function"
                                      "Host variable")
     :else "Lisp variable"))
@@ -118,12 +120,12 @@
 
 (defn gen-doc-table
   ([]
-   (gen-doc-table default-sysout))
+  ;;  (gen-doc-table default-sysout))
-  ([sysfile]
+  ;; ([sysfile]
-   (when (= NIL @oblist)
+  ;;  (when (= NIL @oblist)
-     (try (SYSIN sysfile)
+  ;;    (try (SYSIN sysfile)
-          (catch Throwable any
+  ;;         (catch Throwable any
-            (println (.getMessage any) " while reading " sysfile))))
+  ;;           (println (.getMessage any) " while reading " sysfile))))
    (join
     "\n"
     (doall
@@ -151,3 +153,18 @@
                (list "## Index"
                      ""
                      (gen-doc-table)))))))))
+
+(defn open-doc
+  "Open the documentation page for this `symbol`, if known, in the default
+   web browser."
+  [symbol]
+  (let [doc (get-metadata-for-function symbol :doc)]
+   (if-let [pages (:page-nos (index (keyword symbol)))]
+    (browse-url (page-url (first pages)))
+    (if doc
+      (println doc)
+      (throw (ex-info "No documentation found"
+                      {:phase :host
+                       :function 'DOC
+                       :args (list symbol)
+                       :type :beowulf}))))))

src/beowulf/host.clj

@@ -6,6 +6,7 @@
             [beowulf.cons-cell :refer [F make-cons-cell make-beowulf-list 
                                        pretty-print T]]
             ;; note hyphen - this is Clojure...
+            [beowulf.gendoc :refer [open-doc]]
             [beowulf.oblist :refer [*options* oblist NIL]])
   (:import [beowulf.cons_cell ConsCell]
            ;; note underscore - same namespace, but Java.
@@ -268,8 +269,8 @@
 ;; TODO: These are candidates for moving to Lisp urgently!
 
 (defn ASSOC
-  "If a is an association list such as the one formed by PAIRLIS in the above
+  "If `a` is an association list such as the one formed by PAIRLIS in the above
-  example, then assoc will produce the first pair whose first term is x. Thus
+  example, then assoc will produce the first pair whose first term is `x`. Thus
   it is a table searching function.
 
   All args are assumed to be `beowulf.cons-cell/ConsCell` objects.
@@ -478,3 +479,24 @@
   [s]
   (when (symbol? s)
     (swap! traced-symbols #(set (remove (fn [x] (= s x)) %)))))
+
+;;;; Extensions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn DOC
+   "Open the page for this `symbol` in the Lisp 1.5 manual, if known, in the 
+    default web browser.
+   
+   **NOTE THAT** this is an extension function, not available in strct mode."
+  [symbol]
+  (when (lax? 'DOC)
+    (open-doc symbol)))
+
+(defn CONSP
+  "Return `T` if object `o` is a cons cell, else `F`.
+   
+   **NOTE THAT** this is an extension function, not available in strct mode. 
+   I believe that Lisp 1.5 did not have any mechanism for testing whether an
+   argument was, or was not, a cons cell."
+  [o]
+  (when (lax? 'CONSP)
+    (if (instance? o ConsCell) 'T 'F)))

src/beowulf/io.clj

@@ -63,7 +63,9 @@
   "Dump the current content of the object list to file. If no `filepath` is
    specified, a file name will be constructed of the symbol `Sysout` and 
    the current date. File paths will be considered relative to the filepath
-   set when starting Lisp."
+   set when starting Lisp.
+   
+   **NOTE THAT** this is an extension function, not available in strct mode."
   ([]
    (SYSOUT nil))
   ([filepath]
@@ -92,7 +94,9 @@
    
    **NOTE THAT** if the provided `filename` does not end with `.lsp` (which,
    if you're writing it from the Lisp REPL, it won't), the extension `.lsp`
-   will be appended."
+   will be appended.
+   
+   **NOTE THAT** this is an extension function, not available in strct mode."
   ([]
    (SYSIN (or (:read *options*) default-sysout)))
   ([filename]