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

Upversioned to 0.3 as much refactoring has changed API

Browse source
This commit is contained in:
Simon Brooke 2023-03-31 12:37:29 +01:00
parent 03ed76f34d
commit 3c92427285
20 changed files with 953 additions and 489 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
project.clj
View file

@ -1,13 +1,13 @@
(defproject beowulf "0.2.2-SNAPSHOT"
(defproject beowulf "0.3.0-SNAPSHOT"
:cloverage {:output "docs/cloverage"
:ns-exclude-regex [#"beowulf\.gendoc"]}
:ns-exclude-regex [#"beowulf\.gendoc" #"beowulf\.scratch"]}
:codox {:metadata {:doc "**TODO**: write docs"
:doc/format :markdown}
:output-path "docs/codox"
:source-uri "https://github.com/simon-brooke/beowulf/blob/master/{filepath}#L{line}"}
:description "An implementation of LISP 1.5 in Clojure"
:license {:name "GPL-2.0-or-later"
:url "https://www.eclipse.org/legal/epl-2.0/"}
:url "https://www.gnu.org/licenses/old-licenses/gpl-2.0.en.html"}
:dependencies [[org.clojure/clojure "1.11.1"]
[org.clojure/math.numeric-tower "0.0.5"]
[org.clojure/tools.cli "1.0.214"]

94
resources/lisp1.5.lsp
View file

@ -1,5 +1,5 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Beowulf Sysout file generated at 2023-03-30T09:40:36.483
;; Beowulf Sysout file generated at 2023-03-31T02:24:08.808
;; generated by simon
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -8,72 +8,84 @@
(F)
(ADD1)
(AND)
(APPEND)
(APPEND LAMBDA
(X Y) (COND ((NULL X) Y) ((QUOTE T) (CONS (CAR X) (APPEND (CDR X) Y)))))
(APPLY)
(ATOM)
(CAR)
(CDR)
(CONS)
(COPY LAMBDA (X)
(COND ((NULL X) (QUOTE NIL))
((ATOM X) X)
((QUOTE T) (CONS (COPY (CAR X)) (COPY (CDR X))))))
(COPY
LAMBDA
(X)
(COND
((NULL X) (QUOTE NIL))
((ATOM X) X) ((QUOTE T) (CONS (COPY (CAR X)) (COPY (CDR X))))))
(DEFINE)
(DIFFERENCE)
(DIVIDE LAMBDA (X Y) (CONS (QUOTIENT X Y) (CONS (REMAINDER X Y) (QUOTE NIL))))
(DIVIDE
LAMBDA (X Y) (CONS (QUOTIENT X Y) (CONS (REMAINDER X Y) (QUOTE NIL))))
(ERROR)
(EQ)
(EQUAL)
(EVAL)
(FACTORIAL
LAMBDA (N) (COND ((EQ N 1) 1) (T (TIMES N (FACTORIAL (SUB1 N))))))
(FIXP)
(GENSYM)
(GET LAMBDA (X Y)
(COND ((NULL X) (QUOTE NIL))
((EQ (CAR X) Y) (CAR (CDR X)))
((QUOTE T) (GET (CDR X) Y))))
(GET
LAMBDA
(X Y)
(COND
((NULL X) (QUOTE NIL))
((EQ (CAR X) Y) (CAR (CDR X))) ((QUOTE T) (GET (CDR X) Y))))
(GREATERP)
(INTEROP)
(INTERSECTION LAMBDA (X Y)
(COND ((NULL X) (QUOTE NIL))
((MEMBER (CAR X) Y) (CONS (CAR X) (INTERSECTION (CDR X) Y)))
(INTERSECTION
LAMBDA
(X Y)
(COND
((NULL X) (QUOTE NIL))
((MEMBER (CAR X) Y) (CONS (CAR X) (INTERSECTION (CDR X) Y)))
((QUOTE T) (INTERSECTION (CDR X) Y))))
(LENGTH LAMBDA (L) (COND ((EQ NIL L) 0) (T (ADD1 (LENGTH (CDR L))))))
(LESSP)
(MEMBER LAMBDA (A X)
(COND ((NULL X) (QUOTE F))
((EQ A (CAR X)) (QUOTE T))
((QUOTE T) (MEMBER A (CDR X)))))
(MEMBER
LAMBDA
(A X)
(COND
((NULL X) (QUOTE F))
((EQ A (CAR X)) (QUOTE T)) ((QUOTE T) (MEMBER A (CDR X)))))
(MINUSP LAMBDA (X) (LESSP X 0))
(NOT LAMBDA (X) (COND (X (QUOTE NIL)) ((QUOTE T) (QUOTE T))))
(NULL LAMBDA (X) (COND ((EQUAL X NIL) (QUOTE T)) (T (QUOTE F))))
(NUMBERP)
(OBLIST)
(ONEP LAMBDA (X) (EQ X 1))
(PAIR LAMBDA (X Y)
(COND ((AND (NULL X) (NULL Y)) NIL)
((NULL X) (ERROR 'F2))
((NULL Y) (ERROR 'F3))
(T (CONS (CONS (CAR X) (CAR Y)) (PAIR (CDR X) (CDR Y))))))
(PAIR
LAMBDA
(X Y)
(COND
((AND (NULL X) (NULL Y)) NIL)
((NULL X) (ERROR (QUOTE F2)))
((NULL Y) (ERROR (QUOTE F3)))
(T (CONS (CONS (CAR X) (CAR Y)) (PAIR (CDR X) (CDR Y))))))
(PLUS)
(PRETTY)
(PRINT)
(PROP LAMBDA (X Y U)
(COND ((NULL X) (U))
((EQ (CAR X) Y) (CDR X))
((QUOTE T) (PROP (CDR X) Y U))))
(PROP
LAMBDA
(X Y U)
(COND
((NULL X) (U)) ((EQ (CAR X) Y) (CDR X)) ((QUOTE T) (PROP (CDR X) Y U))))
(QUOTIENT)
(READ)
(REMAINDER)
(REPEAT LAMBDA (N X)
(COND ((EQ N 0) NIL)
(T (CONS X (REPEAT (SUB1 N) X)))))
(RPLACA)
(RPLACD)
(REMAINDER)
(REPEAT
LAMBDA (N X) (COND ((EQ N 0) NIL) (T (CONS X (REPEAT (SUB1 N) X)))))
(RPLACA)
(RPLACD)
(SET)
(SUB1 LAMBDA (N) (DIFFERENCE N 1))
(SYSIN)
(SYSOUT)
(TERPRI)
(TIMES)
(TRACE)
(UNTRACE)
(ZEROP LAMBDA (N) (EQ N 0)))
(SUB1 LAMBDA (N) (DIFFERENCE N 1))
(SYSIN)
(SYSOUT) (TERPRI) (TIMES) (TRACE) (UNTRACE) (ZEROP LAMBDA (N) (EQ N 0)))

3
resources/mexpr/append.mexpr.lsp Normal file
View file

@ -0,0 +1,3 @@
;; page 61
append[x; y] = [null[x] -> y; T -> cons[car[x]; append[cdr[x]; y]]]

245
src/beowulf/bootstrap.clj
View file

@ -10,63 +10,45 @@
therefore all arguments must be numbers, symbols or `beowulf.cons_cell.ConsCell`
objects."
(:require [clojure.string :as s]
[beowulf.cons-cell :refer [CAR CDR CONS LIST make-beowulf-list make-cons-cell
[beowulf.cons-cell :refer [make-beowulf-list make-cons-cell
pretty-print T F]]
[beowulf.host :refer [AND ADD1 DIFFERENCE ERROR FIXP GENSYM GREATERP LESSP
NUMBERP PLUS QUOTIENT
REMAINDER RPLACA RPLACD TIMES]]
[beowulf.host :refer [ADD1 AND ASSOC ATOM ATOM? CAR CDR CONS DEFINE
DIFFERENCE EQ EQUAL ERROR FIXP GENSYM
GREATERP lax? LESSP LIST NUMBERP OBLIST
PAIRLIS PLUS QUOTIENT REMAINDER RPLACA RPLACD SET
TIMES TRACE traced? UNTRACE]]
[beowulf.io :refer [SYSIN SYSOUT]]
[beowulf.oblist :refer [*options* oblist NIL]]
[beowulf.read :refer [READ]]
[beowulf.trace :refer [TRACE traced? UNTRACE]])
[beowulf.read :refer [READ]])
(:import [beowulf.cons_cell ConsCell]
[clojure.lang Symbol]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; This file is essentially Lisp as defined in Chapter 1 (pages 1-14) of the
;;; Lisp 1.5 Programmer's Manual; that is to say, a very simple Lisp language,
;;; which should, I believe, be sufficient in conjunction with the functions
;;; provided by `beowulf.host`, be sufficient to bootstrap the full Lisp 1.5
;;; interpreter.
;;; Copyright (C) 2022-2023 Simon Brooke
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(declare APPLY EVAL)
(defn lax?
"Are we in lax mode? If so. return true; is not, throw an exception with
this `symbol`."
[symbol]
(when (:strict *options*)
(throw (ex-info (format "%s is not available in Lisp 1.5" symbol)
{:cause :strict
:extension symbol})))
true)
(defmacro NULL
"Returns `T` if and only if the argument `x` is bound to `NIL`; else `F`."
[x]
`(if (= ~x NIL) T F))
(defmacro NILP
"Not part of LISP 1.5: `T` if `o` is `NIL`, else `NIL`."
[x]
`(if (= ~x NIL) T NIL))
(defmacro ATOM
"Returns `T` if and only if the argument `x` is bound to an atom; else `F`.
It is not clear to me from the documentation whether `(ATOM 7)` should return
`T` or `F`. I'm going to assume `T`."
[x]
`(if (or (symbol? ~x) (number? ~x)) T F))
(defmacro ATOM?
"The convention of returning `F` from predicates, rather than `NIL`, is going
to tie me in knots. This is a variant of `ATOM` which returns `NIL`
on failure."
[x]
`(if (or (symbol? ~x) (number? ~x)) T NIL))
(defmacro QUOTE
"Quote, but in upper case for LISP 1.5"
[f]
`(quote ~f))
(defn uaf
"Universal access function; `l` is expected to be an arbitrary LISP list, `path`
@ -123,127 +105,7 @@
(defmacro CDAADR [x] `(uaf ~x '(\d \a \a \d)))
(defmacro CDADDR [x] `(uaf ~x '(\d \a \d \d)))
(defn EQ
"Returns `T` if and only if both `x` and `y` are bound to the same atom,
else `NIL`."
[x y]
(cond (and (instance? ConsCell x)
(.equals x y)) T
(and (= (ATOM x) T) (= x y)) T
:else NIL))
(defn EQUAL
"This is a predicate that is true if its two arguments are identical
S-expressions, and false if they are different. (The elementary predicate
`EQ` is defined only for atomic arguments.) The definition of `EQUAL` is
an example of a conditional expression inside a conditional expression.
NOTE: returns `F` on failure, not `NIL`"
[x y]
(cond
(= (ATOM x) T) (if (= x y) T F)
(= (EQUAL (CAR x) (CAR y)) T) (EQUAL (CDR x) (CDR y))
:else F))
(defn SUBST
"This function gives the result of substituting the S-expression `x` for
all occurrences of the atomic symbol `y` in the S-expression `z`."
[x y z]
(cond
(= (EQUAL y z) T) x
(= (ATOM? z) T) z ;; NIL is a symbol
:else
(make-cons-cell (SUBST x y (CAR z)) (SUBST x y (CDR z)))))
(defn APPEND
"Append the the elements of `y` to the elements of `x`.
All args are assumed to be `beowulf.cons-cell/ConsCell` objects.
See page 11 of the Lisp 1.5 Programmers Manual."
[x y]
(cond
(= x NIL) y
:else
(make-cons-cell (CAR x) (APPEND (CDR x) y))))
(defn MEMBER
"This predicate is true if the S-expression `x` occurs among the elements
of the list `y`.
All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects.
See page 11 of the Lisp 1.5 Programmers Manual."
[x y]
(cond
(= y NIL) F ;; NOTE: returns F on falsity, not NIL
(= (EQUAL x (CAR y)) T) T
:else (MEMBER x (CDR y))))
(defn PAIRLIS
"This function gives the list of pairs of corresponding elements of the
lists `x` and `y`, and APPENDs this to the list `a`. The resultant list
of pairs, which is like a table with two columns, is called an
association list.
Eessentially, it builds the environment on the stack, implementing shallow
binding.
All args are assumed to be `beowulf.cons-cell/ConsCell` objects.
See page 12 of the Lisp 1.5 Programmers Manual."
[x y a]
(cond
;; the original tests only x; testing y as well will be a little more
;; robust if `x` and `y` are not the same length.
(or (= NIL x) (= NIL y)) a
:else (make-cons-cell
(make-cons-cell (CAR x) (CAR y))
(PAIRLIS (CDR x) (CDR y) a))))
(defmacro QUOTE
"Quote, but in upper case for LISP 1.5"
[f]
`(quote ~f))
(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
it is a table searching function.
All args are assumed to be `beowulf.cons-cell/ConsCell` objects.
See page 12 of the Lisp 1.5 Programmers Manual."
[x a]
(cond
(= NIL a) NIL ;; this clause is not present in the original but is added for
;; robustness.
(= (EQUAL (CAAR a) x) T) (CAR a)
:else
(ASSOC x (CDR a))))
(defn- SUB2
"Internal to `SUBLIS`, q.v., which SUBSTitutes into a list from a store.
? I think this is doing variable binding in the stack frame?"
[a z]
(cond
(= NIL a) z
(= (CAAR a) z) (CDAR a) ;; TODO: this looks definitely wrong
:else
(SUB2 (CDR a) z)))
(defn SUBLIS
"Here `a` is assumed to be an association list of the form
`((ul . vl)...(un . vn))`, where the `u`s are atomic, and `y` is any
S-expression. What `SUBLIS` does, is to treat the `u`s as variables when
they occur in `y`, and to SUBSTitute the corresponding `v`s from the pair
list.
My interpretation is that this is variable binding in the stack frame.
All args are assumed to be `beowulf.cons-cell/ConsCell` objects.
See page 12 of the Lisp 1.5 Programmers Manual."
[a y]
(cond
(= (ATOM? y) T) (SUB2 a y)
:else
(make-cons-cell (SUBLIS a (CAR y)) (SUBLIS a (CDR y)))))
;;;; INTEROP feature ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn interop-interpret-q-name
"For interoperation with Clojure, it will often be necessary to pass
@ -318,10 +180,10 @@
f (cond
(try
(fn? (eval l-name))
(catch java.lang.ClassNotFoundException e nil)) l-name
(catch java.lang.ClassNotFoundException _ nil)) l-name
(try
(fn? (eval q-name))
(catch java.lang.ClassNotFoundException e nil)) q-name
(catch java.lang.ClassNotFoundException _ nil)) q-name
:else (throw
(ex-info
(str "INTEROP: unknown function `" fn-symbol "`")
@ -353,48 +215,6 @@
{:cause :interop
:detail :strict}))))
(defn OBLIST
"Return a list of the symbols currently bound on the object list.
**NOTE THAT** in the Lisp 1.5 manual, footnote at the bottom of page 69, it implies
that an argument can be passed but I'm not sure of the semantics of
this."
[]
(if (instance? ConsCell @oblist)
(make-beowulf-list (map CAR @oblist))
NIL))
(defn DEFINE
"Bootstrap-only version of `DEFINE` which, post boostrap, can be overwritten
in LISP.
The single argument to `DEFINE` should be an assoc list which should be
nconc'ed onto the front of the oblist. Broadly,
(SETQ OBLIST (NCONC ARG1 OBLIST))"
[args]
(swap!
oblist
(fn [ob arg1]
(loop [cursor arg1 a arg1]
(if (= (CDR cursor) NIL)
(do
(.rplacd cursor @oblist)
(pretty-print a)
a)
(recur (CDR cursor) a))))
(CAR args)))
(defn SET
"Implementation of SET in Clojure. Add to the `oblist` a binding of the
value of `var` to the value of `val`. NOTE WELL: this is not SETQ!"
[symbol val]
(when
(swap!
oblist
(fn [ob s v] (make-cons-cell (make-cons-cell s v) ob))
symbol val)
NIL))
(defn- traced-apply
"Like `APPLY`, but with trace output to console."
[function-symbol args lisp-fn environment depth]
@ -429,12 +249,11 @@
(case function-symbol ;; there must be a better way of doing this!
ADD1 (safe-apply ADD1 args)
AND (safe-apply AND args)
APPEND (safe-apply APPEND args)
APPLY (safe-apply APPLY args) ;; TODO: need to pass the environment and depth
ATOM (ATOM? (CAR args))
CAR (CAAR args)
CDR (CDAR args)
CONS (make-cons-cell (CAR args) (CADR args))
CAR (safe-apply CAR args)
CDR (safe-apply CDR args)
CONS (safe-apply CONS args)
DEFINE (DEFINE (CAR args))
DIFFERENCE (DIFFERENCE (CAR args) (CADR args))
EQ (safe-apply EQ args)

91
src/beowulf/cons_cell.clj
View file

@ -5,6 +5,26 @@
of Clojure lists."
(:require [beowulf.oblist :refer [NIL]]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Copyright (C) 2022-2023 Simon Brooke
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(declare cons-cell?)
(def T
@ -16,6 +36,8 @@
false in Lisp 1.5."
(symbol "F")) ;; false as distinct from nil
;;;; The actual cons-cell ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defprotocol MutableSequence
"Like a sequence, but mutable."
(rplaca
@ -31,9 +53,8 @@
[this]
"like `more`, q.v., but returns List `NIL` not Clojure `nil` when empty.")
(getUid
[this]
"Returns a unique identifier for this object")
)
[this]
"Returns a unique identifier for this object"))
(deftype ConsCell [^:unsynchronized-mutable CAR ^:unsynchronized-mutable CDR uid]
;; Note that, because the CAR and CDR fields are unsynchronised mutable - i.e.
@ -74,11 +95,11 @@
(str "Invalid value in RPLACD: `" value "` (" (type value) ")")
{:cause :bad-value
:detail :rplaca}))))
(getCar [this]
(. this CAR))
(getCdr [this]
(. this CDR))
(. this CDR))
(getUid [this]
(. this uid))
@ -140,11 +161,17 @@
(= NIL (. this CDR)) ")"
:else (str " . " (. this CDR) ")")))))
;;;; Printing. Here be dragons! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- to-string
"Printing ConsCells gave me a *lot* of trouble. This is an internal function
used by the print-method override (below) in order that the standard Clojure
`print` and `str` functions will print ConsCells correctly. The argument
`cell` must, obviously, be an instance of `ConsCell`."
;; TODO: I am deeply suspicious both of this and the defmethod which depends
;; on it. I *think* they are implicated in the `COPY` bug. If the `toString`
;; override in `ConsCell` was right, neither of these would be necessary.
;; see https://github.com/simon-brooke/beowulf/issues/5
[cell]
(loop [c cell
n 0
@ -170,6 +197,12 @@
ss))
(str c))))
(defmethod clojure.core/print-method
;;; I have not worked out how to document defmethod without blowing up the world.
beowulf.cons_cell.ConsCell
[this writer]
(.write writer (to-string this)))
(defn pretty-print
"This isn't the world's best pretty printer but it sort of works."
([^beowulf.cons_cell.ConsCell cell]
@ -204,12 +237,10 @@
ss))
(str c)))))
(defmethod clojure.core/print-method
;;; I have not worked out how to document defmethod without blowing up the world.
beowulf.cons_cell.ConsCell
[this writer]
(.write writer (to-string this)))
(defn cons-cell?
"Is this object `o` a beowulf cons-cell?"
[o]
(instance? beowulf.cons_cell.ConsCell o))
(defn make-cons-cell
"Construct a new instance of cons cell with this `car` and `cdr`."
@ -220,11 +251,6 @@
(throw (ex-info "Cound not construct cons cell" {:car car
:cdr cdr} any)))))
(defn cons-cell?
"Is this object `o` a beowulf cons-cell?"
[o]
(instance? beowulf.cons_cell.ConsCell o))
(defn make-beowulf-list
"Construct a linked list of cons cells with the same content as the
sequence `x`."
@ -245,36 +271,3 @@
(throw (ex-info "Could not construct Beowulf list"
{:content x}
any)))))
(defn CONS
"Construct a new instance of cons cell with this `car` and `cdr`."
[car cdr]
(beowulf.cons_cell.ConsCell. car cdr (gensym "c")))
(defn CAR
"Return the item indicated by the first pointer of a pair. NIL is treated
specially: the CAR of NIL is NIL."
[x]
(if
(= x NIL) NIL
(try
(or (.getCar x) NIL)
(catch Exception any
(throw (Exception.
(str "Cannot take CAR of `" x "` (" (.getName (.getClass x)) ")") any))))))
(defn CDR
"Return the item indicated by the second pointer of a pair. NIL is treated
specially: the CDR of NIL is NIL."
[x]
(if
(= x NIL) NIL
(try
(.getCdr x)
(catch Exception any
(throw (Exception.
(str "Cannot take CDR of `" x "` (" (.getName (.getClass x)) ")") any))))))
(defn LIST
[& args]
(make-beowulf-list args))

