Modularised the reader; some general improvement
This commit is contained in:
parent
9b532d39a8
commit
b5e418118b
|
|
@ -11,7 +11,11 @@
|
||||||
objects."
|
objects."
|
||||||
(:require [clojure.string :as s]
|
(:require [clojure.string :as s]
|
||||||
[clojure.tools.trace :refer [deftrace]]
|
[clojure.tools.trace :refer [deftrace]]
|
||||||
[beowulf.cons-cell :refer [cons-cell? make-beowulf-list make-cons-cell NIL pretty-print T F]]))
|
[beowulf.cons-cell :refer [cons-cell? make-beowulf-list make-cons-cell
|
||||||
|
NIL pretty-print T F]]
|
||||||
|
[beowulf.host :refer [ADD1 DIFFERENCE FIXP NUMBERP PLUS2 QUOTIENT
|
||||||
|
REMAINDER RPLACA RPLACD SUB1 TIMES2]])
|
||||||
|
(:import [beowulf.cons_cell ConsCell]))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;;;
|
;;;
|
||||||
|
|
@ -57,12 +61,6 @@
|
||||||
[x]
|
[x]
|
||||||
`(if (or (symbol? ~x) (number? ~x)) T NIL))
|
`(if (or (symbol? ~x) (number? ~x)) T NIL))
|
||||||
|
|
||||||
(defmacro NUMBERP
|
|
||||||
"Returns `T` if and only if the argument `x` is bound to an number; else `F`.
|
|
||||||
TODO: check whether floating point numbers, rationals, etc were numbers in Lisp 1.5"
|
|
||||||
[x]
|
|
||||||
`(if (number? ~x) T F))
|
|
||||||
|
|
||||||
(defmacro CONS
|
(defmacro CONS
|
||||||
"Construct a new instance of cons cell with this `car` and `cdr`."
|
"Construct a new instance of cons cell with this `car` and `cdr`."
|
||||||
[car cdr]
|
[car cdr]
|
||||||
|
|
@ -75,7 +73,7 @@
|
||||||
(if
|
(if
|
||||||
(= x NIL) NIL
|
(= x NIL) NIL
|
||||||
(try
|
(try
|
||||||
(.getCar x)
|
(or (.getCar x) NIL)
|
||||||
(catch Exception any
|
(catch Exception any
|
||||||
(throw (Exception.
|
(throw (Exception.
|
||||||
(str "Cannot take CAR of `" x "` (" (.getName (.getClass x)) ")") any))))))
|
(str "Cannot take CAR of `" x "` (" (.getName (.getClass x)) ")") any))))))
|
||||||
|
|
@ -149,9 +147,12 @@
|
||||||
|
|
||||||
(defn EQ
|
(defn EQ
|
||||||
"Returns `T` if and only if both `x` and `y` are bound to the same atom,
|
"Returns `T` if and only if both `x` and `y` are bound to the same atom,
|
||||||
else `F`."
|
else `NIL`."
|
||||||
[x y]
|
[x y]
|
||||||
(if (and (= (ATOM x) T) (= x y)) T F))
|
(cond (and (instance? ConsCell x)
|
||||||
|
(.equals x y)) T
|
||||||
|
(and (= (ATOM x) T) (= x y)) T
|
||||||
|
:else NIL))
|
||||||
|
|
||||||
(defn EQUAL
|
(defn EQUAL
|
||||||
"This is a predicate that is true if its two arguments are identical
|
"This is a predicate that is true if its two arguments are identical
|
||||||
|
|
@ -162,7 +163,7 @@
|
||||||
NOTE: returns `F` on failure, not `NIL`"
|
NOTE: returns `F` on failure, not `NIL`"
|
||||||
[x y]
|
[x y]
|
||||||
(cond
|
(cond
|
||||||
(= (ATOM x) T) (EQ x y)
|
(= (ATOM x) T) (if (= x y) T F)
|
||||||
(= (EQUAL (CAR x) (CAR y)) T) (EQUAL (CDR x) (CDR y))
|
(= (EQUAL (CAR x) (CAR y)) T) (EQUAL (CDR x) (CDR y))
|
||||||
:else F))
|
:else F))
|
||||||
|
|
||||||
|
|
@ -378,10 +379,10 @@
|
||||||
"Not certain whether or not this is part of LISP 1.5; adapted from PSL.
|
"Not certain whether or not this is part of LISP 1.5; adapted from PSL.
|
||||||
return the current value of the object list. Note that in PSL this function
|
return the current value of the object list. Note that in PSL this function
|
||||||
returns a list of the symbols bound, not the whole association list."
|
returns a list of the symbols bound, not the whole association list."
|
||||||
[args]
|
[]
|
||||||
(@oblist))
|
(make-beowulf-list (map CAR @oblist)))
|
||||||
|
|
||||||
(deftrace DEFINE
|
(defn DEFINE
|
||||||
"Bootstrap-only version of `DEFINE` which, post boostrap, can be overwritten
|
"Bootstrap-only version of `DEFINE` which, post boostrap, can be overwritten
|
||||||
in LISP.
|
in LISP.
|
||||||
|
|
||||||
|
|
@ -399,7 +400,18 @@
|
||||||
(pretty-print a)
|
(pretty-print a)
|
||||||
a)
|
a)
|
||||||
(recur (CDR cursor) a))))
|
(recur (CDR cursor) a))))
|
||||||
(CAR args)))
|
(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]
|
||||||
|
(doall
|
||||||
|
(swap!
|
||||||
|
oblist
|
||||||
|
(fn [ob s v] (make-cons-cell (make-cons-cell s v) ob))
|
||||||
|
symbol val)
|
||||||
|
NIL))
|
||||||
|
|
||||||
(defn APPLY
|
(defn APPLY
|
||||||
"For bootstrapping, at least, a version of APPLY written in Clojure.
|
"For bootstrapping, at least, a version of APPLY written in Clojure.
|
||||||
|
|
@ -407,23 +419,32 @@
|
||||||
See page 13 of the Lisp 1.5 Programmers Manual."
|
See page 13 of the Lisp 1.5 Programmers Manual."
|
||||||
[function args environment]
|
[function args environment]
|
||||||
(cond
|
(cond
|
||||||
|
(= NIL function) (throw (ex-info "NIL is not a function" {:context "APPLY"
|
||||||
|
:function "NIL"
|
||||||
|
:args args}))
|
||||||
(=
|
(=
|
||||||
(ATOM? function)
|
(ATOM? function)
|
||||||
T) (cond
|
T) (cond
|
||||||
;; TODO: doesn't check whether `function` is bound in the environment;
|
;; (fn? (eval function)) (apply (eval function) args)
|
||||||
;; we'll need that before we can bootstrap.
|
(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 'CAR) (CAAR args)
|
||||||
(= function 'CDR) (CDAR args)
|
(= function 'CDR) (CDAR args)
|
||||||
(= function 'CONS) (make-cons-cell (CAR args) (CADR args))
|
(= function 'CONS) (make-cons-cell (CAR args) (CADR args))
|
||||||
(= function 'DEFINE) (DEFINE args)
|
(= function 'DEFINE) (DEFINE args)
|
||||||
(= function 'ATOM) (if (ATOM? (CAR args)) T NIL)
|
(= function 'EQ) (apply EQ args)
|
||||||
(= function 'EQ) (if (= (CAR args) (CADR args)) T NIL)
|
|
||||||
(= function 'INTEROP) (INTEROP (CAR args) (CDR args))
|
(= function 'INTEROP) (INTEROP (CAR args) (CDR args))
|
||||||
:else
|
(= function 'SET) (SET (CAR args) (CADR args))
|
||||||
(APPLY
|
(EVAL function environment)(APPLY
|
||||||
(EVAL function environment)
|
(EVAL function environment)
|
||||||
args
|
args
|
||||||
environment))
|
environment)
|
||||||
|
:else
|
||||||
|
(throw (ex-info "No function found" {:context "APPLY"
|
||||||
|
:function function
|
||||||
|
:args args})))
|
||||||
(fn? function) ;; i.e., it's a Clojure function
|
(fn? function) ;; i.e., it's a Clojure function
|
||||||
(apply function (to-clojure args))
|
(apply function (to-clojure args))
|
||||||
(= (first function) 'LAMBDA) (EVAL
|
(= (first function) 'LAMBDA) (EVAL
|
||||||
|
|
@ -508,8 +529,11 @@
|
||||||
"For bootstrapping, at least, a version of EVAL written in Clojure.
|
"For bootstrapping, at least, a version of EVAL written in Clojure.
|
||||||
All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects.
|
All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects.
|
||||||
See page 13 of the Lisp 1.5 Programmers Manual."
|
See page 13 of the Lisp 1.5 Programmers Manual."
|
||||||
[expr env]
|
([expr]
|
||||||
(if
|
(EVAL expr @oblist))
|
||||||
|
([expr env]
|
||||||
|
(if
|
||||||
(:trace *options*)
|
(:trace *options*)
|
||||||
(traced-eval expr env)
|
(traced-eval expr env)
|
||||||
(eval-internal expr env)))
|
(eval-internal expr env))))
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -4,11 +4,7 @@
|
||||||
must have both CAR and CDR mutable, so cannot be implemented on top
|
must have both CAR and CDR mutable, so cannot be implemented on top
|
||||||
of Clojure lists.")
|
of Clojure lists.")
|
||||||
|
|
||||||
(declare cons-cell?)
|
(declare cons-cell? NIL)
|
||||||
|
|
||||||
(def NIL
|
|
||||||
"The canonical empty list symbol."
|
|
||||||
(symbol "NIL"))
|
|
||||||
|
|
||||||
(def T
|
(def T
|
||||||
"The canonical true value."
|
"The canonical true value."
|
||||||
|
|
@ -28,13 +24,17 @@
|
||||||
[this value]
|
[this value]
|
||||||
"replace the rest (but-first; cdr) of this sequence with this value")
|
"replace the rest (but-first; cdr) of this sequence with this value")
|
||||||
(getCar
|
(getCar
|
||||||
[this]
|
[this]
|
||||||
"Return the first element of this sequence.")
|
"Return the first element of this sequence.")
|
||||||
(getCdr
|
(getCdr
|
||||||
[this]
|
[this]
|
||||||
"like `more`, q.v., but returns List `NIL` not Clojure `nil` when empty." ))
|
"like `more`, q.v., but returns List `NIL` not Clojure `nil` when empty.")
|
||||||
|
(getUid
|
||||||
|
[this]
|
||||||
|
"Returns a unique identifier for this object")
|
||||||
|
)
|
||||||
|
|
||||||
(deftype ConsCell [^:unsynchronized-mutable CAR ^:unsynchronized-mutable CDR]
|
(deftype ConsCell [^:unsynchronized-mutable CAR ^:unsynchronized-mutable CDR uid]
|
||||||
;; Note that, because the CAR and CDR fields are unsynchronised mutable - i.e.
|
;; Note that, because the CAR and CDR fields are unsynchronised mutable - i.e.
|
||||||
;; plain old Java instance variables which can be written as well as read -
|
;; plain old Java instance variables which can be written as well as read -
|
||||||
;; ConsCells are NOT thread safe. This does not matter, since Lisp 1.5 is
|
;; ConsCells are NOT thread safe. This does not matter, since Lisp 1.5 is
|
||||||
|
|
@ -73,13 +73,16 @@
|
||||||
(str "Invalid value in RPLACD: `" value "` (" (type value) ")")
|
(str "Invalid value in RPLACD: `" value "` (" (type value) ")")
|
||||||
{:cause :bad-value
|
{:cause :bad-value
|
||||||
:detail :rplaca}))))
|
:detail :rplaca}))))
|
||||||
|
|
||||||
(getCar [this]
|
(getCar [this]
|
||||||
(. this CAR))
|
(. this CAR))
|
||||||
(getCdr [this]
|
(getCdr [this]
|
||||||
(. this CDR))
|
(. this CDR))
|
||||||
|
(getUid [this]
|
||||||
|
(. this uid))
|
||||||
|
|
||||||
clojure.lang.ISeq
|
clojure.lang.ISeq
|
||||||
(cons [this x] (ConsCell. x this))
|
(cons [this x] (ConsCell. x this (gensym "c")))
|
||||||
(first [this] (.CAR this))
|
(first [this] (.CAR this))
|
||||||
;; next and more must return ISeq:
|
;; next and more must return ISeq:
|
||||||
;; https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/ISeq.java
|
;; https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/ISeq.java
|
||||||
|
|
@ -101,7 +104,7 @@
|
||||||
clojure.lang.Sequential
|
clojure.lang.Sequential
|
||||||
|
|
||||||
clojure.lang.IPersistentCollection
|
clojure.lang.IPersistentCollection
|
||||||
(empty [this] false) ;; a cons cell is by definition not empty.
|
(empty [this] (= this NIL)) ;; a cons cell is by definition not empty.
|
||||||
(equiv [this other] (if
|
(equiv [this other] (if
|
||||||
(seq? other)
|
(seq? other)
|
||||||
(and
|
(and
|
||||||
|
|
@ -120,26 +123,21 @@
|
||||||
false))
|
false))
|
||||||
|
|
||||||
clojure.lang.Counted
|
clojure.lang.Counted
|
||||||
(count [this] (loop [cell this
|
(count [this] (loop [cell this
|
||||||
result 1]
|
result 1]
|
||||||
(if
|
(if
|
||||||
(coll? (.getCdr this))
|
(and (coll? (.getCdr cell)) (not= NIL (.getCdr cell)))
|
||||||
(recur (.getCdr this) (inc result))
|
(recur (.getCdr cell) (inc result))
|
||||||
result)))
|
result)))
|
||||||
;; (if
|
|
||||||
;; (coll? (.getCdr this))
|
|
||||||
;; (inc (.count (.getCdr this)))
|
|
||||||
;; 1))
|
|
||||||
java.lang.Object
|
|
||||||
(toString [this]
|
|
||||||
(str "("
|
|
||||||
(. this CAR)
|
|
||||||
(cond
|
|
||||||
(instance? ConsCell (. this CDR)) (str " " (subs (.toString (. this CDR)) 1))
|
|
||||||
(= NIL (. this CDR)) ")"
|
|
||||||
:else (str " . " (. this CDR)))))
|
|
||||||
|
|
||||||
)
|
java.lang.Object
|
||||||
|
(toString [this]
|
||||||
|
(str "("
|
||||||
|
(. this CAR)
|
||||||
|
(cond
|
||||||
|
(instance? ConsCell (. this CDR)) (str " " (subs (.toString (. this CDR)) 1))
|
||||||
|
(= NIL (. this CDR)) ")"
|
||||||
|
:else (str " . " (. this CDR))))))
|
||||||
|
|
||||||
(defn- to-string
|
(defn- to-string
|
||||||
"Printing ConsCells gave me a *lot* of trouble. This is an internal function
|
"Printing ConsCells gave me a *lot* of trouble. This is an internal function
|
||||||
|
|
@ -151,22 +149,25 @@
|
||||||
n 0
|
n 0
|
||||||
s "("]
|
s "("]
|
||||||
(if
|
(if
|
||||||
(instance? beowulf.cons_cell.ConsCell c)
|
(instance? beowulf.cons_cell.ConsCell c)
|
||||||
(let [car (.first c)
|
(let [car (.first c)
|
||||||
cdr (.getCdr c)
|
cdr (.getCdr c)
|
||||||
cons? (instance? beowulf.cons_cell.ConsCell cdr)
|
cons? (and
|
||||||
|
(instance? beowulf.cons_cell.ConsCell cdr)
|
||||||
|
(not (nil? cdr))
|
||||||
|
(not= cdr NIL))
|
||||||
ss (str
|
ss (str
|
||||||
s
|
s
|
||||||
(to-string car)
|
(to-string car)
|
||||||
(cond
|
(cond
|
||||||
cons?
|
(or (nil? cdr) (= cdr NIL))
|
||||||
" "
|
")"
|
||||||
(or (nil? cdr) (= cdr NIL))
|
cons?
|
||||||
")"
|
" "
|
||||||
:else
|
:else
|
||||||
(str " . " (to-string cdr) ")")))]
|
(str " . " (to-string cdr) ")")))]
|
||||||
(if
|
(if
|
||||||
cons?
|
cons?
|
||||||
(recur cdr (inc n) ss)
|
(recur cdr (inc n) ss)
|
||||||
ss))
|
ss))
|
||||||
(str c))))
|
(str c))))
|
||||||
|
|
@ -180,27 +181,27 @@
|
||||||
n (inc level)
|
n (inc level)
|
||||||
s "("]
|
s "("]
|
||||||
(if
|
(if
|
||||||
(instance? beowulf.cons_cell.ConsCell c)
|
(instance? beowulf.cons_cell.ConsCell c)
|
||||||
(let [car (.first c)
|
(let [car (.first c)
|
||||||
cdr (.getCdr c)
|
cdr (.getCdr c)
|
||||||
cons? (instance? beowulf.cons_cell.ConsCell cdr)
|
cons? (instance? beowulf.cons_cell.ConsCell cdr)
|
||||||
print-width (count (print-str c))
|
print-width (count (print-str c))
|
||||||
indent (apply str (repeat n " "))
|
indent (apply str (repeat n " "))
|
||||||
ss (str
|
ss (str
|
||||||
s
|
s
|
||||||
(pretty-print car width n)
|
(pretty-print car width n)
|
||||||
(cond
|
(cond
|
||||||
cons?
|
(or (nil? cdr) (= cdr NIL))
|
||||||
(if
|
")"
|
||||||
(< (+ (count indent) print-width) width)
|
cons?
|
||||||
" "
|
(if
|
||||||
(str "\n" indent))
|
(< (+ (count indent) print-width) width)
|
||||||
(or (nil? cdr) (= cdr NIL))
|
" "
|
||||||
")"
|
(str "\n" indent))
|
||||||
:else
|
:else
|
||||||
(str " . " (pretty-print cdr width n) ")")))]
|
(str " . " (pretty-print cdr width n) ")")))]
|
||||||
(if
|
(if
|
||||||
cons?
|
cons?
|
||||||
(recur cdr n ss)
|
(recur cdr n ss)
|
||||||
ss))
|
ss))
|
||||||
(str c)))))
|
(str c)))))
|
||||||
|
|
@ -216,10 +217,14 @@
|
||||||
"Construct a new instance of cons cell with this `car` and `cdr`."
|
"Construct a new instance of cons cell with this `car` and `cdr`."
|
||||||
[car cdr]
|
[car cdr]
|
||||||
(try
|
(try
|
||||||
(ConsCell. car cdr)
|
(ConsCell. car cdr (gensym "c"))
|
||||||
(catch Exception any
|
(catch Exception any
|
||||||
(throw (ex-info "Cound not construct cons cell" {:car car
|
(throw (ex-info "Cound not construct cons cell" {:car car
|
||||||
:cdr cdr} any)))))
|
:cdr cdr} any)))))
|
||||||
|
|
||||||
|
(def NIL
|
||||||
|
"The canonical empty list symbol."
|
||||||
|
'NIL)
|
||||||
|
|
||||||
(defn cons-cell?
|
(defn cons-cell?
|
||||||
"Is this object `o` a beowulf cons-cell?"
|
"Is this object `o` a beowulf cons-cell?"
|
||||||
|
|
@ -232,15 +237,16 @@
|
||||||
[x]
|
[x]
|
||||||
(try
|
(try
|
||||||
(cond
|
(cond
|
||||||
(empty? x) NIL
|
(empty? x) NIL
|
||||||
(coll? x) (ConsCell.
|
(coll? x) (ConsCell.
|
||||||
(if
|
(if
|
||||||
(coll? (first x))
|
(coll? (first x))
|
||||||
(make-beowulf-list (first x))
|
(make-beowulf-list (first x))
|
||||||
(first x))
|
(first x))
|
||||||
(make-beowulf-list (rest x)))
|
(make-beowulf-list (rest x))
|
||||||
:else
|
(gensym "c"))
|
||||||
NIL)
|
:else
|
||||||
|
NIL)
|
||||||
(catch Exception any
|
(catch Exception any
|
||||||
(throw (ex-info "Could not construct Beowulf list"
|
(throw (ex-info "Could not construct Beowulf list"
|
||||||
{:content x}
|
{:content x}
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
(ns beowulf.core
|
(ns beowulf.core
|
||||||
"Essentially, the `-main` function and the bootstrap read-eval-print loop."
|
"Essentially, the `-main` function and the bootstrap read-eval-print loop."
|
||||||
(:require [beowulf.bootstrap :refer [EVAL oblist *options*]]
|
(:require [beowulf.bootstrap :refer [EVAL oblist *options*]]
|
||||||
[beowulf.read :refer [READ]]
|
[beowulf.read :refer [READ read-from-console]]
|
||||||
[clojure.java.io :as io]
|
[clojure.java.io :as io]
|
||||||
[clojure.pprint :refer [pprint]]
|
[clojure.pprint :refer [pprint]]
|
||||||
[clojure.string :refer [trim]]
|
[clojure.string :refer [trim]]
|
||||||
|
|
@ -31,7 +31,7 @@
|
||||||
(try
|
(try
|
||||||
;; TODO: does not currently allow the reading of forms covering multiple
|
;; TODO: does not currently allow the reading of forms covering multiple
|
||||||
;; lines.
|
;; lines.
|
||||||
(let [input (trim (read-line))]
|
(let [input (trim (read-from-console))]
|
||||||
(cond
|
(cond
|
||||||
(= input stop-word) (throw (ex-info "\nFærwell!" {:cause :quit}))
|
(= input stop-word) (throw (ex-info "\nFærwell!" {:cause :quit}))
|
||||||
input (println (str "> " (print-str (EVAL (READ input) @oblist))))
|
input (println (str "> " (print-str (EVAL (READ input) @oblist))))
|
||||||
|
|
@ -41,7 +41,7 @@
|
||||||
e
|
e
|
||||||
(let [data (ex-data e)]
|
(let [data (ex-data e)]
|
||||||
(println (.getMessage e))
|
(println (.getMessage e))
|
||||||
(if
|
(when
|
||||||
data
|
data
|
||||||
(case (:cause data)
|
(case (:cause data)
|
||||||
:parse-failure (println (:failure data))
|
:parse-failure (println (:failure data))
|
||||||
|
|
|
||||||
|
|
@ -13,12 +13,10 @@
|
||||||
|
|
||||||
Both these extensions can be disabled by using the `--strict` command line
|
Both these extensions can be disabled by using the `--strict` command line
|
||||||
switch."
|
switch."
|
||||||
(:require [beowulf.bootstrap :refer [*options*]]
|
(:require [beowulf.reader.generate :refer [generate]]
|
||||||
[clojure.math.numeric-tower :refer [expt]]
|
[beowulf.reader.parser :refer [parse]]
|
||||||
[clojure.string :refer [join split starts-with? trim upper-case]]
|
[beowulf.reader.simplify :refer [simplify]]
|
||||||
[instaparse.core :as i]
|
[clojure.string :refer [join split starts-with? trim]])
|
||||||
[instaparse.failure :as f]
|
|
||||||
[beowulf.cons-cell :refer [make-beowulf-list make-cons-cell NIL]])
|
|
||||||
(:import [java.io InputStream]
|
(:import [java.io InputStream]
|
||||||
[instaparse.gll Failure]))
|
[instaparse.gll Failure]))
|
||||||
|
|
||||||
|
|
@ -30,8 +28,6 @@
|
||||||
;;;
|
;;;
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(declare generate)
|
|
||||||
|
|
||||||
(defn strip-line-comments
|
(defn strip-line-comments
|
||||||
"Strip blank lines and comment lines from this string `s`, expected to
|
"Strip blank lines and comment lines from this string `s`, expected to
|
||||||
be Lisp source."
|
be Lisp source."
|
||||||
|
|
@ -55,386 +51,6 @@
|
||||||
(range)
|
(range)
|
||||||
(split s #"\n"))))))
|
(split s #"\n"))))))
|
||||||
|
|
||||||
(def parse
|
|
||||||
"Parse a string presented as argument into a parse tree which can then
|
|
||||||
be operated upon further."
|
|
||||||
(i/parser
|
|
||||||
(str
|
|
||||||
;; we tolerate whitespace and comments around legitimate input
|
|
||||||
"raw := expr | opt-comment expr opt-comment;"
|
|
||||||
;; top level: we accept mexprs as well as sexprs.
|
|
||||||
"expr := mexpr | sexpr ;"
|
|
||||||
|
|
||||||
;; comments. I'm pretty confident Lisp 1.5 did NOT have these.
|
|
||||||
"comment := opt-space <';;'> opt-space #'[^\\n\\r]*';"
|
|
||||||
|
|
||||||
;; there's a notation comprising a left brace followed by mexprs
|
|
||||||
;; followed by a right brace which doesn't seem to be documented
|
|
||||||
;; but I think must represent a prog(?)
|
|
||||||
|
|
||||||
;; "prog := lbrace exprs rbrace;"
|
|
||||||
;; mexprs. I'm pretty clear that Lisp 1.5 could never read these,
|
|
||||||
;; but it's a convenience.
|
|
||||||
|
|
||||||
"exprs := expr | exprs;"
|
|
||||||
"mexpr := λexpr | fncall | defn | cond | mvar | iexpr | mexpr comment;
|
|
||||||
λexpr := λ lsqb bindings semi-colon body rsqb;
|
|
||||||
λ := 'λ';
|
|
||||||
bindings := lsqb args rsqb;
|
|
||||||
body := (expr semi-colon opt-space)* expr;
|
|
||||||
fncall := fn-name lsqb args rsqb;
|
|
||||||
lsqb := '[';
|
|
||||||
rsqb := ']';
|
|
||||||
lbrace := '{';
|
|
||||||
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;
|
|
||||||
arrow := '->';
|
|
||||||
args := (opt-space expr semi-colon opt-space)* expr;
|
|
||||||
fn-name := mvar;
|
|
||||||
mvar := #'[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.
|
|
||||||
"iexpr := iexp iop iexp;
|
|
||||||
iexp := mexpr | mvar | number | mexpr | opt-space iexp opt-space;
|
|
||||||
iop := '>' | '<' | '+' | '-' | '/' | '=' ;"
|
|
||||||
|
|
||||||
;; comments. I'm pretty confident Lisp 1.5 did NOT have these.
|
|
||||||
"opt-comment := opt-space | comment;"
|
|
||||||
"comment := opt-space <';;'> #'[^\\n\\r]*' opt-space;"
|
|
||||||
|
|
||||||
;; sexprs. Note it's not clear to me whether Lisp 1.5 had the quote macro,
|
|
||||||
;; but I've included it on the basis that it can do little harm.
|
|
||||||
"sexpr := quoted-expr | atom | number | dotted-pair | list | sexpr comment;
|
|
||||||
list := lpar sexpr rpar | lpar (sexpr sep)* rpar | lpar (sexpr sep)* dot-terminal | lbrace exprs rbrace;
|
|
||||||
list := lpar opt-space sexpr rpar | lpar opt-space (sexpr sep)* rpar | lpar opt-space (sexpr sep)* dot-terminal;
|
|
||||||
dotted-pair := lpar dot-terminal ;
|
|
||||||
dot := '.';
|
|
||||||
lpar := '(';
|
|
||||||
rpar := ')';
|
|
||||||
quoted-expr := quote sexpr;
|
|
||||||
quote := '\\'';
|
|
||||||
dot-terminal := sexpr space dot space sexpr rpar;
|
|
||||||
space := #'\\p{javaWhitespace}+';
|
|
||||||
opt-space := #'\\p{javaWhitespace}*';
|
|
||||||
sep := ',' | opt-space;
|
|
||||||
atom := #'[A-Z][A-Z0-9]*';"
|
|
||||||
|
|
||||||
;; Lisp 1.5 supported octal as well as decimal and scientific notation
|
|
||||||
"number := integer | decimal | scientific | octal;
|
|
||||||
integer := #'-?[1-9][0-9]*';
|
|
||||||
decimal := #'-?[1-9][0-9]*\\.?[0-9]*' | #'0.[0-9]*';
|
|
||||||
scientific := coefficient e exponent;
|
|
||||||
coefficient := decimal;
|
|
||||||
exponent := integer;
|
|
||||||
e := 'E';
|
|
||||||
octal := #'[+-]?[0-7]+{1,12}' q scale-factor;
|
|
||||||
q := 'Q';
|
|
||||||
scale-factor := #'[0-9]*'")))
|
|
||||||
|
|
||||||
(declare simplify)
|
|
||||||
|
|
||||||
(defn simplify-second-of-two
|
|
||||||
"There are a number of possible simplifications such that if the `tree` has
|
|
||||||
only two elements, the second is semantically sufficient."
|
|
||||||
[tree context]
|
|
||||||
(if (= (count tree) 2)
|
|
||||||
(simplify (second tree) context)
|
|
||||||
tree))
|
|
||||||
|
|
||||||
(defn remove-optional-space
|
|
||||||
[tree]
|
|
||||||
(if (vector? tree)
|
|
||||||
(if (= :opt-space (first tree))
|
|
||||||
nil
|
|
||||||
(remove nil?
|
|
||||||
(map remove-optional-space tree)))
|
|
||||||
tree))
|
|
||||||
|
|
||||||
(defn remove-nesting
|
|
||||||
[tree]
|
|
||||||
(let [tree' (remove-optional-space tree)]
|
|
||||||
(if-let [key (when (and (vector? tree') (keyword? (first tree'))) (first tree'))]
|
|
||||||
(loop [r tree']
|
|
||||||
(if (and r (vector? r) (keyword? (first r)))
|
|
||||||
(if (= (first r) key)
|
|
||||||
(recur (simplify (second r) :foo))
|
|
||||||
r)
|
|
||||||
r))
|
|
||||||
tree')))
|
|
||||||
|
|
||||||
|
|
||||||
(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."
|
|
||||||
([p]
|
|
||||||
(if
|
|
||||||
(instance? Failure p)
|
|
||||||
(throw (ex-info (str "Ic ne behæfd: " (f/pprint-failure p)) {:cause :parse-failure
|
|
||||||
:phase :simplify
|
|
||||||
:failure p}))
|
|
||||||
(simplify p :expr)))
|
|
||||||
([p context]
|
|
||||||
(if
|
|
||||||
(coll? p)
|
|
||||||
(apply
|
|
||||||
vector
|
|
||||||
(remove
|
|
||||||
#(when (coll? %) (empty? %))
|
|
||||||
(case (first p)
|
|
||||||
(:λexpr
|
|
||||||
:args :bindings :body :cond :cond-clause :defn :dot-terminal
|
|
||||||
:fncall :lhs :octal :quoted-expr :rhs :scientific) (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
|
|
||||||
:atom (if
|
|
||||||
(= context :mexpr)
|
|
||||||
[:quoted-expr p]
|
|
||||||
p)
|
|
||||||
:comment (when
|
|
||||||
(:strict *options*)
|
|
||||||
(throw
|
|
||||||
(ex-info "Cannot parse comments in strict mode"
|
|
||||||
{:cause :strict})))
|
|
||||||
:dotted-pair (if
|
|
||||||
(= context :mexpr)
|
|
||||||
[:fncall
|
|
||||||
[:mvar "cons"]
|
|
||||||
[:args
|
|
||||||
(simplify (nth p 1) context)
|
|
||||||
(simplify (nth p 2) context)]]
|
|
||||||
(map simplify p))
|
|
||||||
:iexp (second (remove-nesting p))
|
|
||||||
:iexpr [:iexpr
|
|
||||||
[:lhs (simplify (second p) context)]
|
|
||||||
(simplify (nth p 2) context) ;; really should be the operator
|
|
||||||
[:rhs (simplify (nth p 3) context)]]
|
|
||||||
:mexpr (if
|
|
||||||
(:strict *options*)
|
|
||||||
(throw
|
|
||||||
(ex-info "Cannot parse meta expressions in strict mode"
|
|
||||||
{:cause :strict}))
|
|
||||||
(simplify (second p) :mexpr))
|
|
||||||
:list (if
|
|
||||||
(= context :mexpr)
|
|
||||||
[:fncall
|
|
||||||
[:mvar "list"]
|
|
||||||
[:args (apply vector (map simplify (rest p)))]]
|
|
||||||
(map #(simplify % context) p))
|
|
||||||
:raw (first (remove empty? (map simplify (rest p))))
|
|
||||||
:sexpr (simplify (second p) :sexpr)
|
|
||||||
;;default
|
|
||||||
p)))
|
|
||||||
p)))
|
|
||||||
|
|
||||||
|
|
||||||
;; # From Lisp 1.5 Programmers Manual, page 10
|
|
||||||
;; Note that I've retyped much of this, since copy/pasting out of PDF is less
|
|
||||||
;; than reliable. Any typos are mine. Quote starts [[
|
|
||||||
|
|
||||||
;; We are now in a position to define the universal LISP function
|
|
||||||
;; evalquote[fn;args], When evalquote is given a function and a list of arguments
|
|
||||||
;; for that function, it computes the value of the function applied to the arguments.
|
|
||||||
;; LISP functions have S-expressions as arguments. In particular, the argument "fn"
|
|
||||||
;; of the function evalquote must be an S-expression. Since we have been
|
|
||||||
;; writing functions as M-expressions, it is necessary to translate them into
|
|
||||||
;; S-expressions.
|
|
||||||
|
|
||||||
;; The following rules define a method of translating functions written in the
|
|
||||||
;; meta-language into S-expressions.
|
|
||||||
;; 1. If the function is represented by its name, it is translated by changing
|
|
||||||
;; all of the letters to upper case, making it an atomic symbol. Thus is
|
|
||||||
;; translated to CAR.
|
|
||||||
;; 2. If the function uses the lambda notation, then the expression
|
|
||||||
;; λ[[x ..;xn]; ε] is translated into (LAMBDA (X1 ...XN) ε*), where ε* is the translation
|
|
||||||
;; of ε.
|
|
||||||
;; 3. If the function begins with label, then the translation of
|
|
||||||
;; label[α;ε] is (LABEL α* ε*).
|
|
||||||
|
|
||||||
;; Forms are translated as follows:
|
|
||||||
;; 1. A variable, like a function name, is translated by using uppercase letters.
|
|
||||||
;; Thus the translation of varl is VAR1.
|
|
||||||
;; 2. The obvious translation of letting a constant translate into itself will not
|
|
||||||
;; work. Since the translation of x is X, the translation of X must be something
|
|
||||||
;; else to avoid ambiguity. The solution is to quote it. Thus X is translated
|
|
||||||
;; into (QUOTE X).
|
|
||||||
;; 3. The form fn[argl;. ..;argn] is translated into (fn* argl* ...argn*)
|
|
||||||
;; 4. The conditional expression [pl-el;...;pn-en] is translated into
|
|
||||||
;; (COND (p1* e1*)...(pn* en*))
|
|
||||||
|
|
||||||
;; ## Examples
|
|
||||||
|
|
||||||
;; M-expressions S-expressions
|
|
||||||
;; x X
|
|
||||||
;; car CAR
|
|
||||||
;; car[x] (CAR X)
|
|
||||||
;; T (QUOTE T)
|
|
||||||
;; ff[car [x]] (FF (CAR X))
|
|
||||||
;; [atom[x]->x; T->ff[car[x]]] (COND ((ATOM X) X)
|
|
||||||
;; ((QUOTE T)(FF (CAR X))))
|
|
||||||
;; label[ff;λ[[x];[atom[x]->x; T->ff[car[x]]]]] (LABEL FF (LAMBDA (X) (COND
|
|
||||||
;; ((ATOM X) X)
|
|
||||||
;; ((QUOTE T)(FF (CAR X))))))
|
|
||||||
|
|
||||||
;; ]] quote ends
|
|
||||||
|
|
||||||
(defn gen-cond-clause
|
|
||||||
"Generate a cond clause from this simplified parse tree fragment `p`;
|
|
||||||
returns `nil` if `p` does not represent a cond clause."
|
|
||||||
[p]
|
|
||||||
(when
|
|
||||||
(and (coll? p) (= :cond-clause (first p)))
|
|
||||||
(make-beowulf-list
|
|
||||||
(list (if (= (nth p 1) [:quoted-expr [:atom "T"]])
|
|
||||||
'T
|
|
||||||
(generate (nth p 1)))
|
|
||||||
(generate (nth p 2))))))
|
|
||||||
|
|
||||||
(defn gen-cond
|
|
||||||
"Generate a cond statement from this simplified parse tree fragment `p`;
|
|
||||||
returns `nil` if `p` does not represent a (MEXPR) cond statement."
|
|
||||||
[p]
|
|
||||||
(when
|
|
||||||
(and (coll? p) (= :cond (first p)))
|
|
||||||
(make-beowulf-list
|
|
||||||
(cons
|
|
||||||
'COND
|
|
||||||
(map
|
|
||||||
generate
|
|
||||||
(rest p))))))
|
|
||||||
|
|
||||||
(defn gen-fn-call
|
|
||||||
"Generate a function call from this simplified parse tree fragment `p`;
|
|
||||||
returns `nil` if `p` does not represent a (MEXPR) function call."
|
|
||||||
[p]
|
|
||||||
(when
|
|
||||||
(and (coll? p) (= :fncall (first p)) (= :mvar (first (second p))))
|
|
||||||
(make-cons-cell
|
|
||||||
(generate (second p))
|
|
||||||
(generate (nth p 2)))))
|
|
||||||
|
|
||||||
|
|
||||||
(defn gen-dot-terminated-list
|
|
||||||
"Generate a list, which may be dot-terminated, from this partial parse tree
|
|
||||||
'p'. Note that the function acts recursively and progressively decapitates
|
|
||||||
its argument, so that the argument will not always be a valid parse tree."
|
|
||||||
[p]
|
|
||||||
(cond
|
|
||||||
(empty? p)
|
|
||||||
NIL
|
|
||||||
(and (coll? (first p)) (= :dot-terminal (first (first p))))
|
|
||||||
(let [dt (first p)]
|
|
||||||
(make-cons-cell
|
|
||||||
(generate (nth dt 1))
|
|
||||||
(generate (nth dt 2))))
|
|
||||||
:else
|
|
||||||
(make-cons-cell
|
|
||||||
(generate (first p))
|
|
||||||
(gen-dot-terminated-list (rest p)))))
|
|
||||||
|
|
||||||
(defn generate-defn
|
|
||||||
[tree]
|
|
||||||
(make-beowulf-list
|
|
||||||
(list 'SET
|
|
||||||
(list 'QUOTE (generate (-> tree second second)))
|
|
||||||
(list 'QUOTE
|
|
||||||
(cons 'LAMBDA
|
|
||||||
(cons (generate (nth (second tree) 2))
|
|
||||||
(map generate (-> tree rest rest rest))))))))
|
|
||||||
|
|
||||||
(defn generate-set
|
|
||||||
"Actually not sure what the mexpr representation of set looks like"
|
|
||||||
[tree]
|
|
||||||
(throw (ex-info "Not Yet Implemented" {:feature "generate-set"})))
|
|
||||||
|
|
||||||
(defn generate-assign
|
|
||||||
"Generate an assignment statement based on this `tree`. If the thing
|
|
||||||
being assigned to is a function signature, then we have to do something
|
|
||||||
different to if it's an atom."
|
|
||||||
[tree]
|
|
||||||
(case (first (second tree))
|
|
||||||
:fncall (generate-defn tree)
|
|
||||||
(:mvar :atom) (generate-set tree)))
|
|
||||||
|
|
||||||
(defn strip-leading-zeros
|
|
||||||
"`read-string` interprets strings with leading zeros as octal; strip
|
|
||||||
any from this string `s`. If what's left is empty (i.e. there were
|
|
||||||
only zeros, return `\"0\"`."
|
|
||||||
([s]
|
|
||||||
(strip-leading-zeros s ""))
|
|
||||||
([s prefix]
|
|
||||||
(if
|
|
||||||
(empty? s) "0"
|
|
||||||
(case (first s)
|
|
||||||
(\+ \-) (strip-leading-zeros (subs s 1) (str (first s) prefix))
|
|
||||||
"0" (strip-leading-zeros (subs s 1) prefix)
|
|
||||||
(str prefix s)))))
|
|
||||||
|
|
||||||
(defn generate
|
|
||||||
"Generate lisp structure from this parse tree `p`. It is assumed that
|
|
||||||
`p` has been simplified."
|
|
||||||
[p]
|
|
||||||
(try
|
|
||||||
(if
|
|
||||||
(coll? p)
|
|
||||||
(case (first p)
|
|
||||||
:λ "LAMBDA"
|
|
||||||
:λexpr (make-cons-cell
|
|
||||||
(generate (nth p 1))
|
|
||||||
(make-cons-cell (generate (nth p 2))
|
|
||||||
(generate (nth p 3))))
|
|
||||||
:args (make-beowulf-list (map generate (rest p)))
|
|
||||||
:atom (symbol (second p))
|
|
||||||
:bindings (generate (second p))
|
|
||||||
:body (make-beowulf-list (map generate (rest p)))
|
|
||||||
:cond (gen-cond p)
|
|
||||||
:cond-clause (gen-cond-clause p)
|
|
||||||
(:decimal :integer) (read-string (strip-leading-zeros (second p)))
|
|
||||||
:defn (generate-assign p)
|
|
||||||
:dotted-pair (make-cons-cell
|
|
||||||
(generate (nth p 1))
|
|
||||||
(generate (nth p 2)))
|
|
||||||
:exponent (generate (second p))
|
|
||||||
:fncall (gen-fn-call p)
|
|
||||||
:list (gen-dot-terminated-list (rest p))
|
|
||||||
:mvar (symbol (upper-case (second p)))
|
|
||||||
:octal (let [n (read-string (strip-leading-zeros (second p) "0"))
|
|
||||||
scale (generate (nth p 2))]
|
|
||||||
(* n (expt 8 scale)))
|
|
||||||
|
|
||||||
;; the quote read macro (which probably didn't exist in Lisp 1.5, but...)
|
|
||||||
:quoted-expr (make-beowulf-list (list 'QUOTE (generate (second p))))
|
|
||||||
:scale-factor (if
|
|
||||||
(empty? (second p)) 0
|
|
||||||
(read-string (strip-leading-zeros (second p))))
|
|
||||||
:scientific (let [n (generate (second p))
|
|
||||||
exponent (generate (nth p 2))]
|
|
||||||
(* n (expt 10 exponent)))
|
|
||||||
|
|
||||||
;; default
|
|
||||||
(throw (ex-info (str "Unrecognised head: " (first p))
|
|
||||||
{:generating p})))
|
|
||||||
p)
|
|
||||||
(catch Throwable any
|
|
||||||
(throw (ex-info "Could not generate"
|
|
||||||
{:generating p}
|
|
||||||
any)))))
|
|
||||||
|
|
||||||
;; (defn parse
|
|
||||||
;; "Parse string `s` into a parse tree which can then be operated upon further."
|
|
||||||
;; [s]
|
|
||||||
;; (let [r (parse-internal s)]
|
|
||||||
;; (when (instance? Failure r)
|
|
||||||
;; (throw
|
|
||||||
;; (ex-info "Parse failed"
|
|
||||||
;; (merge {:fail r :source s} r))))
|
|
||||||
;; r))
|
|
||||||
|
|
||||||
|
|
||||||
(defn gsp
|
(defn gsp
|
||||||
"Shortcut macro - the internals of read; or, if you like, read-string.
|
"Shortcut macro - the internals of read; or, if you like, read-string.
|
||||||
Argument `s` should be a string representation of a valid Lisp
|
Argument `s` should be a string representation of a valid Lisp
|
||||||
|
|
@ -447,15 +63,24 @@
|
||||||
(throw (ex-info "Parse failed" (assoc parse-tree :source source))))
|
(throw (ex-info "Parse failed" (assoc parse-tree :source source))))
|
||||||
(generate (simplify parse-tree)))))
|
(generate (simplify parse-tree)))))
|
||||||
|
|
||||||
|
(defn read-from-console
|
||||||
|
"Attempt to read a complete lisp expression from the console."
|
||||||
|
[]
|
||||||
|
(loop [r (read-line)]
|
||||||
|
(if (= (count (re-seq #"\(" r))
|
||||||
|
(count (re-seq #"\)" r)))
|
||||||
|
r
|
||||||
|
(recur (str r "\n" (read-line))))))
|
||||||
|
|
||||||
(defn READ
|
(defn READ
|
||||||
"An implementation of a Lisp reader sufficient for bootstrapping; not necessarily
|
"An implementation of a Lisp reader sufficient for bootstrapping; not necessarily
|
||||||
the final Lisp reader. `input` should be either a string representation of a LISP
|
the final Lisp reader. `input` should be either a string representation of a LISP
|
||||||
expression, or else an input stream. A single form will be read."
|
expression, or else an input stream. A single form will be read."
|
||||||
([]
|
([]
|
||||||
(gsp (read-line)))
|
(gsp (read-from-console)))
|
||||||
([input]
|
([input]
|
||||||
(cond
|
(cond
|
||||||
(empty? input) (gsp (read-line))
|
(empty? input) (gsp (read-from-console))
|
||||||
(string? input) (gsp input)
|
(string? input) (gsp input)
|
||||||
(instance? InputStream input) (READ (slurp input))
|
(instance? InputStream input) (READ (slurp input))
|
||||||
:else (throw (ex-info "READ: `input` should be a string or an input stream" {})))))
|
:else (throw (ex-info "READ: `input` should be a string or an input stream" {})))))
|
||||||
|
|
|
||||||
198
src/beowulf/reader/generate.clj
Normal file
198
src/beowulf/reader/generate.clj
Normal file
|
|
@ -0,0 +1,198 @@
|
||||||
|
(ns beowulf.reader.generate
|
||||||
|
(:require [beowulf.cons-cell :refer [make-beowulf-list make-cons-cell NIL]]
|
||||||
|
[clojure.math.numeric-tower :refer [expt]]
|
||||||
|
[clojure.string :refer [upper-case]]))
|
||||||
|
|
||||||
|
;; # From Lisp 1.5 Programmers Manual, page 10
|
||||||
|
;; Note that I've retyped much of this, since copy/pasting out of PDF is less
|
||||||
|
;; than reliable. Any typos are mine. Quote starts [[
|
||||||
|
|
||||||
|
;; We are now in a position to define the universal LISP function
|
||||||
|
;; evalquote[fn;args], When evalquote is given a function and a list of arguments
|
||||||
|
;; for that function, it computes the value of the function applied to the arguments.
|
||||||
|
;; LISP functions have S-expressions as arguments. In particular, the argument "fn"
|
||||||
|
;; of the function evalquote must be an S-expression. Since we have been
|
||||||
|
;; writing functions as M-expressions, it is necessary to translate them into
|
||||||
|
;; S-expressions.
|
||||||
|
|
||||||
|
;; The following rules define a method of translating functions written in the
|
||||||
|
;; meta-language into S-expressions.
|
||||||
|
;; 1. If the function is represented by its name, it is translated by changing
|
||||||
|
;; all of the letters to upper case, making it an atomic symbol. Thus is
|
||||||
|
;; translated to CAR.
|
||||||
|
;; 2. If the function uses the lambda notation, then the expression
|
||||||
|
;; λ[[x ..;xn]; ε] is translated into (LAMBDA (X1 ...XN) ε*), where ε* is the translation
|
||||||
|
;; of ε.
|
||||||
|
;; 3. If the function begins with label, then the translation of
|
||||||
|
;; label[α;ε] is (LABEL α* ε*).
|
||||||
|
|
||||||
|
;; Forms are translated as follows:
|
||||||
|
;; 1. A variable, like a function name, is translated by using uppercase letters.
|
||||||
|
;; Thus the translation of varl is VAR1.
|
||||||
|
;; 2. The obvious translation of letting a constant translate into itself will not
|
||||||
|
;; work. Since the translation of x is X, the translation of X must be something
|
||||||
|
;; else to avoid ambiguity. The solution is to quote it. Thus X is translated
|
||||||
|
;; into (QUOTE X).
|
||||||
|
;; 3. The form fn[argl;. ..;argn] is translated into (fn* argl* ...argn*)
|
||||||
|
;; 4. The conditional expression [pl-el;...;pn-en] is translated into
|
||||||
|
;; (COND (p1* e1*)...(pn* en*))
|
||||||
|
|
||||||
|
;; ## Examples
|
||||||
|
|
||||||
|
;; M-expressions S-expressions
|
||||||
|
;; x X
|
||||||
|
;; car CAR
|
||||||
|
;; car[x] (CAR X)
|
||||||
|
;; T (QUOTE T)
|
||||||
|
;; ff[car [x]] (FF (CAR X))
|
||||||
|
;; [atom[x]->x; T->ff[car[x]]] (COND ((ATOM X) X)
|
||||||
|
;; ((QUOTE T)(FF (CAR X))))
|
||||||
|
;; label[ff;λ[[x];[atom[x]->x; T->ff[car[x]]]]] (LABEL FF (LAMBDA (X) (COND
|
||||||
|
;; ((ATOM X) X)
|
||||||
|
;; ((QUOTE T)(FF (CAR X))))))
|
||||||
|
|
||||||
|
;; ]] quote ends
|
||||||
|
|
||||||
|
(declare generate)
|
||||||
|
|
||||||
|
(defn gen-cond-clause
|
||||||
|
"Generate a cond clause from this simplified parse tree fragment `p`;
|
||||||
|
returns `nil` if `p` does not represent a cond clause."
|
||||||
|
[p]
|
||||||
|
(when
|
||||||
|
(and (coll? p) (= :cond-clause (first p)))
|
||||||
|
(make-beowulf-list
|
||||||
|
(list (if (= (nth p 1) [:quoted-expr [:atom "T"]])
|
||||||
|
'T
|
||||||
|
(generate (nth p 1)))
|
||||||
|
(generate (nth p 2))))))
|
||||||
|
|
||||||
|
(defn gen-cond
|
||||||
|
"Generate a cond statement from this simplified parse tree fragment `p`;
|
||||||
|
returns `nil` if `p` does not represent a (MEXPR) cond statement."
|
||||||
|
[p]
|
||||||
|
(when
|
||||||
|
(and (coll? p) (= :cond (first p)))
|
||||||
|
(make-beowulf-list
|
||||||
|
(cons
|
||||||
|
'COND
|
||||||
|
(map
|
||||||
|
generate
|
||||||
|
(rest p))))))
|
||||||
|
|
||||||
|
(defn gen-fn-call
|
||||||
|
"Generate a function call from this simplified parse tree fragment `p`;
|
||||||
|
returns `nil` if `p` does not represent a (MEXPR) function call."
|
||||||
|
[p]
|
||||||
|
(when
|
||||||
|
(and (coll? p) (= :fncall (first p)) (= :mvar (first (second p))))
|
||||||
|
(make-cons-cell
|
||||||
|
(generate (second p))
|
||||||
|
(generate (nth p 2)))))
|
||||||
|
|
||||||
|
|
||||||
|
(defn gen-dot-terminated-list
|
||||||
|
"Generate a list, which may be dot-terminated, from this partial parse tree
|
||||||
|
'p'. Note that the function acts recursively and progressively decapitates
|
||||||
|
its argument, so that the argument will not always be a valid parse tree."
|
||||||
|
[p]
|
||||||
|
(cond
|
||||||
|
(empty? p)
|
||||||
|
NIL
|
||||||
|
(and (coll? (first p)) (= :dot-terminal (first (first p))))
|
||||||
|
(let [dt (first p)]
|
||||||
|
(make-cons-cell
|
||||||
|
(generate (nth dt 1))
|
||||||
|
(generate (nth dt 2))))
|
||||||
|
:else
|
||||||
|
(make-cons-cell
|
||||||
|
(generate (first p))
|
||||||
|
(gen-dot-terminated-list (rest p)))))
|
||||||
|
|
||||||
|
(defn generate-defn
|
||||||
|
[tree]
|
||||||
|
(make-beowulf-list
|
||||||
|
(list 'SET
|
||||||
|
(list 'QUOTE (generate (-> tree second second)))
|
||||||
|
(list 'QUOTE
|
||||||
|
(cons 'LAMBDA
|
||||||
|
(cons (generate (nth (second tree) 2))
|
||||||
|
(map generate (-> tree rest rest rest))))))))
|
||||||
|
|
||||||
|
(defn generate-set
|
||||||
|
"Actually not sure what the mexpr representation of set looks like"
|
||||||
|
[tree]
|
||||||
|
(throw (ex-info "Not Yet Implemented" {:feature "generate-set"})))
|
||||||
|
|
||||||
|
(defn generate-assign
|
||||||
|
"Generate an assignment statement based on this `tree`. If the thing
|
||||||
|
being assigned to is a function signature, then we have to do something
|
||||||
|
different to if it's an atom."
|
||||||
|
[tree]
|
||||||
|
(case (first (second tree))
|
||||||
|
:fncall (generate-defn tree)
|
||||||
|
(:mvar :atom) (generate-set tree)))
|
||||||
|
|
||||||
|
(defn strip-leading-zeros
|
||||||
|
"`read-string` interprets strings with leading zeros as octal; strip
|
||||||
|
any from this string `s`. If what's left is empty (i.e. there were
|
||||||
|
only zeros, return `\"0\"`."
|
||||||
|
([s]
|
||||||
|
(strip-leading-zeros s ""))
|
||||||
|
([s prefix]
|
||||||
|
(if
|
||||||
|
(empty? s) "0"
|
||||||
|
(case (first s)
|
||||||
|
(\+ \-) (strip-leading-zeros (subs s 1) (str (first s) prefix))
|
||||||
|
"0" (strip-leading-zeros (subs s 1) prefix)
|
||||||
|
(str prefix s)))))
|
||||||
|
|
||||||
|
(defn generate
|
||||||
|
"Generate lisp structure from this parse tree `p`. It is assumed that
|
||||||
|
`p` has been simplified."
|
||||||
|
[p]
|
||||||
|
(try
|
||||||
|
(if
|
||||||
|
(coll? p)
|
||||||
|
(case (first p)
|
||||||
|
:λ "LAMBDA"
|
||||||
|
:λexpr (make-cons-cell
|
||||||
|
(generate (nth p 1))
|
||||||
|
(make-cons-cell (generate (nth p 2))
|
||||||
|
(generate (nth p 3))))
|
||||||
|
:args (make-beowulf-list (map generate (rest p)))
|
||||||
|
:atom (symbol (second p))
|
||||||
|
:bindings (generate (second p))
|
||||||
|
:body (make-beowulf-list (map generate (rest p)))
|
||||||
|
:cond (gen-cond p)
|
||||||
|
:cond-clause (gen-cond-clause p)
|
||||||
|
(:decimal :integer) (read-string (strip-leading-zeros (second p)))
|
||||||
|
:defn (generate-assign p)
|
||||||
|
:dotted-pair (make-cons-cell
|
||||||
|
(generate (nth p 1))
|
||||||
|
(generate (nth p 2)))
|
||||||
|
:exponent (generate (second p))
|
||||||
|
:fncall (gen-fn-call p)
|
||||||
|
:list (gen-dot-terminated-list (rest p))
|
||||||
|
:mvar (symbol (upper-case (second p)))
|
||||||
|
:octal (let [n (read-string (strip-leading-zeros (second p) "0"))
|
||||||
|
scale (generate (nth p 2))]
|
||||||
|
(* n (expt 8 scale)))
|
||||||
|
|
||||||
|
;; the quote read macro (which probably didn't exist in Lisp 1.5, but...)
|
||||||
|
:quoted-expr (make-beowulf-list (list 'QUOTE (generate (second p))))
|
||||||
|
:scale-factor (if
|
||||||
|
(empty? (second p)) 0
|
||||||
|
(read-string (strip-leading-zeros (second p))))
|
||||||
|
:scientific (let [n (generate (second p))
|
||||||
|
exponent (generate (nth p 2))]
|
||||||
|
(* n (expt 10 exponent)))
|
||||||
|
|
||||||
|
;; default
|
||||||
|
(throw (ex-info (str "Unrecognised head: " (first p))
|
||||||
|
{:generating p})))
|
||||||
|
p)
|
||||||
|
(catch Throwable any
|
||||||
|
(throw (ex-info "Could not generate"
|
||||||
|
{:generating p}
|
||||||
|
any)))))
|
||||||
84
src/beowulf/reader/parser.clj
Normal file
84
src/beowulf/reader/parser.clj
Normal file
|
|
@ -0,0 +1,84 @@
|
||||||
|
(ns beowulf.reader.parser
|
||||||
|
"The actual parser, supporting both S-expression and M-expression syntax."
|
||||||
|
(:require [instaparse.core :as i]))
|
||||||
|
|
||||||
|
(def parse
|
||||||
|
"Parse a string presented as argument into a parse tree which can then
|
||||||
|
be operated upon further."
|
||||||
|
(i/parser
|
||||||
|
(str
|
||||||
|
;; we tolerate whitespace and comments around legitimate input
|
||||||
|
"raw := expr | opt-comment expr opt-comment;"
|
||||||
|
;; top level: we accept mexprs as well as sexprs.
|
||||||
|
"expr := mexpr | sexpr ;"
|
||||||
|
|
||||||
|
;; comments. I'm pretty confident Lisp 1.5 did NOT have these.
|
||||||
|
"comment := opt-space <';;'> opt-space #'[^\\n\\r]*';"
|
||||||
|
|
||||||
|
;; there's a notation comprising a left brace followed by mexprs
|
||||||
|
;; followed by a right brace which doesn't seem to be documented
|
||||||
|
;; but I think must represent a prog(?)
|
||||||
|
|
||||||
|
;; "prog := lbrace exprs rbrace;"
|
||||||
|
;; mexprs. I'm pretty clear that Lisp 1.5 could never read these,
|
||||||
|
;; but it's a convenience.
|
||||||
|
|
||||||
|
"exprs := expr | exprs;"
|
||||||
|
"mexpr := λexpr | fncall | defn | cond | mvar | iexpr | mexpr comment;
|
||||||
|
λexpr := λ lsqb bindings semi-colon body rsqb;
|
||||||
|
λ := 'λ';
|
||||||
|
bindings := lsqb args rsqb;
|
||||||
|
body := (expr semi-colon opt-space)* expr;
|
||||||
|
fncall := fn-name lsqb args rsqb;
|
||||||
|
lsqb := '[';
|
||||||
|
rsqb := ']';
|
||||||
|
lbrace := '{';
|
||||||
|
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;
|
||||||
|
arrow := '->';
|
||||||
|
args := (opt-space expr semi-colon opt-space)* expr;
|
||||||
|
fn-name := mvar;
|
||||||
|
mvar := #'[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.
|
||||||
|
"iexpr := iexp iop iexp;
|
||||||
|
iexp := mexpr | mvar | number | mexpr | opt-space iexp opt-space;
|
||||||
|
iop := '>' | '<' | '+' | '-' | '/' | '=' ;"
|
||||||
|
|
||||||
|
;; comments. I'm pretty confident Lisp 1.5 did NOT have these.
|
||||||
|
"opt-comment := opt-space | comment;"
|
||||||
|
"comment := opt-space <';;'> #'[^\\n\\r]*' opt-space;"
|
||||||
|
|
||||||
|
;; sexprs. Note it's not clear to me whether Lisp 1.5 had the quote macro,
|
||||||
|
;; but I've included it on the basis that it can do little harm.
|
||||||
|
"sexpr := quoted-expr | atom | number | dotted-pair | list | sexpr comment;
|
||||||
|
list := lpar sexpr rpar | lpar (sexpr sep)* rpar | lpar (sexpr sep)* dot-terminal | lbrace exprs rbrace;
|
||||||
|
list := lpar opt-space sexpr rpar | lpar opt-space (sexpr sep)* rpar | lpar opt-space (sexpr sep)* dot-terminal;
|
||||||
|
dotted-pair := lpar dot-terminal ;
|
||||||
|
dot := '.';
|
||||||
|
lpar := '(';
|
||||||
|
rpar := ')';
|
||||||
|
quoted-expr := quote sexpr;
|
||||||
|
quote := '\\'';
|
||||||
|
dot-terminal := sexpr space dot space sexpr rpar;
|
||||||
|
space := #'\\p{javaWhitespace}+';
|
||||||
|
opt-space := #'\\p{javaWhitespace}*';
|
||||||
|
sep := ',' | opt-space;
|
||||||
|
atom := #'[A-Z][A-Z0-9]*';"
|
||||||
|
|
||||||
|
;; Lisp 1.5 supported octal as well as decimal and scientific notation
|
||||||
|
"number := integer | decimal | scientific | octal;
|
||||||
|
integer := #'-?[1-9][0-9]*';
|
||||||
|
decimal := #'-?[1-9][0-9]*\\.?[0-9]*' | #'0.[0-9]*';
|
||||||
|
scientific := coefficient e exponent;
|
||||||
|
coefficient := decimal;
|
||||||
|
exponent := integer;
|
||||||
|
e := 'E';
|
||||||
|
octal := #'[+-]?[0-7]+{1,12}' q scale-factor;
|
||||||
|
q := 'Q';
|
||||||
|
scale-factor := #'[0-9]*'")))
|
||||||
|
|
||||||
94
src/beowulf/reader/simplify.clj
Normal file
94
src/beowulf/reader/simplify.clj
Normal file
|
|
@ -0,0 +1,94 @@
|
||||||
|
(ns beowulf.reader.simplify
|
||||||
|
"Simplify parse trees. Be aware that this is very tightly coupled
|
||||||
|
with the parser."
|
||||||
|
(:require [beowulf.bootstrap :refer [*options*]]
|
||||||
|
[instaparse.failure :as f])
|
||||||
|
(:import [instaparse.gll Failure]))
|
||||||
|
|
||||||
|
(declare simplify)
|
||||||
|
|
||||||
|
(defn remove-optional-space
|
||||||
|
[tree]
|
||||||
|
(if (vector? tree)
|
||||||
|
(if (= :opt-space (first tree))
|
||||||
|
nil
|
||||||
|
(remove nil?
|
||||||
|
(map remove-optional-space tree)))
|
||||||
|
tree))
|
||||||
|
|
||||||
|
(defn remove-nesting
|
||||||
|
[tree]
|
||||||
|
(let [tree' (remove-optional-space tree)]
|
||||||
|
(if-let [key (when (and (vector? tree') (keyword? (first tree'))) (first tree'))]
|
||||||
|
(loop [r tree']
|
||||||
|
(if (and r (vector? r) (keyword? (first r)))
|
||||||
|
(if (= (first r) key)
|
||||||
|
(recur (simplify (second r) :foo))
|
||||||
|
r)
|
||||||
|
r))
|
||||||
|
tree')))
|
||||||
|
|
||||||
|
|
||||||
|
(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."
|
||||||
|
([p]
|
||||||
|
(if
|
||||||
|
(instance? Failure p)
|
||||||
|
(throw (ex-info (str "Ic ne behæfd: " (f/pprint-failure p)) {:cause :parse-failure
|
||||||
|
:phase :simplify
|
||||||
|
:failure p}))
|
||||||
|
(simplify p :expr)))
|
||||||
|
([p context]
|
||||||
|
(if
|
||||||
|
(coll? p)
|
||||||
|
(apply
|
||||||
|
vector
|
||||||
|
(remove
|
||||||
|
#(when (coll? %) (empty? %))
|
||||||
|
(case (first p)
|
||||||
|
(:λexpr
|
||||||
|
:args :bindings :body :cond :cond-clause :defn :dot-terminal
|
||||||
|
:fncall :lhs :octal :quoted-expr :rhs :scientific) (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
|
||||||
|
:atom (if
|
||||||
|
(= context :mexpr)
|
||||||
|
[:quoted-expr p]
|
||||||
|
p)
|
||||||
|
:comment (when
|
||||||
|
(:strict *options*)
|
||||||
|
(throw
|
||||||
|
(ex-info "Cannot parse comments in strict mode"
|
||||||
|
{:cause :strict})))
|
||||||
|
:dotted-pair (if
|
||||||
|
(= context :mexpr)
|
||||||
|
[:fncall
|
||||||
|
[:mvar "cons"]
|
||||||
|
[:args
|
||||||
|
(simplify (nth p 1) context)
|
||||||
|
(simplify (nth p 2) context)]]
|
||||||
|
(map simplify p))
|
||||||
|
:iexp (second (remove-nesting p))
|
||||||
|
:iexpr [:iexpr
|
||||||
|
[:lhs (simplify (second p) context)]
|
||||||
|
(simplify (nth p 2) context) ;; really should be the operator
|
||||||
|
[:rhs (simplify (nth p 3) context)]]
|
||||||
|
:mexpr (if
|
||||||
|
(:strict *options*)
|
||||||
|
(throw
|
||||||
|
(ex-info "Cannot parse meta expressions in strict mode"
|
||||||
|
{:cause :strict}))
|
||||||
|
(simplify (second p) :mexpr))
|
||||||
|
:list (if
|
||||||
|
(= context :mexpr)
|
||||||
|
[:fncall
|
||||||
|
[:mvar "list"]
|
||||||
|
[:args (apply vector (map simplify (rest p)))]]
|
||||||
|
(map #(simplify % context) p))
|
||||||
|
:raw (first (remove empty? (map simplify (rest p))))
|
||||||
|
:sexpr (simplify (second p) :sexpr)
|
||||||
|
;;default
|
||||||
|
p)))
|
||||||
|
p)))
|
||||||
|
|
@ -1,8 +1,9 @@
|
||||||
(ns beowulf.bootstrap-test
|
(ns beowulf.bootstrap-test
|
||||||
(:require [clojure.math.numeric-tower :refer [abs]]
|
(:require [clojure.test :refer [deftest testing is]]
|
||||||
[clojure.test :refer :all]
|
[beowulf.cons-cell :refer [make-cons-cell NIL T F]]
|
||||||
[beowulf.cons-cell :refer [make-beowulf-list make-cons-cell NIL T F]]
|
[beowulf.bootstrap :refer [APPEND ASSOC ATOM ATOM? CAR CAAAAR CADR
|
||||||
[beowulf.bootstrap :refer :all]
|
CADDR CADDDR CDR EQ EQUAL MEMBER
|
||||||
|
PAIRLIS SUBLIS SUBST]]
|
||||||
[beowulf.read :refer [gsp]]))
|
[beowulf.read :refer [gsp]]))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
@ -51,21 +52,6 @@
|
||||||
actual (ATOM? (gsp "(A B C D)"))]
|
actual (ATOM? (gsp "(A B C D)"))]
|
||||||
(is (= actual expected) "A list is explicitly not an atom"))))
|
(is (= actual expected) "A list is explicitly not an atom"))))
|
||||||
|
|
||||||
(deftest numberp-tests
|
|
||||||
(testing "NUMBERP"
|
|
||||||
(let [expected T
|
|
||||||
actual (NUMBERP 7)]
|
|
||||||
(is (= actual expected) "7 is a number"))
|
|
||||||
(let [expected T
|
|
||||||
actual (NUMBERP 3.14)]
|
|
||||||
(is (= actual expected) "3.14 is a number"))
|
|
||||||
(let [expected F
|
|
||||||
actual (NUMBERP NIL)]
|
|
||||||
(is (= actual expected) "NIL is not a number"))
|
|
||||||
(let [expected F
|
|
||||||
actual (NUMBERP (gsp "HELLO"))]
|
|
||||||
(is (= actual expected) "HELLO is not a number"))))
|
|
||||||
|
|
||||||
(deftest access-function-tests
|
(deftest access-function-tests
|
||||||
(testing "CAR"
|
(testing "CAR"
|
||||||
(let [expected 'A
|
(let [expected 'A
|
||||||
|
|
@ -132,13 +118,18 @@
|
||||||
(let [expected 'T
|
(let [expected 'T
|
||||||
actual (EQ 'FRED 'FRED)]
|
actual (EQ 'FRED 'FRED)]
|
||||||
(is (= actual expected) "identical symbols"))
|
(is (= actual expected) "identical symbols"))
|
||||||
(let [expected 'F
|
(let [expected 'NIL
|
||||||
actual (EQ 'FRED 'ELFREDA)]
|
actual (EQ 'FRED 'ELFREDA)]
|
||||||
(is (= actual expected) "different symbols"))
|
(is (= actual expected) "different symbols"))
|
||||||
(let [expected 'F
|
(let [expected 'T
|
||||||
l (gsp "(NOT AN ATOM)")
|
l (gsp "(NOT AN ATOM)")
|
||||||
actual (EQ l l)]
|
actual (EQ l l)]
|
||||||
(is (= actual expected) "identical lists (EQ is not defined for lists)")))
|
(is (= actual expected) "identically the same list"))
|
||||||
|
(let [expected 'NIL
|
||||||
|
l1 (gsp "(NOT AN ATOM)")
|
||||||
|
l2 (gsp "(NOT AN ATOM)")
|
||||||
|
actual (EQ l1 l2)]
|
||||||
|
(is (= actual expected) "different lists with the same content")))
|
||||||
(testing "equal"
|
(testing "equal"
|
||||||
(let [expected 'T
|
(let [expected 'T
|
||||||
actual (EQUAL 'FRED 'FRED)]
|
actual (EQUAL 'FRED 'FRED)]
|
||||||
|
|
|
||||||
|
|
@ -1,11 +1,12 @@
|
||||||
(ns beowulf.cons-cell-test
|
(ns beowulf.cons-cell-test
|
||||||
(:require [clojure.test :refer :all]
|
(:require [clojure.test :refer [deftest is testing]]
|
||||||
[beowulf.cons-cell :refer :all]))
|
[beowulf.cons-cell :refer [make-beowulf-list make-cons-cell pretty-print]])
|
||||||
|
(:import [beowulf.cons_cell ConsCell]))
|
||||||
|
|
||||||
(deftest cons-cell-tests
|
(deftest cons-cell-tests
|
||||||
(testing "make-cons-cell"
|
(testing "make-cons-cell"
|
||||||
(let [expected "(A . B)"
|
(let [expected "(A . B)"
|
||||||
actual (print-str (beowulf.cons_cell.ConsCell. 'A 'B))]
|
actual (print-str (ConsCell. 'A 'B (gensym "c")))]
|
||||||
(is (= actual expected) "Cons cells should print as cons cells, natch."))
|
(is (= actual expected) "Cons cells should print as cons cells, natch."))
|
||||||
(let [expected "(A . B)"
|
(let [expected "(A . B)"
|
||||||
actual (print-str (make-cons-cell 'A 'B))]
|
actual (print-str (make-cons-cell 'A 'B))]
|
||||||
|
|
|
||||||
|
|
@ -1,8 +1,8 @@
|
||||||
(ns beowulf.core-test
|
(ns beowulf.core-test
|
||||||
(:require [clojure.java.io :refer [reader]]
|
(:require [clojure.java.io :refer [reader]]
|
||||||
[clojure.string :refer [split]]
|
[clojure.string :refer [split]]
|
||||||
[clojure.test :refer :all]
|
[clojure.test :refer [deftest is testing]]
|
||||||
[beowulf.core :refer :all]))
|
[beowulf.core :refer [-main repl stop-word]]))
|
||||||
|
|
||||||
;; (deftest a-test
|
;; (deftest a-test
|
||||||
;; (testing "FIXME, I fail."
|
;; (testing "FIXME, I fail."
|
||||||
|
|
@ -36,7 +36,7 @@
|
||||||
(testing "No flags"
|
(testing "No flags"
|
||||||
(let [expected-greeting "Hider wilcuman. Béowulf is mín nama."
|
(let [expected-greeting "Hider wilcuman. Béowulf is mín nama."
|
||||||
expected-quit-message (str "Sprecan '" stop-word "' tó laéfan")
|
expected-quit-message (str "Sprecan '" stop-word "' tó laéfan")
|
||||||
expected-result #".*\(A \. B\)"
|
expected-result #".*\(3 \. 4\)"
|
||||||
expected-prompt "Sprecan:: "
|
expected-prompt "Sprecan:: "
|
||||||
expected-signoff "Færwell!"
|
expected-signoff "Færwell!"
|
||||||
;; anticipated output (note blank lines):
|
;; anticipated output (note blank lines):
|
||||||
|
|
@ -45,11 +45,11 @@
|
||||||
|
|
||||||
; Sprecan 'STOP' tó laéfan
|
; Sprecan 'STOP' tó laéfan
|
||||||
|
|
||||||
; Sprecan:: > (A . B)
|
; Sprecan:: > (3 . 4)
|
||||||
; Sprecan::
|
; Sprecan::
|
||||||
; Færwell!
|
; Færwell!
|
||||||
[_ greeting _ _ quit-message _ result prompt signoff]
|
[_ greeting _ _ quit-message _ result prompt signoff]
|
||||||
(with-open [r (reader (string->stream (str "cons[A; B]\n" stop-word)))]
|
(with-open [r (reader (string->stream (str "cons[3; 4]\n" stop-word)))]
|
||||||
(binding [*in* r]
|
(binding [*in* r]
|
||||||
(split (with-out-str (-main)) #"\n")))]
|
(split (with-out-str (-main)) #"\n")))]
|
||||||
(is (= greeting expected-greeting))
|
(is (= greeting expected-greeting))
|
||||||
|
|
@ -63,11 +63,11 @@
|
||||||
(let [expected-greeting "Hider wilcuman. Béowulf is mín nama."
|
(let [expected-greeting "Hider wilcuman. Béowulf is mín nama."
|
||||||
expected-quit-message (str "Sprecan '" stop-word "' tó laéfan")
|
expected-quit-message (str "Sprecan '" stop-word "' tó laéfan")
|
||||||
expected-error #"Unknown option:.*"
|
expected-error #"Unknown option:.*"
|
||||||
expected-result #".*\(A \. B\)"
|
expected-result #".*\(5 \. 6\)"
|
||||||
expected-prompt "Sprecan:: "
|
expected-prompt "Sprecan:: "
|
||||||
expected-signoff "Færwell!"
|
expected-signoff "Færwell!"
|
||||||
[_ greeting _ error quit-message _ result prompt signoff]
|
[_ greeting _ error quit-message _ result prompt signoff]
|
||||||
(with-open [r (reader (string->stream (str "cons[A; B]\n" stop-word)))]
|
(with-open [r (reader (string->stream (str "cons[5; 6]\n" stop-word)))]
|
||||||
(binding [*in* r]
|
(binding [*in* r]
|
||||||
(split (with-out-str (-main "--unknown")) #"\n")))]
|
(split (with-out-str (-main "--unknown")) #"\n")))]
|
||||||
(is (= greeting expected-greeting))
|
(is (= greeting expected-greeting))
|
||||||
|
|
|
||||||
|
|
@ -1,9 +1,8 @@
|
||||||
(ns beowulf.host-test
|
(ns beowulf.host-test
|
||||||
(:require [clojure.math.numeric-tower :refer [abs]]
|
(:require [clojure.test :refer [deftest is testing]]
|
||||||
[clojure.test :refer :all]
|
|
||||||
[beowulf.cons-cell :refer [make-beowulf-list make-cons-cell NIL T F]]
|
|
||||||
[beowulf.bootstrap :refer [CDR]]
|
[beowulf.bootstrap :refer [CDR]]
|
||||||
[beowulf.host :refer :all]
|
[beowulf.cons-cell :refer [F make-beowulf-list NIL T]]
|
||||||
|
[beowulf.host :refer [DIFFERENCE NUMBERP PLUS2 RPLACA RPLACD TIMES2]]
|
||||||
[beowulf.read :refer [gsp]]))
|
[beowulf.read :refer [gsp]]))
|
||||||
|
|
||||||
(deftest destructive-change-test
|
(deftest destructive-change-test
|
||||||
|
|
@ -35,6 +34,21 @@
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
|
|
||||||
|
(deftest numberp-tests
|
||||||
|
(testing "NUMBERP"
|
||||||
|
(let [expected T
|
||||||
|
actual (NUMBERP 7)]
|
||||||
|
(is (= actual expected) "7 is a number"))
|
||||||
|
(let [expected T
|
||||||
|
actual (NUMBERP 3.14)]
|
||||||
|
(is (= actual expected) "3.14 is a number"))
|
||||||
|
(let [expected F
|
||||||
|
actual (NUMBERP NIL)]
|
||||||
|
(is (= actual expected) "NIL is not a number"))
|
||||||
|
(let [expected F
|
||||||
|
actual (NUMBERP (gsp "HELLO"))]
|
||||||
|
(is (= actual expected) "HELLO is not a number"))))
|
||||||
|
|
||||||
(deftest arithmetic-test
|
(deftest arithmetic-test
|
||||||
;; These are just sanity-test tests; they're by no means exhaustive.
|
;; These are just sanity-test tests; they're by no means exhaustive.
|
||||||
(testing "PLUS2"
|
(testing "PLUS2"
|
||||||
|
|
|
||||||
|
|
@ -1,8 +1,6 @@
|
||||||
(ns beowulf.interop-test
|
(ns beowulf.interop-test
|
||||||
(:require [clojure.test :refer :all]
|
(:require [clojure.test :refer [deftest is testing]]
|
||||||
[beowulf.cons-cell :refer [make-beowulf-list make-cons-cell NIL T F]]
|
|
||||||
[beowulf.bootstrap :refer [EVAL INTEROP QUOTE]]
|
[beowulf.bootstrap :refer [EVAL INTEROP QUOTE]]
|
||||||
[beowulf.host :refer :all]
|
|
||||||
[beowulf.read :refer [gsp]]))
|
[beowulf.read :refer [gsp]]))
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,9 +1,12 @@
|
||||||
(ns beowulf.mexpr-test
|
(ns beowulf.mexpr-test
|
||||||
"These tests are taken generally from the examples on page 10 of
|
"These tests are taken generally from the examples on page 10 of
|
||||||
Lisp 1.5 Programmers Manual"
|
Lisp 1.5 Programmers Manual"
|
||||||
(:require [clojure.test :refer :all]
|
(:require [clojure.test :refer [deftest is testing]]
|
||||||
[beowulf.bootstrap :refer [*options*]]
|
[beowulf.bootstrap :refer [*options*]]
|
||||||
[beowulf.read :refer [parse simplify generate gsp]]))
|
[beowulf.read :refer [gsp]]
|
||||||
|
[beowulf.reader.generate :refer [generate]]
|
||||||
|
[beowulf.reader.parser :refer [parse]]
|
||||||
|
[beowulf.reader.simplify :refer [simplify]]))
|
||||||
|
|
||||||
;; These tests are taken generally from the examples on page 10 of
|
;; These tests are taken generally from the examples on page 10 of
|
||||||
;; Lisp 1.5 Programmers Manual:
|
;; Lisp 1.5 Programmers Manual:
|
||||||
|
|
@ -39,13 +42,14 @@
|
||||||
;; Wrapping in a function call puts us into mexpr contest;
|
;; Wrapping in a function call puts us into mexpr contest;
|
||||||
;; "T" would be interpreted as a sexpr, which would not be
|
;; "T" would be interpreted as a sexpr, which would not be
|
||||||
;; quoted.
|
;; quoted.
|
||||||
(let [expected "(ATOM (QUOTE A))"
|
(let [expected "(ATOM A)"
|
||||||
actual (print-str (gsp "atom[A]"))]
|
actual (print-str (gsp "atom[A]"))]
|
||||||
(is (= actual expected)
|
(is (= actual expected)))
|
||||||
"Atoms should normally be quoted"))
|
|
||||||
;; I'm not clear how `car[(A B C)]` should be translated, but
|
;; I'm not clear how `car[(A B C)]` should be translated, but
|
||||||
;; I suspect as (CAR (LIST 'A 'B 'C)).
|
;; I suspect as (CAR (LIST A B C)).
|
||||||
|
(let [expected "(CAR (LIST A B C))"
|
||||||
|
actual (print-str (gsp "car[(A B C)]"))]
|
||||||
|
(is (= actual expected)))
|
||||||
))
|
))
|
||||||
|
|
||||||
(deftest fncall-tests
|
(deftest fncall-tests
|
||||||
|
|
@ -79,6 +83,6 @@
|
||||||
|
|
||||||
(deftest assignment-tests
|
(deftest assignment-tests
|
||||||
(testing "Function assignment"
|
(testing "Function assignment"
|
||||||
(let [expected "(SET (QUOTE FF) (LAMBDA (X) (COND ((ATOM X) X) (T (FF (CAR X))))))"
|
(let [expected "(SET (QUOTE FF) (QUOTE (LAMBDA (X) (COND ((ATOM X) X) (T (FF (CAR X)))))))"
|
||||||
actual (gsp "ff[x]=[atom[x] -> x; T -> ff[car[x]]]")]
|
actual (print-str (gsp "ff[x]=[atom[x] -> x; T -> ff[car[x]]]"))]
|
||||||
(is (= actual expected)))))
|
(is (= actual expected)))))
|
||||||
|
|
|
||||||
|
|
@ -1,28 +1,27 @@
|
||||||
(ns beowulf.sexpr-test
|
(ns beowulf.sexpr-test
|
||||||
(:require [clojure.math.numeric-tower :refer [abs]]
|
(:require [clojure.test :refer [deftest is testing]]
|
||||||
[clojure.test :refer :all]
|
|
||||||
[beowulf.cons-cell :refer :all]
|
|
||||||
[beowulf.bootstrap :refer [*options*]]
|
[beowulf.bootstrap :refer [*options*]]
|
||||||
[beowulf.read :refer [parse simplify generate gsp]]))
|
[beowulf.cons-cell :refer []]
|
||||||
|
[beowulf.read :refer [gsp]]))
|
||||||
|
|
||||||
;; broadly, sexprs should be homoiconic
|
;; broadly, sexprs should be homoiconic
|
||||||
|
|
||||||
(deftest atom-tests
|
(deftest atom-tests
|
||||||
(testing "Reading atoms"
|
(testing "Reading atoms"
|
||||||
(let [expected 'A
|
(let [expected 'A
|
||||||
actual (gsp(str expected))]
|
actual (gsp (str expected))]
|
||||||
(is (= actual expected)))
|
(is (= actual expected)))
|
||||||
(let [expected 'APPLE
|
(let [expected 'APPLE
|
||||||
actual (gsp(str expected))]
|
actual (gsp (str expected))]
|
||||||
(is (= actual expected)))
|
(is (= actual expected)))
|
||||||
(let [expected 'PART2
|
(let [expected 'PART2
|
||||||
actual (gsp(str expected))]
|
actual (gsp (str expected))]
|
||||||
(is (= actual expected)))
|
(is (= actual expected)))
|
||||||
(let [expected 'EXTRALONGSTRINGOFLETTERS
|
(let [expected 'EXTRALONGSTRINGOFLETTERS
|
||||||
actual (gsp(str expected))]
|
actual (gsp (str expected))]
|
||||||
(is (= actual expected)))
|
(is (= actual expected)))
|
||||||
(let [expected 'A4B66XYZ2
|
(let [expected 'A4B66XYZ2
|
||||||
actual (gsp(str expected))]
|
actual (gsp (str expected))]
|
||||||
(is (= actual expected)))))
|
(is (= actual expected)))))
|
||||||
|
|
||||||
(deftest comment-tests
|
(deftest comment-tests
|
||||||
|
|
@ -41,13 +40,13 @@
|
||||||
B C)"))]
|
B C)"))]
|
||||||
(is (= actual expected)
|
(is (= actual expected)
|
||||||
"Really important that comments work inside lists"))
|
"Really important that comments work inside lists"))
|
||||||
;; ;; TODO: Currently failing and I'm not sure why
|
;; ;; TODO: Currently failing and I'm not sure why
|
||||||
;; (binding [*options* {:strict true}]
|
;; (binding [*options* {:strict true}]
|
||||||
;; (is (thrown-with-msg?
|
;; (is (thrown-with-msg?
|
||||||
;; Exception
|
;; Exception
|
||||||
;; #"Cannot parse comments in strict mode"
|
;; #"Cannot parse comments in strict mode"
|
||||||
;; (gsp "(A ;; comment
|
;; (gsp "(A ;; comment
|
||||||
;; B C)"))))
|
;; B C)"))))
|
||||||
))
|
))
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue