From 5ee9531e6bd6c55daceb1bd7e0b177db01357baf Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 1 Apr 2023 17:56:49 +0100 Subject: [PATCH] New Lisp functions ASSOC, EFFACE, MAPLIST --- README.md | 2 +- resources/lisp1.5.lsp | 12 ++++++ resources/mexpr/assoc.mexpr.lsp | 7 ++++ resources/mexpr/efface.mexpr.lsp | 6 +++ resources/mexpr/maplist.mexpr.lsp | 4 ++ src/beowulf/bootstrap.clj | 3 +- src/beowulf/core.clj | 4 +- src/beowulf/gendoc.clj | 69 +++++++++++++++++++------------ src/beowulf/host.clj | 28 +++++++++++-- src/beowulf/io.clj | 8 +++- 10 files changed, 109 insertions(+), 34 deletions(-) create mode 100644 resources/mexpr/assoc.mexpr.lsp create mode 100644 resources/mexpr/efface.mexpr.lsp create mode 100644 resources/mexpr/maplist.mexpr.lsp diff --git a/README.md b/README.md index 968bee8..88ba778 100644 --- a/README.md +++ b/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 diff --git a/resources/lisp1.5.lsp b/resources/lisp1.5.lsp index 13b90aa..ac9106f 100644 --- a/resources/lisp1.5.lsp +++ b/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) diff --git a/resources/mexpr/assoc.mexpr.lsp b/resources/mexpr/assoc.mexpr.lsp new file mode 100644 index 0000000..d3aff41 --- /dev/null +++ b/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))) \ No newline at end of file diff --git a/resources/mexpr/efface.mexpr.lsp b/resources/mexpr/efface.mexpr.lsp new file mode 100644 index 0000000..a91c454 --- /dev/null +++ b/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]]]] \ No newline at end of file diff --git a/resources/mexpr/maplist.mexpr.lsp b/resources/mexpr/maplist.mexpr.lsp new file mode 100644 index 0000000..e04c38c --- /dev/null +++ b/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]]] \ No newline at end of file diff --git a/src/beowulf/bootstrap.clj b/src/beowulf/bootstrap.clj index 08f4864..2b15fee 100644 --- a/src/beowulf/bootstrap.clj +++ b/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) diff --git a/src/beowulf/core.clj b/src/beowulf/core.clj index d199fd8..3ff8a62 100644 --- a/src/beowulf/core.clj +++ b/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)))))))) diff --git a/src/beowulf/gendoc.clj b/src/beowulf/gendoc.clj index def8b58..d81b2f8 100644 --- a/src/beowulf/gendoc.clj +++ b/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]] - [beowulf.host :refer [ASSOC]] - [beowulf.manual :refer [format-page-references index *manual-url*]] - [beowulf.oblist :refer [NIL oblist]] - [clojure.java.browse :refer [browse-url]] - [clojure.string :refer [join replace upper-case]])) + (:require ;; [beowulf.io :refer [default-sysout SYSIN]] + [beowulf.manual :refer [format-page-references index + *manual-url* page-url]] + [beowulf.oblist :refer [NIL oblist]] + [clojure.java.browse :refer [browse-url]] + [clojure.string :refer [join replace upper-case]])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -31,16 +31,18 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (def host-functions - "Functions which we can infer are written in Clojure." - (reduce - merge - {} - (map - ns-publics - ['beowulf.bootstrap - 'beowulf.host - 'beowulf.io - 'beowulf.read]))) + "Functions which we can infer are written in Clojure. We need to collect these + at run-time, not compile time, hence memoised function, not variable." + (memoize + (fn [] (reduce + merge + {} + (map + ns-publics + ['beowulf.bootstrap + '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")) @@ -99,7 +101,7 @@ :else "?")) (defn infer-implementation - [entry] + [entry] (case (second entry) LAMBDA (format "%s-fn" (second entry)) LABEL (format "%s-fn" (second entry)) @@ -118,12 +120,12 @@ (defn gen-doc-table ([] - (gen-doc-table default-sysout)) - ([sysfile] - (when (= NIL @oblist) - (try (SYSIN sysfile) - (catch Throwable any - (println (.getMessage any) " while reading " sysfile)))) + ;; (gen-doc-table default-sysout)) + ;; ([sysfile] + ;; (when (= NIL @oblist) + ;; (try (SYSIN sysfile) + ;; (catch Throwable any + ;; (println (.getMessage any) " while reading " sysfile)))) (join "\n" (doall @@ -150,4 +152,19 @@ println (list "## Index" "" - (gen-doc-table))))))))) \ No newline at end of file + (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})))))) \ No newline at end of file diff --git a/src/beowulf/host.clj b/src/beowulf/host.clj index 8600faa..7b87072 100644 --- a/src/beowulf/host.clj +++ b/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 - example, then assoc will produce the first pair whose first term is x. Thus + "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 it is a table searching function. All args are assumed to be `beowulf.cons-cell/ConsCell` objects. @@ -477,4 +478,25 @@ (defn UNTRACE [s] (when (symbol? s) - (swap! traced-symbols #(set (remove (fn [x] (= s x)) %))))) \ No newline at end of file + (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))) \ No newline at end of file diff --git a/src/beowulf/io.clj b/src/beowulf/io.clj index b441bda..cca8838 100644 --- a/src/beowulf/io.clj +++ b/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]