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

There are regressions, tests are failing, but EVAL is beginning to work

Browse source
This commit is contained in:
Simon Brooke 2023-03-27 11:57:08 +01:00
parent 269d31df13
commit fec6a6a73a
No known key found for this signature in database
GPG key ID: A7A4F18D1D4DF987
8 changed files with 143 additions and 71 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
resources/null.mexpr.lsp Normal file
View file

@ -0,0 +1 @@
null[x] = [x = NIL -> T; T -> F]

147
src/beowulf/bootstrap.clj
View file

@ -13,11 +13,12 @@
[clojure.tools.trace :refer [deftrace]]
[beowulf.cons-cell :refer [CAR CDR CONS LIST make-beowulf-list make-cons-cell
pretty-print T F]]
[beowulf.host :refer [ADD1 DIFFERENCE FIXP NUMBERP PLUS2 QUOTIENT
REMAINDER RPLACA RPLACD SUB1 TIMES2]]
[beowulf.host :refer [ADD1 DIFFERENCE FIXP NUMBERP PLUS QUOTIENT
REMAINDER RPLACA RPLACD SUB1 TIMES]]
[beowulf.io :refer [SYSIN SYSOUT]]
[beowulf.oblist :refer [*options* oblist NIL]])
(:import [beowulf.cons_cell ConsCell]))
(:import [beowulf.cons_cell ConsCell]
[clojure.lang Symbol]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
@ -29,7 +30,7 @@
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(declare EVAL)
(declare APPLY EVAL)
(defmacro NULL
@ -379,42 +380,62 @@
symbol val)
NIL))
(defn APPLY
"For bootstrapping, at least, a version of APPLY written in Clojure.
All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects.
See page 13 of the Lisp 1.5 Programmers Manual."
(defn- apply-symbolic
"Apply this `funtion-symbol` to these `args` in this `environment` and
return the result."
[^Symbol function-symbol ^ConsCell args ^ConsCell environment]
(let [fn (try (EVAL function-symbol environment)
(catch Throwable any (when (:trace *options*)
(println any))))]
(if (and fn (not= fn NIL))
(APPLY fn args environment)
(case function-symbol ;; there must be a better way of doing this!
ADD1 (apply ADD1 args)
APPEND (apply APPEND args)
APPLY (apply APPLY args)
ATOM (ATOM? (CAR args))
CAR (CAAR args)
CDR (CDAR args)
CONS (make-cons-cell (CAR args) (CADR args))
DEFINE (DEFINE (CAR args))
DIFFERENCE (DIFFERENCE (CAR args) (CADR args))
EQ (apply EQ args)
;; think about EVAL. Getting the environment right is subtle
FIXP (apply FIXP args)
INTEROP (apply INTEROP args)
NUMBERP (apply NUMBERP args)
PLUS (apply PLUS args)
PRETTY (apply pretty-print args)
QUOTIENT (apply QUOTIENT args)
REMAINDER (apply REMAINDER args)
RPLACA (apply RPLACA args)
RPLACD (apply RPLACD args)
SET (apply SET args)
SYSIN (apply SYSIN args)
SYSOUT (apply SYSOUT args)
TIMES (apply TIMES args)
;; else
(ex-info "No function found"
{:context "APPLY"
:function function-symbol
:args args})))))
(defn apply-internal
"Internal guts of both `APPLY` and `traced-apply`. Apply this `function` to
these `arguments` in this `environment` and return the result.
For bootstrapping, at least, a version of APPLY written in Clojure.
All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects.
See page 13 of the Lisp 1.5 Programmers Manual."
[function args environment]
(cond
(= NIL function) (throw (ex-info "NIL is not a function" {:context "APPLY"
:function "NIL"
:args args}))
(=
(ATOM? function)
T) (cond
;; (fn? (eval function)) (apply (eval function) args)
(not=
(ASSOC function environment)
NIL) (APPLY (CDR (ASSOC function environment)) args environment)
(= function 'ATOM) (if (ATOM? (CAR args)) T NIL)
(= function 'CAR) (CAAR args)
(= function 'CDR) (CDAR args)
(= function 'CONS) (make-cons-cell (CAR args) (CADR args))
(= function 'DEFINE) (DEFINE args)
(= function 'EQ) (apply EQ args)
(= function 'INTEROP) (INTEROP (CAR args) (CDR args))
(= function 'SET) (SET (CAR args) (CADR args))
(= function 'SYSIN) (SYSIN (CAR args))
(= function 'SYSOUT) (SYSOUT (CAR args))
(EVAL function environment) (APPLY
(EVAL function environment)
args
environment)
:else
(throw (ex-info "No function found" {:context "APPLY"
:function function
:args args})))
(fn? function) ;; i.e., it's a Clojure function
(apply function (to-clojure args))
(= NIL function) (if (:strict *options*)
NIL
(throw (ex-info "NIL is not a function"
{:context "APPLY"
:function "NIL"
:args args})))
(= (ATOM? function) T) (apply-symbolic function args environment)
(= (first function) 'LAMBDA) (EVAL
(CADDR function)
(PAIRLIS (CADR function) args environment))
@ -427,8 +448,27 @@
(CADDR function))
environment))))
(deftrace traced-apply
"Traced wrapper for `internal-apply`, q.v. Apply this `function` to
these `arguments` in this `environment` and return the result."
[function args environment]
(apply-internal function args environment))
(defn APPLY
"Despatcher for APPLY, selects beteen `traced-apply` and `apply-internal`
based on the value of `:trace` in `*options*`. Apply this `function` to
these `arguments` and return the result. If `environment` is not passed,
if defaults to the current value of the global object list."
([function args]
(APPLY function args @oblist))
([function args environment]
(if
(:trace *options*)
(traced-apply function args environment)
(apply-internal function args environment))))
(defn- EVCON
"Inner guts of primitive COND. All args are assumed to be
"Inner guts of primitive COND. All `clauses` are assumed to be
`beowulf.cons-cell/ConsCell` objects.
See page 13 of the Lisp 1.5 Programmers Manual."
[clauses env]
@ -449,20 +489,33 @@
(EVAL (CAR args) env)
(EVLIS (CDR args) env))))
(defn eval-internal
"Common guts for both EVAL and traced-eval"
(defn- eval-symbolic [^Symbol s env]
(let [binding (CDR (ASSOC s env))]
(if (= binding NIL)
(throw (ex-info (format "No binding for symbol `%s`" s)
{:phase :eval
:symbol s}))
binding)))
(defn- eval-internal
"Common guts for both EVAL and traced-eval. Evaluate this `expr`
and return the result.
For bootstrapping, at least, this is a version of EVAL written in Clojure.
All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects.
See page 13 of the Lisp 1.5 Programmers Manual."
[expr env]
(cond
(= (NUMBERP expr) T) expr
(symbol? expr) (eval-symbolic expr env)
(string? expr) (if (:strict *options*)
(throw
(ex-info
(str "EVAL: strings not allowed in strict mode: \"" expr "\"")
{:cause :eval
{:phase :eval
:detail :strict
:expr expr}))
(symbol expr))
(= (ATOM? expr) T) (CDR (ASSOC expr env))
(=
(ATOM? (CAR expr))
T) (cond
@ -494,9 +547,11 @@
(defn EVAL
"For bootstrapping, at least, a version of EVAL written in Clojure.
All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects.
See page 13 of the Lisp 1.5 Programmers Manual."
"Despatcher for EVAL, selects beteen `traced-eval` and `eval-internal`
based on the value of `:trace` in `*options*`. Evaluate this `expr`
and return the result. If `environment` is not passed,
if defaults to the current value of the global object list.
All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects."
([expr]
(EVAL expr @oblist))
([expr env]

15
src/beowulf/host.clj
View file

@ -63,17 +63,14 @@
{:cause :bad-value
:detail :rplaca}))));; PLUS
(defn PLUS2
"Lisp 1.5 `PLUS` is varargs, and implementing varargs functions in Clojure is
not an added complexity I want. So this is a two arg `PLUS`, on which a
varargs `PLUS` can be built in the Lisp 1.5 layer using `REDUCE`."
[x y]
(let [s (+ x y)]
(defn PLUS
[& args]
(let [s (apply + args)]
(if (integer? s) s (float s))))
(defn TIMES2
[x y]
(let [p (* x y)]
(defn TIMES
[& args]
(let [p (apply * args)]
(if (integer? p) p (float p))))
(defn DIFFERENCE

2
src/beowulf/io.clj
View file

@ -48,7 +48,7 @@
(with-out-str
(println (apply str (repeat 79 ";")))
(println (format ";; Beowulf %s Sysout file generated at %s"
(System/getProperty "beowulf.version")
(or (System/getProperty "beowulf.version") "")
(local-date-time)))
(when (System/getenv "USER")
(println (format ";; generated by %s" (System/getenv "USER"))))

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

@ -130,7 +130,7 @@
(defn gen-iexpr
[tree]
(let [bundle (reduce #(assoc %1 (first %2) (nth %2 1))
(let [bundle (reduce #(assoc %1 (first %2) %2)
{}
(rest tree))]
(list (generate (:iop bundle))
@ -194,9 +194,22 @@
:exponent (generate (second p))
:fncall (gen-fn-call p)
:iexpr (gen-iexpr p)
:iop (case (second p)
"/" 'DIFFERENCE
"=" 'EQUAL
">" 'GREATERP
"<" 'LESSP
"+" 'PLUS
"*" 'TIMES
;; else
(throw (ex-info "Unrecognised infix operator symbol"
{:phase :generate
:fragment p})))
:list (gen-dot-terminated-list (rest p))
(:lhs :rhs) (generate (second p))
:mexpr (generate (second p))
:mconst (make-beowulf-list
(list 'QUOTE (symbol (upper-case (second p)))))
:mvar (symbol (upper-case (second p)))
:octal (let [n (read-string (strip-leading-zeros (second p) "0"))
scale (generate (nth p 2))]

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

@ -24,11 +24,11 @@
;; but it's a convenience.
"exprs := expr | exprs;"
"mexpr := λexpr | fncall | defn | cond | mvar | iexpr | mexpr comment;
"mexpr := λexpr | fncall | defn | cond | mvar | mconst | iexpr | mexpr comment;
λexpr := λ lsqb bindings semi-colon body rsqb;
λ := 'λ';
bindings := lsqb args rsqb;
body := (expr semi-colon opt-space)* expr;
body := (mexpr semi-colon opt-space)* mexpr;
fncall := fn-name lsqb args rsqb;
lsqb := '[';
rsqb := ']';
@ -36,18 +36,21 @@
rbrace := '}';
defn := mexpr opt-space '=' opt-space mexpr;
cond := lsqb (opt-space cond-clause semi-colon opt-space)* cond-clause rsqb;
cond-clause := expr opt-space arrow opt-space expr opt-space;
cond-clause := mexpr opt-space arrow opt-space mexpr opt-space;
arrow := '->';
args := (opt-space expr semi-colon opt-space)* expr;
args := (opt-space mexpr semi-colon opt-space)* mexpr;
fn-name := mvar;
mvar := #'[a-z]+';
mconst := #'[A-Z]+';
semi-colon := ';';"
;; Infix operators appear in mexprs, e.g. on page 7. Ooops!
;; I do not know what infix operators are considered legal.
;; In particular I do not know what symbol was used for
;; multiply
"iexpr := iexp iop iexp;
iexp := mexpr | number | opt-space iexp opt-space;
iop := '>' | '<' | '+' | '-' | '/' | '=' ;"
iop := '>' | '<' | '+' | '-' | '*' '/' | '=' ;"
;; comments. I'm pretty confident Lisp 1.5 did NOT have these.
"opt-comment := opt-space | comment;"

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

@ -35,7 +35,10 @@
(defn simplify
"Simplify this parse tree `p`. If `p` is an instaparse failure object, throw
an `ex-info`, with `p` as the value of its `:failure` key."
an `ex-info`, with `p` as the value of its `:failure` key.
**NOTE THAT** it is assumed that `remove-optional-space` has been run on the
parse tree **BEFORE** it is passed to `simplify`."
([p]
(if
(instance? Failure p)
@ -55,7 +58,7 @@
(case (first p)
(:λexpr
:args :bindings :body :cond :cond-clause :defn :dot-terminal
:fncall :lhs :octal :quoted-expr :rhs :scientific) (map #(simplify % context) p)
:fncall :lhs :quoted-expr :rhs ) (map #(simplify % context) p)
(:arg :expr :coefficient :fn-name :number) (simplify (second p) context)
(:arrow :dot :e :lpar :lsqb :opt-comment :opt-space :q :quote :rpar :rsqb
:semi-colon :sep :space) nil
@ -68,7 +71,7 @@
(throw
(ex-info "Cannot parse comments in strict mode"
{:cause :strict})))
:decimal p
(:decimal :integer :mconst :octal :scientific) p
:dotted-pair (if
(= context :mexpr)
[:fncall

12
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 PLUS2 RPLACA RPLACD TIMES2]]
[beowulf.host :refer [DIFFERENCE NUMBERP PLUS RPLACA RPLACD TIMES]]
[beowulf.oblist :refer [NIL]]
[beowulf.read :refer [gsp]]))
@ -51,18 +51,18 @@
(deftest arithmetic-test
;; These are just sanity-test tests; they're by no means exhaustive.
(testing "PLUS2"
(testing "PLUS"
(let [expected 3
actual (PLUS2 1 2)]
actual (PLUS 1 2)]
(is (= actual expected))
(is (integer? actual)))
(let [expected 3.5
actual (PLUS2 1.25 9/4)]
actual (PLUS 1.25 9/4)]
(is (= actual expected))
(is (float? actual))))
(testing "TIMES2"
(testing "TIMES"
(let [expected 6
actual (TIMES2 2 3)]
actual (TIMES 2 3)]
(is (= actual expected))))
(testing DIFFERENCE
(let [expected -1