24
src/beowulf/core.clj
View file

@ -1,7 +1,7 @@
(ns beowulf.core
"Essentially, the `-main` function and the bootstrap read-eval-print loop."
(:require [beowulf.bootstrap :refer [EVAL]]
[beowulf.io :refer [SYSIN]]
[beowulf.io :refer [default-sysout SYSIN]]
[beowulf.read :refer [READ read-from-console]]
[beowulf.oblist :refer [*options* oblist]]
[clojure.java.io :as io]
@ -10,6 +10,26 @@
[clojure.tools.cli :refer [parse-opts]])
(:gen-class))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Copyright (C) 2022-2023 Simon Brooke
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def stop-word "STOP")
(def cli-options
@ -24,7 +44,7 @@
["-p PROMPT" "--prompt PROMPT" "Set the REPL prompt to PROMPT"
:default "Sprecan::"]
["-r INITFILE" "--read INITFILE" "Read Lisp system from file INITFILE"
:default "resources/lisp1.5.lsp"
:default default-sysout
:validate [#(and
(.exists (io/file %))
(.canRead (io/file %)))

93
src/beowulf/gendoc.clj
View file

@ -1,6 +1,31 @@
(ns beowulf.gendoc
(:require [beowulf.oblist :refer [oblist]]
[clojure.string :refer [join replace]]))
"Generate table of documentation of Lisp symbols and functions.
NOTE: this is *very* hacky. You almost certainly do not want to
use this!"
(:require [beowulf.io :refer [default-sysout SYSIN]]
[beowulf.oblist :refer [oblist]]
[clojure.string :refer [join replace upper-case]]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Copyright (C) 2022-2023 Simon Brooke
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def host-functions
"Functions which we can infer are written in Clojure."
@ -35,22 +60,43 @@
(let [fn (host-functions (symbol (first entry)))]
(get-metadata-for-function fn key)))
(defn infer-type
"Try to work out what this `entry` from the oblist actually
represents."
[entry]
(cond
(= (second entry) 'LAMBDA) "Lisp function"
(host-functions (first entry)) "Host function"
:else "?"))
(= (second entry) 'LABEL) "Labeled form"
(host-functions (first entry)) (if (fn? (eval (symbol (host-functions (first entry)))))
"Host function"
"Host variable")
:else "Lisp variable"))
(defn- format-clj-signature
"Format the signature of the Clojure function represented by `symbol` for
Lisp documentation."
[symbol arglists]
(join
"; "
(map
(fn [l]
(str
(cons symbol
(map #(upper-case (str %)) l))))
arglists)))
(defn infer-signature
"Infer the signature of the function value of this oblist `entry`, if any."
[entry]
(cond
(= (count entry) 1) (get-metadata-for-entry entry :arglists)
(= (second entry) 'LAMBDA) (nth entry 2)
(= (count entry) 1) (format-clj-signature
(first entry)
(get-metadata-for-entry entry :arglists))
(= (second entry) 'LAMBDA) (str (cons (first entry) (nth entry 2)))
:else "?"))
(defn find-documentation
"Find appropriate documentation for this `entry` from the oblist."
[entry]
(cond
(= (count entry) 1) (if-let [doc (get-metadata-for-entry entry :doc)]
@ -59,19 +105,24 @@
:else "?"))
(defn gen-doc-table
[]
(join
"\n"
(doall
(concat
'("| Symbol | Type | Signature | Documentation |"
"|--------|------|-----------|---------------|")
(map
#(format "| %s | %s | %s | %s |"
(first %)
(infer-type %)
(infer-signature %)
(find-documentation %))
@oblist)))))
([]
(gen-doc-table default-sysout))
([sysfile]
(try (SYSIN sysfile)
(catch Throwable any
(println (.getMessage any) " while reading " sysfile)))
(join
"\n"
(doall
(concat
'("| Symbol | Type | Signature | Documentation |"
"|--------|------|-----------|---------------|")
(map
#(format "| %s | %s | %s | %s |"
(first %)
(infer-type %)
(infer-signature %)
(find-documentation %))
@oblist))))))
;; (println (gen-doc-table))

451
src/beowulf/host.clj
View file

@ -3,17 +3,255 @@
be) implemented in Lisp 1.5, which therefore need to be implemented in the
host language, in this case Clojure."
(:require [clojure.string :refer [upper-case]]
[beowulf.cons-cell :refer [F make-beowulf-list T]]
[beowulf.cons-cell :refer [F make-cons-cell make-beowulf-list
pretty-print T]]
;; note hyphen - this is Clojure...
[beowulf.oblist :refer [NIL]])
[beowulf.oblist :refer [*options* oblist NIL]])
(:import [beowulf.cons_cell ConsCell]
;; note underscore - same namespace, but Java.
))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Copyright (C) 2022-2023 Simon Brooke
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; these are CANDIDATES to be host-implemented. only a subset of them MUST be.
;; those which can be implemented in Lisp should be, since that aids
;; portability.
(defn lax?
"Are we in lax mode? If so. return true; is not, throw an exception with
this `symbol`."
[symbol]
(when (:strict *options*)
(throw (ex-info (format "%s is not available in Lisp 1.5" symbol)
{:type :strict
:phase :host
:function symbol})))
true)
;;;; Basic operations on cons cells ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn CONS
"Construct a new instance of cons cell with this `car` and `cdr`."
[car cdr]
(beowulf.cons_cell.ConsCell. car cdr (gensym "c")))
(defn CAR
"Return the item indicated by the first pointer of a pair. NIL is treated
specially: the CAR of NIL is NIL."
[x]
(if
(= x NIL) NIL
(try
(or (.getCar x) NIL)
(catch Exception any
(throw (ex-info
(str "Cannot take CAR of `" x "` (" (.getName (.getClass x)) ")")
{:phase :host
:function 'CAR
:args (list x)
:type :beowulf}
;; startlingly, Lisp 1.5 did not flag an error when you took the
;; CAR of something that wasn't cons cell. The result, as the
;; manual says (page 56), could be garbage.
any))))))
(defn CDR
"Return the item indicated by the second pointer of a pair. NIL is treated
specially: the CDR of NIL is NIL."
[x]
(if
(= x NIL) NIL
(try
(.getCdr x)
(catch Exception any
(throw (ex-info
(str "Cannot take CDR of `" x "` (" (.getName (.getClass x)) ")")
{:phase :host
:function 'CDR
:args (list x)
:type :beowulf}
;; startlingly, Lisp 1.5 did not flag an error when you took the
;; CAR of something that wasn't cons cell. The result, as the
;; manual says (page 56), could be garbage.
any))))))
(defn uaf
"Universal access function; `l` is expected to be an arbitrary LISP list, `path`
a (clojure) list of the characters `a` and `d`. Intended to make declaring
all those fiddly `#'c[ad]+r'` functions a bit easier"
[l path]
(cond
(= l NIL) NIL
(empty? path) l
:else
(try
(case (last path)
\a (uaf (.first l) (butlast path))
\d (uaf (.getCdr l) (butlast path))
(throw (ex-info (str "uaf: unexpected letter in path (only `a` and `d` permitted): " (last path))
{:cause :uaf
:detail :unexpected-letter
:expr (last path)})))
(catch ClassCastException e
(throw (ex-info
(str "uaf: Not a LISP list? " (type l))
{:cause :uaf
:detail :not-a-lisp-list
:expr l}
e))))))
(defmacro CAAR [x] `(uaf ~x '(\a \a)))
(defmacro CADR [x] `(uaf ~x '(\a \d)))
(defmacro CDDR [x] `(uaf ~x '(\d \d)))
(defmacro CDAR [x] `(uaf ~x '(\d \a)))
(defmacro CAAAR [x] `(uaf ~x '(\a \a \a)))
(defmacro CAADR [x] `(uaf ~x '(\a \a \d)))
(defmacro CADAR [x] `(uaf ~x '(\a \d \a)))
(defmacro CADDR [x] `(uaf ~x '(\a \d \d)))
(defmacro CDDAR [x] `(uaf ~x '(\d \d \a)))
(defmacro CDDDR [x] `(uaf ~x '(\d \d \d)))
(defmacro CDAAR [x] `(uaf ~x '(\d \a \a)))
(defmacro CDADR [x] `(uaf ~x '(\d \a \d)))
(defmacro CAAAAR [x] `(uaf ~x '(\a \a \a \a)))
(defmacro CAADAR [x] `(uaf ~x '(\a \a \d \a)))
(defmacro CADAAR [x] `(uaf ~x '(\a \d \a \a)))
(defmacro CADDAR [x] `(uaf ~x '(\a \d \d \a)))
(defmacro CDDAAR [x] `(uaf ~x '(\d \d \a \a)))
(defmacro CDDDAR [x] `(uaf ~x '(\d \d \d \a)))
(defmacro CDAAAR [x] `(uaf ~x '(\d \a \a \a)))
(defmacro CDADAR [x] `(uaf ~x '(\d \a \d \a)))
(defmacro CAAADR [x] `(uaf ~x '(\a \a \a \d)))
(defmacro CAADDR [x] `(uaf ~x '(\a \a \d \d)))
(defmacro CADADR [x] `(uaf ~x '(\a \d \a \d)))
(defmacro CADDDR [x] `(uaf ~x '(\a \d \d \d)))
(defmacro CDDADR [x] `(uaf ~x '(\d \d \a \d)))
(defmacro CDDDDR [x] `(uaf ~x '(\d \d \d \d)))
(defmacro CDAADR [x] `(uaf ~x '(\d \a \a \d)))
(defmacro CDADDR [x] `(uaf ~x '(\d \a \d \d)))
(defn RPLACA
"Replace the CAR pointer of this `cell` with this `value`. Dangerous, should
really not exist, but does in Lisp 1.5 (and was important for some
performance hacks in early Lisps)"
[^ConsCell cell value]
(if
(instance? ConsCell cell)
(if
(or
(instance? ConsCell value)
(number? value)
(symbol? value)
(= value NIL))
(do
(.rplaca cell value)
cell)
(throw (ex-info
(str "Invalid value in RPLACA: `" value "` (" (type value) ")")
{:cause :bad-value
:detail :rplaca})))
(throw (ex-info
(str "Invalid cell in RPLACA: `" cell "` (" (type cell) ")")
{:cause :bad-value
:detail :rplaca}))))
(defn RPLACD
"Replace the CDR pointer of this `cell` with this `value`. Dangerous, should
really not exist, but does in Lisp 1.5 (and was important for some
performance hacks in early Lisps)"
[^ConsCell cell value]
(if
(instance? ConsCell cell)
(if
(or
(instance? ConsCell value)
(number? value)
(symbol? value)
(= value NIL))
(do
(.rplacd cell value)
cell)
(throw (ex-info
(str "Invalid value in RPLACD: `" value "` (" (type value) ")")
{:cause :bad-value
:detail :rplaca})))
(throw (ex-info
(str "Invalid cell in RPLACD: `" cell "` (" (type cell) ")")
{:cause :bad-value
:detail :rplaca}))));; PLUS
(defn LIST
[& args]
(make-beowulf-list args))
;;;; Basic predicates ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmacro NULL
"Returns `T` if and only if the argument `x` is bound to `NIL`; else `F`."
[x]
`(if (= ~x NIL) T F))
(defmacro NILP
"Not part of LISP 1.5: `T` if `o` is `NIL`, else `NIL`."
[x]
`(if (= ~x NIL) T NIL))
(defn ATOM
"Returns `T` if and only if the argument `x` is bound to an atom; else `F`.
It is not clear to me from the documentation whether `(ATOM 7)` should return
`T` or `F`. I'm going to assume `T`."
[x]
(if (or (symbol? x) (number? x)) T F))
(defmacro ATOM?
"The convention of returning `F` from predicates, rather than `NIL`, is going
to tie me in knots. This is a variant of `ATOM` which returns `NIL`
on failure."
[x]
`(if (or (symbol? ~x) (number? ~x)) T NIL))
(defn EQ
"Returns `T` if and only if both `x` and `y` are bound to the same atom,
else `NIL`."
[x y]
(cond (and (instance? ConsCell x)
(.equals x y)) T
(and (= (ATOM x) T) (= x y)) T
:else NIL))
(defn EQUAL
"This is a predicate that is true if its two arguments are identical
S-expressions, and false if they are different. (The elementary predicate
`EQ` is defined only for atomic arguments.) The definition of `EQUAL` is
an example of a conditional expression inside a conditional expression.
NOTE: returns `F` on failure, not `NIL`"
[x y]
(cond
(= (ATOM x) T) (if (= x y) T F)
(= (EQUAL (CAR x) (CAR y)) T) (EQUAL (CDR x) (CDR y))
:else F))
(defn AND
"`T` if and only if none of my `args` evaluate to either `F` or `NIL`,
else `F`.
@ -25,55 +263,86 @@
'T
'F))
(defn RPLACA
"Replace the CAR pointer of this `cell` with this `value`. Dangerous, should
really not exist, but does in Lisp 1.5 (and was important for some
performance hacks in early Lisps)"
[^ConsCell cell value]
(if
(instance? ConsCell cell)
(if
(or
(instance? ConsCell value)
(number? value)
(symbol? value)
(= value NIL))
(do
(.rplaca cell value)
cell)
(throw (ex-info
(str "Invalid value in RPLACA: `" value "` (" (type value) ")")
{:cause :bad-value
:detail :rplaca})))
(throw (ex-info
(str "Invalid cell in RPLACA: `" cell "` (" (type cell) ")")
{:cause :bad-value
:detail :rplaca}))))
;;;; Operations on lists ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; TODO: These are candidates for moving to Lisp urgently!
(defn RPLACD
"Replace the CDR pointer of this `cell` with this `value`. Dangerous, should
really not exist, but does in Lisp 1.5 (and was important for some
performance hacks in early Lisps)"
[^ConsCell cell value]
(if
(instance? ConsCell cell)
(if
(or
(instance? ConsCell value)
(number? value)
(symbol? value)
(= value NIL))
(do
(.rplacd cell value)
cell)
(throw (ex-info
(str "Invalid value in RPLACD: `" value "` (" (type value) ")")
{:cause :bad-value
:detail :rplaca})))
(throw (ex-info
(str "Invalid cell in RPLACD: `" cell "` (" (type cell) ")")
{:cause :bad-value
:detail :rplaca}))));; PLUS
(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
it is a table searching function.
All args are assumed to be `beowulf.cons-cell/ConsCell` objects.
See page 12 of the Lisp 1.5 Programmers Manual."
[x a]
(cond
(= NIL a) NIL ;; this clause is not present in the original but is added for
;; robustness.
(= (EQUAL (CAAR a) x) T) (CAR a)
:else
(ASSOC x (CDR a))))
(defn- SUB2
"Internal to `SUBLIS`, q.v., which SUBSTitutes into a list from a store.
? I think this is doing variable binding in the stack frame?"
[a z]
(cond
(= NIL a) z
(= (CAAR a) z) (CDAR a) ;; TODO: this looks definitely wrong
:else
(SUB2 (CDR a) z)))
(defn SUBLIS
"Here `a` is assumed to be an association list of the form
`((ul . vl)...(un . vn))`, where the `u`s are atomic, and `y` is any
S-expression. What `SUBLIS` does, is to treat the `u`s as variables when
they occur in `y`, and to SUBSTitute the corresponding `v`s from the pair
list.
My interpretation is that this is variable binding in the stack frame.
All args are assumed to be `beowulf.cons-cell/ConsCell` objects.
See page 12 of the Lisp 1.5 Programmers Manual."
[a y]
(cond
(= (ATOM? y) T) (SUB2 a y)
:else
(make-cons-cell (SUBLIS a (CAR y)) (SUBLIS a (CDR y)))))
(defn SUBST
"This function gives the result of substituting the S-expression `x` for
all occurrences of the atomic symbol `y` in the S-expression `z`."
[x y z]
(cond
(= (EQUAL y z) T) x
(= (ATOM? z) T) z ;; NIL is a symbol
:else
(make-cons-cell (SUBST x y (CAR z)) (SUBST x y (CDR z)))))
(defn PAIRLIS
"This function gives the list of pairs of corresponding elements of the
lists `x` and `y`, and APPENDs this to the list `a`. The resultant list
of pairs, which is like a table with two columns, is called an
association list.
Eessentially, it builds the environment on the stack, implementing shallow
binding.
All args are assumed to be `beowulf.cons-cell/ConsCell` objects.
See page 12 of the Lisp 1.5 Programmers Manual."
[x y a]
(cond
;; the original tests only x; testing y as well will be a little more
;; robust if `x` and `y` are not the same length.
(or (= NIL x) (= NIL y)) a
:else (make-cons-cell
(make-cons-cell (CAR x) (CAR y))
(PAIRLIS (CDR x) (CDR y) a))))
;;;; Arithmetic ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; TODO: When in strict mode, should we limit arithmetic precision to that
;; supported by Lisp 1.5?
(defn PLUS
[& args]
@ -118,6 +387,16 @@
[x]
(if (number? x) T F))
(defn LESSP
[x y]
(< x y))
(defn GREATERP
[x y]
(> x y))
;;;; Miscellaneous ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn GENSYM
"Generate a unique symbol."
[]
@ -129,10 +408,70 @@
(throw (ex-info "LISP ERROR" {:cause (apply vector args)
:phase :eval})))
(defn LESSP
[x y]
(< x y))
;;;; Assignment and the object list ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn GREATERP
[x y]
(> x y))
(defn OBLIST
"Return a list of the symbols currently bound on the object list.
**NOTE THAT** in the Lisp 1.5 manual, footnote at the bottom of page 69, it implies
that an argument can be passed but I'm not sure of the semantics of
this."
[]
(if (instance? ConsCell @oblist)
(make-beowulf-list (map CAR @oblist))
NIL))
(defn DEFINE
"Bootstrap-only version of `DEFINE` which, post boostrap, can be overwritten
in LISP.
The single argument to `DEFINE` should be an assoc list which should be
nconc'ed onto the front of the oblist. Broadly,
(SETQ OBLIST (NCONC ARG1 OBLIST))"
[args]
(swap!
oblist
(fn [ob arg1]
(loop [cursor arg1 a arg1]
(if (= (CDR cursor) NIL)
(do
(.rplacd cursor @oblist)
(pretty-print a)
a)
(recur (CDR cursor) a))))
(CAR args)))
(defn SET
"Implementation of SET in Clojure. Add to the `oblist` a binding of the
value of `var` to the value of `val`. NOTE WELL: this is not SETQ!"
[symbol val]
(when
(swap!
oblist
(fn [ob s v] (make-cons-cell (make-cons-cell s v) ob))
symbol val)
NIL))
;;;; TRACE and friends ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def traced-symbols
"Symbols currently being traced."
(atom #{}))
(defn traced?
"Return `true` iff `s` is a symbol currently being traced, else `nil`."
[s]
(try (contains? @traced-symbols s)
(catch Throwable _)))
(defn TRACE
"Add this symbol `s` to the set of symbols currently being traced. If `s`
is not a symbol, does nothing."
[s]
(when (symbol? s)
(swap! traced-symbols #(conj % s))))
(defn UNTRACE
[s]
(when (symbol? s)
(swap! traced-symbols #(set (remove (fn [x] (= s x)) %)))))

24
src/beowulf/io.clj
View file

@ -22,6 +22,28 @@
[clojure.string :refer [ends-with?]]
[java-time.api :refer [local-date local-date-time]]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Copyright (C) 2022-2023 Simon Brooke
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def ^:constant default-sysout "resources/lisp1.5.lsp")
(defn- full-path
[fp]
(str
@ -72,7 +94,7 @@
if you're writing it from the Lisp REPL, it won't), the extension `.lsp`
will be appended."
([]
(SYSIN (or (:read *options*) "resources/lisp1.5.lsp")))
(SYSIN (or (:read *options*) default-sysout)))
([filename]
(let [fp (file (full-path (str filename)))
file (when (and (.exists fp) (.canRead fp)) fp)

25
src/beowulf/oblist.clj
View file

@ -1,10 +1,31 @@
(ns beowulf.oblist
"A namespace mainly devoted to the object list.
"A namespace mainly devoted to the object list and other top level
global variables.
Yes, this makes little sense, but if you put it anywhere else you end
Yes, this makes little sense, but if you put them anywhere else you end
up in cyclic dependency hell."
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Copyright (C) 2022-2023 Simon Brooke
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def NIL
"The canonical empty list symbol.

18
src/beowulf/read.clj
View file

@ -28,6 +28,24 @@
;;; the real Lisp reader.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Copyright (C) 2022-2023 Simon Brooke
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn strip-line-comments
"Strip blank lines and comment lines from this string `s`, expected to

20
src/beowulf/reader/char_reader.clj
View file

@ -19,6 +19,26 @@
(:import [org.jline.reader LineReader LineReaderBuilder]
[org.jline.terminal TerminalBuilder]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Copyright (C) 2022-2023 Simon Brooke
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; It looks from the example given [here](https://github.com/jline/jline3/blob/master/demo/src/main/java/org/jline/demo/Repl.java)
;; as though JLine could be used to build a perfect line-reader for Beowulf; but it also
;; looks as though you'd need a DPhil in JLine to write it, and I don't have

19
src/beowulf/reader/generate.clj
View file

@ -61,6 +61,25 @@
[clojure.math.numeric-tower :refer [expt]]
[clojure.string :refer [upper-case]]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Copyright (C) 2022-2023 Simon Brooke
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(declare generate)

53
src/beowulf/reader/macros.clj
View file

@ -1,17 +1,48 @@
(ns beowulf.reader.macros
"Can I implement reader macros? let's see!"
(:require [beowulf.cons-cell :refer [CONS LIST make-beowulf-list]]
[clojure.string :refer [join]])
(:import [beowulf.cons_cell ConsCell]))
"Can I implement reader macros? let's see!
We don't need (at least, in the Clojure reader) to rewrite forms like
`'FOO`, because that's handled by the parser. But we do need to rewrite
things which don't evaluate their arguments, like `SETQ`, because (unless
LABEL does it, which I'm not yet sure of) we're not yet able to implement
things which don't evaluate arguments.
;; We don't need (at least, in the Clojure reader) to rewrite forms like
;; "'FOO", because that's handled by the parser. But we do need to rewrite
;; things which don't evaluate their arguments, like `SETQ`, because (unless
;; LABEL does it, which I'm not yet sure of) we're not yet able to implement
;; things which don't evaluate arguments.
TODO: at this stage, the following should probably also be read macros:
DEFINE"
(:require [beowulf.cons-cell :refer [make-beowulf-list]]
[beowulf.host :refer [CONS LIST]]
[clojure.string :refer [join]]))
;; TODO: at this stage, the following should probably also be read macros:
;; DEFINE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; We don't need (at least, in the Clojure reader) to rewrite forms like
;;; "'FOO", because that's handled by the parser. But we do need to rewrite
;;; things which don't evaluate their arguments, like `SETQ`, because (unless
;;; LABEL does it, which I'm not yet sure of) we're not yet able to implement
;;; things which don't evaluate arguments.
;;;
;;; TODO: at this stage, the following should probably also be read macros:
;;; DEFINE
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Copyright (C) 2022-2023 Simon Brooke
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def ^:dynamic *readmacros*
{:car {'DEFUN (fn [f]

20
src/beowulf/reader/parser.clj
View file

@ -2,6 +2,26 @@
"The actual parser, supporting both S-expression and M-expression syntax."
(:require [instaparse.core :as i]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Copyright (C) 2022-2023 Simon Brooke
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def parse
"Parse a string presented as argument into a parse tree which can then
be operated upon further."

20
src/beowulf/reader/simplify.clj
View file

@ -5,6 +5,26 @@
[instaparse.failure :as f])
(:import [instaparse.gll Failure]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Copyright (C) 2022-2023 Simon Brooke
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(declare simplify)
(defn remove-optional-space

24
src/beowulf/trace.clj
View file

@ -1,24 +0,0 @@
(ns beowulf.trace
"Tracing of function execution")
(def traced-symbols
"Symbols currently being traced."
(atom #{}))
(defn traced?
"Return `true` iff `s` is a symbol currently being traced, else `nil`."
[s]
(try (contains? @traced-symbols s)
(catch Throwable _)))
(defn TRACE
"Add this symbol `s` to the set of symbols currently being traced. If `s`
is not a symbol, does nothing."
[s]
(when (symbol? s)
(swap! traced-symbols #(conj % s))))
(defn UNTRACE
[s]
(when (symbol? s)
(swap! traced-symbols #(set (remove (fn [x] (= s x)) %)))))

44
test/beowulf/bootstrap_test.clj
View file

@ -1,8 +1,8 @@
(ns beowulf.bootstrap-test
(:require [clojure.test :refer [deftest testing is]]
[beowulf.cons-cell :refer [CAR CDR make-cons-cell T F]]
[beowulf.bootstrap :refer [APPEND ASSOC ATOM ATOM? CAAAAR CADR
CADDR CADDDR EQ EQUAL MEMBER
[beowulf.cons-cell :refer [make-cons-cell T F]]
[beowulf.host :refer [ASSOC ATOM ATOM? CAR CAAAAR CADR
CADDR CADDDR CDR EQ EQUAL
PAIRLIS SUBLIS SUBST]]
[beowulf.oblist :refer [NIL]]
[beowulf.read :refer [gsp]]))
@ -165,44 +165,6 @@
(gsp "((A . B) . C)")))]
(is (= actual expected)))))
(deftest append-tests
(testing "append"
(let [expected "(A B C . D)"
actual (print-str
(APPEND
(gsp "(A B)")
(gsp "(C . D)")))]
(is (= actual expected)))
(let [expected "(A B C D E)"
actual (print-str
(APPEND
(gsp "(A B)")
(gsp "(C D E)")))]
(is (= actual expected)))))
(deftest member-tests
(testing "member"
(let [expected 'T
actual (MEMBER
(gsp "ALBERT")
(gsp "(ALBERT BELINDA CHARLIE DORIS ELFREDA FRED)"))]
(is (= actual expected)))
(let [expected 'T
actual (MEMBER
(gsp "BELINDA")
(gsp "(ALBERT BELINDA CHARLIE DORIS ELFREDA FRED)"))]
(is (= actual expected)))
(let [expected 'T
actual (MEMBER
(gsp "ELFREDA")
(gsp "(ALBERT BELINDA CHARLIE DORIS ELFREDA FRED)"))]
(is (= actual expected)))
(let [expected 'F
actual (MEMBER
(gsp "BERTRAM")
(gsp "(ALBERT BELINDA CHARLIE DORIS ELFREDA FRED)"))]
(is (= actual expected)))))
(deftest pairlis-tests
(testing "pairlis"
(let [expected "((A . U) (B . V) (C . W) (D . X) (E . Y))"

4
test/beowulf/host_test.clj
View file

@ -1,7 +1,7 @@
(ns beowulf.host-test
(:require [clojure.test :refer [deftest is testing]]
[beowulf.cons-cell :refer [CDR F make-beowulf-list T]]
[beowulf.host :refer [DIFFERENCE NUMBERP PLUS RPLACA RPLACD TIMES]]
[beowulf.cons-cell :refer [F make-beowulf-list T]]
[beowulf.host :refer [CDR DIFFERENCE NUMBERP PLUS RPLACA RPLACD TIMES]]
[beowulf.oblist :refer [NIL]]
[beowulf.read :refer [gsp]]))

164
test/beowulf/lisp_test.clj
View file

@ -4,29 +4,147 @@
[beowulf.bootstrap :refer [EVAL]]
[beowulf.cons-cell :refer [make-beowulf-list]]
[beowulf.io :refer [SYSIN]]
;; [beowulf.oblist :refer [NIL]]
[beowulf.read :refer [READ]]))
;; (use-fixtures :once (fn [f]
;; (try (SYSIN "resources/lisp1.5.lsp")
;; (f)
;; (catch Throwable any
;; (throw (ex-info "Failed to load Lisp sysout"
;; {:phase test
;; :function 'SYSIN
;; :file "resources/lisp1.5.lsp"}))))))
(defn- reps
"'Read eval print string', or 'read eval print single'.
Reads and evaluates one input string, and returns the
output string."
[input]
(with-out-str (print (EVAL (READ input)))))
;; (deftest "COPY test"
;; ;; (testing "copy NIL"
;; ;; (println "in-test: " (SYSIN "resources/lisp1.5.lsp"))
;; ;; (let [expected "NIL"
;; ;; actual (with-out-str (println (EVAL (READ "(COPY NIL)"))))]
;; ;; (is (= actual expected))))
;; (testing "copy straight list"
;; (println "in-test: " (SYSIN "resources/lisp1.5.lsp"))
;; (let [expected (make-beowulf-list '(A B C))
;; actual (with-out-str (print (EVAL (READ "(COPY '(A B C))"))))]
;; (is (= actual expected))))
;; (testing "copy assoc list"
;; (let [expected "((A . 1) (B . 2) (C . 3))"
;; actual (with-out-str (println (EVAL (READ "(COPY '((A . 1) (B . 2) (C . 3)))"))))]
;; (is (= actual expected)))))
(use-fixtures :once (fn [f]
(try (when (SYSIN "resources/lisp1.5.lsp")
(f))
(catch Throwable any
(throw (ex-info "Failed to load Lisp sysout"
{:phase test
:function 'SYSIN
:file "resources/lisp1.5.lsp"}
any))))))
(deftest APPEND-tests
(testing "append - dot-terminated lists"
(let [expected "(A B C . D)"
actual (reps "(APPEND '(A B) (CONS 'C 'D))")]
(is (= actual expected)))
(let [expected "(A B C . D)"
actual (reps "(APPEND (CONS 'A (CONS 'B NIL)) (CONS 'C 'D))")]
(is (= actual expected)))
;; this is failing: https://github.com/simon-brooke/beowulf/issues/5
(let [expected "(A B C . D)"
actual (reps "(APPEND '(A B) '(C . D))")]
(is (= actual expected))))
(testing "append - straight lists"
(let [expected "(A B C D E)"
actual (reps "(APPEND '(A B) '(C D E))")]
(is (= actual expected)))))
(deftest COPY-tests
(testing "copy NIL"
(let [expected "NIL"
actual (with-out-str (print (EVAL (READ "(COPY NIL)"))))]
(is (= actual expected))))
(testing "copy straight list"
(let [expected (make-beowulf-list '(A B C))
actual (EVAL (READ "(COPY '(A B C))"))]
(is (= actual expected))))
(testing "copy assoc list created in READ"
;; this is failing. Problem in READ?
;; see https://github.com/simon-brooke/beowulf/issues/5
(let [expected (READ "((A . 1) (B . 2) (C . 3))")
actual (EVAL (READ "(COPY '((A . 1) (B . 2) (C . 3)))"))]
(is (= actual expected))))
(testing "copy assoc list created with PAIR"
(let [expected (READ "((A . 1) (B . 2) (C . 3))")
actual (EVAL (READ "(COPY (PAIR '(A B C) '(1 2 3)))"))]
(is (= actual expected)))))
(deftest DIVIDE-tests
(testing "rational divide"
(let [expected "(4 0)"
input "(DIVIDE 8 2)"
actual (reps input)]
(is (= actual expected))))
(testing "irrational divide"
(let [expected "(3.142857 1)"
input "(DIVIDE 22 7)"
actual (reps input)]
(is (= actual expected))))
(testing "divide by zero"
(let [input "(DIVIDE 22 0)"]
(is (thrown-with-msg? ArithmeticException
#"Divide by zero"
(reps input)))))
;; TODO: need to write tests for GET but I don't really
;; understand what the correct behaviour is.
(deftest INTERSECTION-tests
(testing "non-intersecting"
(let [expected "NIL"
input "(INTERSECTION '(A B C) '(D E F))"
actual (reps input)]
(is (= actual expected))))
(testing "intersection with NIL"
(let [expected "NIL"
input "(INTERSECTION '(A B C) NIL)"
actual (reps input)]
(is (= actual expected))))
(testing "intersection with NIL (2)"
(let [expected "NIL"
input "(INTERSECTION NIL '(A B C))"
actual (reps input)]
(is (= actual expected))))
(testing "sequential intersection"
(let [expected "(C D)"
input "(INTERSECTION '(A B C D) '(C D E F))"
actual (reps input)]
(is (= actual expected))))
(testing "non-sequential intersection"
(let [expected "(C D)"
input "(INTERSECTION '(A B C D) '(F D E C))"
actual (reps input)]
(is (= actual expected)))))
(deftest LENGTH-tests
(testing "length of NIL"
(let [expected "0"
input "(LENGTH NIL)"
actual (reps input)]
(is (= actual expected))))
(testing "length of simple list"
(let [expected "3"
input "(LENGTH '(1 2 3))"
actual (reps input)]
(is (= actual expected))))
(testing "length of dot-terminated list"
(let [expected "3"
input "(LENGTH '(1 2 3 . 4))"
actual (reps input)]
(is (= actual expected))))
(testing "length of assoc list"
(let [expected "3"
input "(LENGTH (PAIR '(A B C) '(1 2 3)))"
actual (reps input)]
(is (= actual expected))))))
(deftest MEMBER-tests
(testing "member"
(let [expected "T"
actual (reps "(MEMBER 'ALBERT '(ALBERT BELINDA CHARLIE DORIS ELFREDA FRED))")]
(is (= actual expected)))
(let [expected "T"
actual (reps "(MEMBER 'BELINDA '(ALBERT BELINDA CHARLIE DORIS ELFREDA FRED))")]
(is (= actual expected)))
(let [expected "T"
actual (reps "(MEMBER 'ELFREDA '(ALBERT BELINDA CHARLIE DORIS ELFREDA FRED))")]
(is (= actual expected)))
(let [expected "F"
actual (reps "(MEMBER 'BERTRAM '(ALBERT BELINDA CHARLIE DORIS ELFREDA FRED))")]
(is (= actual expected)))))