simon/beowulf
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

New Lisp functions ASSOC, EFFACE, MAPLIST

Browse source
This commit is contained in:
Simon Brooke 2023-04-01 17:56:49 +01:00
parent 41cecdc522
commit 5ee9531e6b
10 changed files with 109 additions and 34 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
README.md
View file

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

12
resources/lisp1.5.lsp
View file

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

7
resources/mexpr/assoc.mexpr.lsp Normal file
View file

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

6
resources/mexpr/efface.mexpr.lsp Normal file
View file

@ -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]]]]

4
resources/mexpr/maplist.mexpr.lsp Normal file
View file

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

3
src/beowulf/bootstrap.clj
View file

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

4
src/beowulf/core.clj
View file

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

45
src/beowulf/gendoc.clj
View file

@ -3,9 +3,9 @@
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*]]
(: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,8 +31,10 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def host-functions
"Functions which we can infer are written in Clojure."
(reduce
"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
@ -40,7 +42,7 @@
['beowulf.bootstrap
'beowulf.host
'beowulf.io
'beowulf.read])))
'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))
([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
@ -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}))))))

26
src/beowulf/host.clj
View file

@ -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.
@ -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)))

8
src/beowulf/io.clj
View file

@ -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]