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

#7: Progress! No longer breaking!

Browse source 
Bug is now probably in the implementation of CONC rather than in EVAL.
This commit is contained in:
Simon Brooke 2023-04-16 10:51:17 +01:00
parent d2ce61e6a7
commit d563f390c1
No known key found for this signature in database
GPG key ID: A7A4F18D1D4DF987
4 changed files with 111 additions and 30 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

22
resources/sexpr/fact.lsp Normal file
View file

@ -0,0 +1,22 @@
;; Common Lisp
(defun range (max &key (min 0) (step 1))
(loop for n from min below max by step
collect n))
(mapcar #'(lambda (x) (+ x 1)) (range 10))
(defun factoriali (n)
(reduce #'* (range (+ n 1) :min 1 :step 1)))
(defun factorialr (n)
(cond ((= n 1) 1)
(t (* n (factorialr (- n 1))))))
;; Clojure
(defn factorial [n]
(reduce *' (range 1 (+ n 1))))
(defn expt [n x]
(reduce *' (repeat x n)))

13
resources/sexpr/select.lsp Normal file
View file

@ -0,0 +1,13 @@
;; Bottom of page 66
(PUT 'SELECT 'FEXPR
'(LABEL FORM
(PROG (Q BODY)
(SETQ Q (EVAL (CAR FORM))) ;; not sure that Q should be evaled.
(SETQ BODY (CDR FORM))
LOOP
(COND
((EQ NIL (CDR BODY)) (RETURN (CAR BODY)))
((EQ Q (EVAL (CAAR BODY))) (RETURN (CDAR BODY))))
(SETQ BODY (CDR BODY))
(GO LOOP))))

93
src/beowulf/bootstrap.clj
View file

@ -11,9 +11,10 @@
objects."
(:require [beowulf.cons-cell :refer [F make-beowulf-list make-cons-cell
pretty-print T]]
[beowulf.host :refer [ASSOC ATOM CAAR CADAR CADDR CADR CAR CDR
[beowulf.host :refer [ASSOC ATOM CAAR CAADR CADAR CADDR CADR CAR CDR
CONS ERROR GET LIST NUMBERP PAIRLIS traced?]]
[beowulf.oblist :refer [*options* NIL]])
[beowulf.oblist :refer [*options* NIL]]
[clojure.tools.trace :refer [deftrace]])
(:import [beowulf.cons_cell ConsCell]
[clojure.lang Symbol]))
@ -37,7 +38,7 @@
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(declare APPLY EVAL prog-eval)
(declare APPLY EVAL EVCON prog-eval)
;;;; The PROGram feature ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -88,30 +89,45 @@
(cond
(number? expr) expr
(symbol? expr) (@vars expr)
(instance? ConsCell expr) (case (.getCar expr)
COND (prog-cond (.getCdr expr)
(instance? ConsCell expr) (case (CAR expr)
COND (prog-cond (CDR expr)
vars env depth)
GO (make-cons-cell
'*PROGGO* (.getCar (.getCdr expr)))
RETURN (make-cons-cell
'*PROGRETURN*
(prog-eval (.getCar (.getCdr expr))
vars env depth))
SET (let [v (CADDR expr)]
GO (let [target (CADR expr)]
(when (traced? 'PROG)
(println " PROG:GO: Goto " target))
(make-cons-cell
'*PROGGO* target))
RETURN (let [val (prog-eval
(CADR expr)
vars env depth)]
(when (traced? 'PROG)
(println " PROG:RETURN: Returning "
val)
(make-cons-cell
'*PROGRETURN*
val)))
SET (let [var (prog-eval (CADR expr)
vars env depth)
val (prog-eval (CADDR expr)
vars env depth)]
(when (traced? 'PROG)
(println " PROG:SET: Setting "
var " to " val))
(swap! vars
assoc
(prog-eval (CADR expr)
vars env depth)
(prog-eval (CADDR expr)
vars env depth))
v)
SETQ (let [v (CADDR expr)]
var
val)
val)
SETQ (let [var (CADDR expr)
val (prog-eval var
vars env depth)]
(when (traced? 'PROG)
(println " PROG:SETQ: Setting " var " to " val))
(swap! vars
assoc
(CADR expr)
(prog-eval v
vars env depth))
v)
val)
val)
;; else
(beowulf.bootstrap/EVAL expr
(merge-vars vars env)
@ -224,7 +240,7 @@
(println (str "<" indent " " function-symbol " " response))))
response)
(defn- value
(defn value
"Seek a value for this symbol `s` by checking each of these indicators in
turn."
([s]
@ -269,7 +285,7 @@
return the result."
[^Symbol function-symbol args ^ConsCell environment depth]
(trace-call function-symbol args depth)
(let [lisp-fn (value function-symbol '(EXPR FEXPR))
(let [lisp-fn (value function-symbol '(EXPR FEXPR)) ;; <-- should these be handled differently? I think so!
args' (cond (= NIL args) args
(empty? args) NIL
(instance? ConsCell args) args
@ -296,17 +312,36 @@
(trace-response function-symbol result depth)
result))
(defn- apply-label
;; (LABEL ARGS
;; (COND ((COND ((ONEP (LENGTH ARGS)) ARGS)
;; (T (ATTRIB (CAR ARGS) (APPLY CONC (CDR ARGS) NIL))))
;; ARGS)))
;; ((1 2 3 4) (5 6 7 8) (9 10 11 12))
;; NIL
;; (def function (make-beowulf-list '(LABEL ARGS (COND
;; ((COND ((ONEP (LENGTH ARGS)) ARGS)
;; (T (ATTRIB (CAR ARGS)
;; (APPLY CONC (CDR ARGS) NIL))))
;; ARGS)))))
;; (def args (make-beowulf-list '((1 2 3 4) (5 6 7 8) (9 10 11 12))))
;; function
;; (CADR function)
;; (CADDR function)
(defn apply-label
"Apply in the special case that the first element in the function is `LABEL`."
[function args environment depth]
(APPLY
(EVAL
(CADDR function)
args
(CONS
(CONS (CADR function) (CADDR function))
(CONS (CADR function) args)
environment)
depth))
;; (apply-label function args NIL 1)
;; (APPLY function args NIL 1)
(defn- apply-lambda
"Apply in the special case that the first element in the function is `LAMBDA`."
[function args environment depth]
@ -340,6 +375,8 @@
FUNARG (APPLY (CADR function) args (CADDR function) depth)
LAMBDA (apply-lambda function args environment depth)
;; else
;; OK, this is *not* what is says in the manual...
;; COND (EVCON ???)
(throw (ex-info "Ungecnáwen wyrþan sí þegnung-weard"
{:phase :apply
:function function
@ -394,7 +431,7 @@
(println (str indent ": EVAL: sceald bindele: " (or v "nil"))))
(if (instance? ConsCell v)
(.getCdr v)
(let [v' (value expr (list 'APVAL))]
(let [v' (value expr)]
(when (traced? 'EVAL)
(println (str indent ": EVAL: deóp bindele: (" expr " . " (or v' "nil") ")")))
(if v'

11
test/beowulf/lisp_test.clj
View file

@ -167,7 +167,6 @@
(T (GO START))))")]
(is (= actual expected)))))
(deftest put-get-tests
(let [symbol 'TESTSYMBOL
p1 'TESTPROPONE
@ -204,3 +203,13 @@
(is (= actual1 expected1) "The value set can be retrieved.")
(is (= actual2 expected2) "Values are independent.")
(is (= actual3 expected3) "Setting a second property does not obliterate the first.")))))
(deftest fsubr-tests
(testing "FSUBR/CONC"
(reps "(SETQ P (RANGE 1 4))")
(reps "(SETQ Q (RANGE 5 8))")
(reps "(SETQ R (RANGE 9 12))")
(reps "(CONC P Q R)")
(let [expected "(1 2 3 4 5 6 7 8 9 10 11 12)"
actual (reps "X")]
(is (= actual expected)))))