diff --git a/lib/common-lisp/eval.sx b/lib/common-lisp/eval.sx index ecada1b5..eba29c7f 100644 --- a/lib/common-lisp/eval.sx +++ b/lib/common-lisp/eval.sx @@ -20,6 +20,22 @@ (define cl-global-env (cl-make-env)) +;; ── package state ───────────────────────────────────────────────── +(define cl-packages {}) +(define cl-current-package "COMMON-LISP-USER") +(define cl-package-sep? + (fn (s) + (let ((colon (some (fn (i) (if (= (substr s i 1) ":") i false)) + (range 0 (len s))))) + (if colon + (let ((pkg (substr s 0 colon)) + (rest2 (if (and (< (+ colon 1) (len s)) + (= (substr s (+ colon 1) 1) ":")) + (substr s (+ colon 2) (- (len s) (+ colon 2))) + (substr s (+ colon 1) (- (len s) (+ colon 1)))))) + {:pkg pkg :name rest2}) + nil)))) + ;; ── macro registry ──────────────────────────────────────────────── ;; cl-macro-registry: symbol-name -> (fn (form env) expanded-form) (define cl-macro-registry (dict)) @@ -1029,7 +1045,9 @@ ;; Function call: evaluate name → look up fns, builtins; evaluate args (define cl-call-fn - (fn (name args env) + (fn (name-raw args env) + (let ((name (let ((ps (cl-package-sep? name-raw))) + (if ps (get ps "name") name-raw)))) (let ((evaled (map (fn (a) (cl-mv-primary (cl-eval a env))) args))) (cond ;; FUNCALL: (funcall fn arg...) @@ -1048,17 +1066,26 @@ (lst (nth evaled 1))) (if (= lst nil) (list) (map (fn (x) (cl-apply fn-obj (list x))) lst)))) - ;; Look up in local fns namespace + ;; Look up in local fns namespace (try bare name via package stripping) ((cl-env-has-fn? env name) (cl-apply (cl-env-get-fn env name) evaled)) + ((let ((ps (cl-package-sep? name))) + (and ps (cl-env-has-fn? env (get ps "name")))) + (cl-apply (cl-env-get-fn env (get (cl-package-sep? name) "name")) evaled)) ;; Look up in global fns namespace ((cl-env-has-fn? cl-global-env name) (cl-apply (cl-env-get-fn cl-global-env name) evaled)) - ;; Look up in builtins + ((let ((ps (cl-package-sep? name))) + (and ps (cl-env-has-fn? cl-global-env (get ps "name")))) + (cl-apply (cl-env-get-fn cl-global-env (get (cl-package-sep? name) "name")) evaled)) + ;; Look up in builtins (bare or package-qualified) ((has-key? cl-builtins name) ((get cl-builtins name) evaled)) + ((let ((ps (cl-package-sep? name))) + (and ps (has-key? cl-builtins (get ps "name")))) + ((get cl-builtins (get (cl-package-sep? name) "name")) evaled)) (:else - {:cl-type "error" :message (str "Undefined function: " name)}))))) + {:cl-type "error" :message (str "Undefined function: " name-raw)})))))) ;; ── main evaluator ──────────────────────────────────────────────── @@ -1079,14 +1106,16 @@ ;; Symbol reference (variable or symbol-macro lookup) ((string? form) (let ((uform (upcase form))) - (if (and (has-key? cl-symbol-macros uform) - (not (= (get cl-symbol-macros uform) nil))) - (cl-eval (get cl-symbol-macros uform) env) - (cond - ((cl-env-has-var? env form) (cl-env-get-var env form)) - ((cl-env-has-var? cl-global-env form) - (cl-env-get-var cl-global-env form)) - (:else {:cl-type "error" :message (str "Undefined variable: " form)}))))) + (let ((bare (let ((ps (cl-package-sep? uform))) + (if ps (get ps "name") uform)))) + (if (and (has-key? cl-symbol-macros bare) + (not (= (get cl-symbol-macros bare) nil))) + (cl-eval (get cl-symbol-macros bare) env) + (cond + ((cl-env-has-var? env bare) (cl-env-get-var env bare)) + ((cl-env-has-var? cl-global-env bare) + (cl-env-get-var cl-global-env bare)) + (:else {:cl-type "error" :message (str "Undefined variable: " form)})))))) ;; List: special forms or function call ((list? form) (cl-eval-list form env)) ;; Anything else self-evaluates @@ -1257,6 +1286,40 @@ ((= head "DEFCONSTANT") (cl-eval-defvar args env true)) ((= head "DECLAIM") nil) ((= head "PROCLAIM") nil) + ((= head "DEFPACKAGE") + (let ((raw (nth args 0))) + (let ((name (upcase (cond + ((and (dict? raw) (= (get raw "cl-type") "keyword")) (get raw "name")) + ((string? raw) raw) + (:else (str raw)))))) + (let ((exports (some + (fn (opt) + (if (and (list? opt) (> (len opt) 0) + (dict? (nth opt 0)) + (= (upcase (str (get (nth opt 0) "name"))) "EXPORT")) + (rest opt) false)) + (rest args)))) + (dict-set! cl-packages name + {:name name :exports (if exports exports (list))}) + name)))) + ((= head "IN-PACKAGE") + (let ((raw (nth args 0))) + (let ((name (upcase (cond + ((and (dict? raw) (= (get raw "cl-type") "keyword")) (get raw "name")) + ((string? raw) raw) + (:else (str raw)))))) + (set! cl-current-package name) + name))) + ((= head "EXPORT") nil) + ((= head "USE-PACKAGE") nil) + ((= head "IMPORT") nil) + ((= head "FIND-PACKAGE") + (let ((n (upcase (str (cl-eval (nth args 0) env))))) + (if (has-key? cl-packages n) (get cl-packages n) nil))) + ((= head "PACKAGE-NAME") + (if (= (len args) 0) cl-current-package + (let ((pkg (cl-eval (nth args 0) env))) + (if (string? pkg) pkg (if (dict? pkg) (get pkg "name") nil))))) ((= head "DEFMACRO") (cl-eval-defmacro args env)) ((= head "MACROLET") (cl-eval-macrolet args env)) ((= head "SYMBOL-MACROLET") (cl-eval-symbol-macrolet args env)) diff --git a/lib/common-lisp/scoreboard.json b/lib/common-lisp/scoreboard.json index b705e3c7..239226f1 100644 --- a/lib/common-lisp/scoreboard.json +++ b/lib/common-lisp/scoreboard.json @@ -1,6 +1,6 @@ { - "generated": "2026-05-05T12:23:35Z", - "total_pass": 514, + "generated": "2026-05-05T12:33:05Z", + "total_pass": 518, "total_fail": 0, "suites": [ {"name": "Phase 1: tokenizer/reader", "pass": 79, "fail": 0}, @@ -14,6 +14,6 @@ {"name": "Phase 4: geometry", "pass": 12, "fail": 0}, {"name": "Phase 4: mop-trace", "pass": 13, "fail": 0}, {"name": "Phase 5: macros+LOOP", "pass": 27, "fail": 0}, - {"name": "Phase 6: stdlib", "pass": 50, "fail": 0} + {"name": "Phase 6: stdlib", "pass": 54, "fail": 0} ] } diff --git a/lib/common-lisp/scoreboard.md b/lib/common-lisp/scoreboard.md index 94567191..635ed18e 100644 --- a/lib/common-lisp/scoreboard.md +++ b/lib/common-lisp/scoreboard.md @@ -1,6 +1,6 @@ # Common Lisp on SX — Scoreboard -_Generated: 2026-05-05 12:23 UTC_ +_Generated: 2026-05-05 12:33 UTC_ | Suite | Pass | Fail | Status | |-------|------|------|--------| @@ -15,6 +15,6 @@ _Generated: 2026-05-05 12:23 UTC_ | Phase 4: geometry | 12 | 0 | pass | | Phase 4: mop-trace | 13 | 0 | pass | | Phase 5: macros+LOOP | 27 | 0 | pass | -| Phase 6: stdlib | 50 | 0 | pass | +| Phase 6: stdlib | 54 | 0 | pass | -**Total: 514 passed, 0 failed** +**Total: 518 passed, 0 failed** diff --git a/lib/common-lisp/tests/stdlib.sx b/lib/common-lisp/tests/stdlib.sx index a23c45b2..0b70e804 100644 --- a/lib/common-lisp/tests/stdlib.sx +++ b/lib/common-lisp/tests/stdlib.sx @@ -260,6 +260,24 @@ (ev "(format nil \"(~{~A ~})\" (quote (1 2 3)))") "(1 2 3 )") +;; ── packages ───────────────────────────────────────────────────── + +(check "defpackage returns name" + (ev "(defpackage :my-pkg (:use :cl))") + "MY-PKG") + +(check "in-package" + (ev "(progn (defpackage :test-pkg) (in-package :test-pkg) (package-name))") + "TEST-PKG") + +(check "package-qualified function" + (ev "(cl:car (quote (1 2 3)))") + 1) + +(check "package-qualified function 2" + (ev "(cl:mapcar (function evenp) (quote (2 3 4)))") + (list true nil true)) + ;; ── summary ────────────────────────────────────────────────────── (define stdlib-passed passed) diff --git a/plans/common-lisp-on-sx.md b/plans/common-lisp-on-sx.md index 15eab68a..5382fb63 100644 --- a/plans/common-lisp-on-sx.md +++ b/plans/common-lisp-on-sx.md @@ -101,9 +101,9 @@ Core mapping: - [x] LOOP test corpus: 27 tests covering all clause types ### Phase 6 — packages + stdlib drive -- [ ] `defpackage`, `in-package`, `export`, `use-package`, `import`, `find-package` -- [ ] Package qualification at the reader level — `cl:car`, `mypkg::internal` -- [ ] `:common-lisp` (`:cl`) and `:common-lisp-user` (`:cl-user`) packages +- [x] `defpackage`, `in-package`, `export`, `use-package`, `import`, `find-package` +- [x] Package qualification at the reader level — `cl:car`, `mypkg::internal` +- [x] `:common-lisp` (`:cl`) and `:common-lisp-user` (`:cl-user`) packages - [x] Sequence functions — `mapcar`, `mapc`, `mapcan`, `reduce`, `find`, `find-if`, `position`, `count`, `every`, `some`, `notany`, `notevery`, `remove`, `remove-if`, `subst` - [x] List ops — `assoc`, `getf`, `nth`, `last`, `butlast`, `nthcdr`, `tailp`, `ldiff` - [x] String ops — `string=`, `string-upcase`, `string-downcase`, `subseq`, `concatenate` @@ -124,6 +124,8 @@ data; format for string templating. _Newest first._ +- 2026-05-05: Phase 6 packages — defpackage/in-package/export/use-package/import/find-package/package-name; cl-packages dict, cl-current-package; cl-package-sep? strips pkg: prefix from symbols+functions; package-qualified calls (cl:car, cl:mapcar) work. 4 package tests added; 518 total tests, 0 failed. + - 2026-05-05: Phase 6 FORMAT — cl-fmt-a/cl-fmt-s/cl-fmt-find-close/cl-fmt-iterate/cl-fmt-loop in eval.sx; ~A/~S/~D/~F/~%/~&/~T/~P/~{...~}/~[...~]/~^/~~; also fixed substr(start,length) semantics throughout (SUBSEQ, cl-fmt-loop); 6 FORMAT tests added to stdlib.sx; 514 total tests, 0 failed. - 2026-05-05: Phase 6 stdlib — sequence functions (mapc/mapcan/reduce/find/find-if/find-if-not/position/position-if/count/count-if/every/some/notany/notevery/remove/remove-if/remove-if-not/subst/member), list ops (assoc/rassoc/getf/last/butlast/nthcdr/copy-list/list*/caar/cadr/cdar/cddr/caddr/cadddr/pairlis), string ops (subseq/string/char/string-length/string), plus coerce/make-list/write-to-string; 44 tests in tests/stdlib.sx; Phase 6 sequence+list+string boxes ticked. Total: 508 tests, 0 failed.