diff --git a/lib/scheme/eval.sx b/lib/scheme/eval.sx index a0559692..7c5c18f3 100644 --- a/lib/scheme/eval.sx +++ b/lib/scheme/eval.sx @@ -78,6 +78,126 @@ (error "quote: expects exactly 1 argument")) (:else (first args))))) +;; if — (if TEST CONSEQUENT) or (if TEST CONSEQUENT ALTERNATE). +;; Scheme truthiness: only #f is false; everything else (incl. nil/empty +;; list) is truthy. Match SX's `if` semantics where possible. +(scheme-define-op! "if" + (fn (args env) + (cond + ((< (length args) 2) + (error "if: expects (test then [else])")) + (:else + (let ((test-val (scheme-eval (first args) env))) + (cond + ((not (= test-val false)) + (scheme-eval (nth args 1) env)) + ((>= (length args) 3) + (scheme-eval (nth args 2) env)) + (:else nil))))))) + +;; set! — mutate an existing binding by walking the env chain. +(scheme-define-op! "set!" + (fn (args env) + (cond + ((not (= (length args) 2)) + (error "set!: expects (set! name expr)")) + ((not (string? (first args))) + (error "set!: name must be a symbol")) + (:else + (let ((name (first args)) + (val (scheme-eval (nth args 1) env))) + (let ((src (refl-env-find-frame env name))) + (cond + ((nil? src) + (error (str "set!: unbound variable: " name))) + (:else + (dict-set! (get src :bindings) name val) + val)))))))) + +;; define — top-level or internal binding. (define name expr) or +;; (define (name . formals) body...) the latter being lambda sugar. +(scheme-define-op! "define" + (fn (args env) + (cond + ((< (length args) 2) + (error "define: expects (define name expr) or (define (name . formals) body)")) + ((string? (first args)) + ;; (define name expr) + (let ((val (scheme-eval (nth args 1) env))) + (scheme-env-bind! env (first args) val) + val)) + ((list? (first args)) + ;; (define (name . formals) body...) — sugar + (let ((header (first args)) + (body (rest args))) + (cond + ((= (length header) 0) + (error "define: malformed function header")) + (:else + (let ((name (first header)) + (formals (rest header))) + (let ((closure (scheme-make-closure formals nil body env))) + (scheme-env-bind! env name closure) + closure)))))) + (:else (error "define: malformed form"))))) + +;; begin — evaluate each expression in sequence, return the last. +(scheme-define-op! "begin" + (fn (args env) + (cond + ((or (nil? args) (= (length args) 0)) nil) + (:else (scheme-eval-body args env))))) + +(define scheme-eval-body + (fn (forms env) + (cond + ((= (length forms) 1) (scheme-eval (first forms) env)) + (:else + (begin + (scheme-eval (first forms) env) + (scheme-eval-body (rest forms) env)))))) + +;; lambda — (lambda formals body...) where formals is one of: +;; () — no args +;; (a b c) — fixed-arity +;; name — bare symbol; binds all args as a list +;; Dotted-pair tail (a b . rest) deferred until parser support lands. +(scheme-define-op! "lambda" + (fn (args env) + (cond + ((< (length args) 2) + (error "lambda: expects (lambda formals body...)")) + (:else + (let ((formals (first args)) + (body (rest args))) + (cond + ;; bare symbol: collect-all-args + ((string? formals) + (scheme-make-closure (list) formals body env)) + ;; flat list: each must be a symbol + ((list? formals) + (cond + ((not (scm-formals-ok? formals)) + (error "lambda: formals must be symbols")) + (:else + (scheme-make-closure formals nil body env)))) + (:else (error "lambda: invalid formals")))))))) + +(define scm-formals-ok? + (fn (formals) + (cond + ((or (nil? formals) (= (length formals) 0)) true) + ((string? (first formals)) (scm-formals-ok? (rest formals))) + (:else false)))) + +(define scheme-make-closure + (fn (params rest-name body env) + {:scm-tag :closure + :params params + :rest rest-name + :body body + :env env})) + ;; ── eval-args helper ───────────────────────────────────────────── (define @@ -131,10 +251,35 @@ (scheme-apply-closure proc args)) (:else (error (str "scheme-eval: not a procedure: " proc)))))) -;; Stub for Phase 3 — closures land then. -(define - scheme-apply-closure - (fn (proc args) (error "scheme-eval: closures land in Phase 3"))) +;; Apply a Scheme closure: bind formals + rest, eval body in +;; (extend static-env), return value of last form. +(define scheme-apply-closure + (fn (proc args) + (let ((local (scheme-extend-env (get proc :env))) + (params (get proc :params)) + (rest-name (get proc :rest)) + (body (get proc :body))) + (begin + (scm-bind-params! local params args rest-name) + (scheme-eval-body body local))))) + +(define scm-bind-params! + (fn (env params args rest-name) + (cond + ;; No more formals: maybe bind the rest, else check arity. + ((or (nil? params) (= (length params) 0)) + (cond + ((not (nil? rest-name)) + (scheme-env-bind! env rest-name args)) + ((or (nil? args) (= (length args) 0)) nil) + (:else (error "lambda: too many arguments")))) + ;; Out of args but still have formals → arity error. + ((or (nil? args) (= (length args) 0)) + (error "lambda: too few arguments")) + (:else + (begin + (scheme-env-bind! env (first params) (first args)) + (scm-bind-params! env (rest params) (rest args) rest-name)))))) ;; Evaluate a program (sequence of forms), returning the last value. (define diff --git a/lib/scheme/tests/syntax.sx b/lib/scheme/tests/syntax.sx new file mode 100644 index 00000000..3c552bcb --- /dev/null +++ b/lib/scheme/tests/syntax.sx @@ -0,0 +1,237 @@ +;; lib/scheme/tests/syntax.sx — exercises Phase 3 syntactic operators. + +(define scm-syn-pass 0) +(define scm-syn-fail 0) +(define scm-syn-fails (list)) + +(define + scm-syn-test + (fn + (name actual expected) + (if + (= actual expected) + (set! scm-syn-pass (+ scm-syn-pass 1)) + (begin + (set! scm-syn-fail (+ scm-syn-fail 1)) + (append! scm-syn-fails {:name name :actual actual :expected expected}))))) + +(define scm-syn-eval (fn (src env) (scheme-eval (scheme-parse src) env))) + +(define + scm-syn-eval-all + (fn (src env) (scheme-eval-program (scheme-parse-all src) env))) + +;; Test env with arithmetic primitives. +(define + scm-syn-env + (fn + () + (let + ((env (scheme-make-env))) + (scheme-env-bind! + env + "+" + (fn (args) (+ (first args) (nth args 1)))) + (scheme-env-bind! + env + "-" + (fn (args) (- (first args) (nth args 1)))) + (scheme-env-bind! + env + "*" + (fn (args) (* (first args) (nth args 1)))) + (scheme-env-bind! + env + "/" + (fn (args) (/ (first args) (nth args 1)))) + (scheme-env-bind! + env + "<=" + (fn (args) (<= (first args) (nth args 1)))) + (scheme-env-bind! + env + "<" + (fn (args) (< (first args) (nth args 1)))) + (scheme-env-bind! + env + "=" + (fn (args) (= (first args) (nth args 1)))) + (scheme-env-bind! env "list" (fn (args) args)) + (scheme-env-bind! + env + "cons" + (fn (args) (cons (first args) (nth args 1)))) + (scheme-env-bind! env "car" (fn (args) (first (first args)))) + (scheme-env-bind! env "cdr" (fn (args) (rest (first args)))) + env))) + +;; ── if ─────────────────────────────────────────────────────────── +(scm-syn-test + "if: true" + (scm-syn-eval "(if #t 1 2)" (scm-syn-env)) + 1) +(scm-syn-test + "if: false" + (scm-syn-eval "(if #f 1 2)" (scm-syn-env)) + 2) +(scm-syn-test + "if: predicate" + (scm-syn-eval "(if (<= 1 2) 99 nope)" (scm-syn-env)) + 99) +(scm-syn-test + "if: no else returns nil" + (scm-syn-eval "(if #f 99)" (scm-syn-env)) + nil) +(scm-syn-test + "if: truthy non-#f" + (scm-syn-eval "(if 0 'yes 'no)" (scm-syn-env)) + "yes") + +;; ── define ─────────────────────────────────────────────────────── +(scm-syn-test + "define: bind value" + (let + ((env (scm-syn-env))) + (scm-syn-eval "(define x 42)" env) + (scm-syn-eval "x" env)) + 42) +(scm-syn-test + "define: function sugar" + (let + ((env (scm-syn-env))) + (scm-syn-eval-all "(define (double n) (+ n n)) (double 21)" env)) + 42) +(scm-syn-test + "define: redefine" + (let + ((env (scm-syn-env))) + (scm-syn-eval-all "(define x 1) (define x 2) x" env)) + 2) + +;; ── set! ───────────────────────────────────────────────────────── +(scm-syn-test + "set!: mutate" + (let + ((env (scm-syn-env))) + (scm-syn-eval-all "(define x 1) (set! x 99) x" env)) + 99) +(scm-syn-test + "set!: walks parent" + (let + ((env (scm-syn-env))) + (scm-syn-eval-all "(define x 1) ((lambda () (set! x 100))) x" env)) + 100) +(scm-syn-test + "set!: errors on unbound" + (guard + (e (true :raised)) + (scm-syn-eval-all "(set! never-defined 1)" (scm-syn-env))) + :raised) + +;; ── begin ──────────────────────────────────────────────────────── +(scm-syn-test + "begin: empty returns nil" + (scm-syn-eval "(begin)" (scm-syn-env)) + nil) +(scm-syn-test + "begin: returns last" + (scm-syn-eval "(begin 1 2 3)" (scm-syn-env)) + 3) +(scm-syn-test + "begin: side effects in order" + (let + ((env (scm-syn-env))) + (scm-syn-eval-all + "(define x 0) (begin (set! x 1) (set! x 2) (set! x 3)) x" + env)) + 3) + +;; ── lambda ─────────────────────────────────────────────────────── +(scm-syn-test + "lambda: identity" + (scm-syn-eval "((lambda (x) x) 42)" (scm-syn-env)) + 42) +(scm-syn-test + "lambda: arithmetic" + (scm-syn-eval "((lambda (x y) (+ x y)) 3 4)" (scm-syn-env)) + 7) +(scm-syn-test + "lambda: zero args" + (scm-syn-eval "((lambda () 99))" (scm-syn-env)) + 99) +(scm-syn-test + "lambda: multi-body" + (scm-syn-eval "((lambda (x) (define t (+ x 1)) (+ t t)) 5)" (scm-syn-env)) + 12) +(scm-syn-test + "lambda: rest-arg as bare symbol" + (scm-syn-eval "((lambda args args) 1 2 3)" (scm-syn-env)) + (list 1 2 3)) + +;; ── closures ───────────────────────────────────────────────────── +(scm-syn-test + "closure: captures binding" + (let + ((env (scm-syn-env))) + (scm-syn-eval-all + "(define (make-adder n) (lambda (x) (+ x n))) ((make-adder 10) 5)" + env)) + 15) +(scm-syn-test + "closure: counter via set!" + (let + ((env (scm-syn-env))) + (scm-syn-eval-all + "(define (make-counter) (define n 0) (lambda () (set! n (+ n 1)) n)) (define c (make-counter)) (c) (c) (c)" + env)) + 3) +(scm-syn-test + "closure: curried" + (let + ((env (scm-syn-env))) + (scm-syn-eval-all + "(define curry+ (lambda (a) (lambda (b) (lambda (c) (+ a (+ b c)))))) (((curry+ 1) 2) 3)" + env)) + 6) + +;; ── recursion ──────────────────────────────────────────────────── +(scm-syn-test + "recursive: factorial 5" + (let + ((env (scm-syn-env))) + (scm-syn-eval-all + "(define (fact n) (if (<= n 1) 1 (* n (fact (- n 1))))) (fact 5)" + env)) + 120) +(scm-syn-test + "recursive: factorial 10" + (let + ((env (scm-syn-env))) + (scm-syn-eval-all + "(define (fact n) (if (<= n 1) 1 (* n (fact (- n 1))))) (fact 10)" + env)) + 3628800) +(scm-syn-test + "recursive: list length" + (let + ((env (scm-syn-env))) + (scm-syn-eval-all + "(define (len xs) (if (= 0 (- 0 0)) (if (= xs (quote ())) 0 (+ 1 (len (cdr xs)))) 0)) (len '(a b c d))" + env)) + 4) + +;; ── quote vs eval distinction ──────────────────────────────────── +(scm-syn-test + "quote: list literal" + (scm-syn-eval "'(1 2 3)" (scm-syn-env)) + (list 1 2 3)) +(scm-syn-test + "quote: nested" + (scm-syn-eval "'(a (b c) d)" (scm-syn-env)) + (list "a" (list "b" "c") "d")) +(scm-syn-test + "quote: symbol vs evaluated" + (let ((env (scm-syn-env))) (scm-syn-eval-all "(define x 42) 'x" env)) + "x") + +(define scm-syn-tests-run! (fn () {:total (+ scm-syn-pass scm-syn-fail) :passed scm-syn-pass :failed scm-syn-fail :fails scm-syn-fails}))