Compare commits
5 Commits
loops/erla
...
loops/smal
| Author | SHA1 | Date | |
|---|---|---|---|
| 52523606a8 | |||
| e71154f9c6 | |||
| 33ce994f23 | |||
| 4e7d2183ad | |||
| 6a00df2609 |
891
lib/smalltalk/parser.sx
Normal file
891
lib/smalltalk/parser.sx
Normal file
@@ -0,0 +1,891 @@
|
||||
;; Smalltalk parser — produces an AST from the tokenizer's token stream.
|
||||
;;
|
||||
;; AST node shapes (dicts):
|
||||
;; {:type "lit-int" :value N} integer
|
||||
;; {:type "lit-float" :value F} float
|
||||
;; {:type "lit-string" :value S} string
|
||||
;; {:type "lit-char" :value C} character
|
||||
;; {:type "lit-symbol" :value S} symbol literal (#foo)
|
||||
;; {:type "lit-array" :elements (list ...)} literal array (#(1 2 #foo))
|
||||
;; {:type "lit-byte-array" :elements (...)} byte array (#[1 2 3])
|
||||
;; {:type "lit-nil" } / "lit-true" / "lit-false"
|
||||
;; {:type "ident" :name "x"} variable reference
|
||||
;; {:type "self"} / "super" / "thisContext" pseudo-variables
|
||||
;; {:type "assign" :name "x" :expr E} x := E
|
||||
;; {:type "return" :expr E} ^ E
|
||||
;; {:type "send" :receiver R :selector S :args (list ...)}
|
||||
;; {:type "cascade" :receiver R :messages (list {:selector :args} ...)}
|
||||
;; {:type "block" :params (list "a") :temps (list "t") :body (list expr)}
|
||||
;; {:type "seq" :exprs (list ...)} statement sequence
|
||||
;; {:type "method" :selector S :params (list ...) :temps (list ...) :body (list ...) :pragmas (list ...)}
|
||||
;;
|
||||
;; A "chunk" / class-definition stream is parsed at a higher level (deferred).
|
||||
|
||||
;; ── Chunk-stream reader ────────────────────────────────────────────────
|
||||
;; Pharo chunk format: chunks are separated by `!`. A doubled `!!` inside a
|
||||
;; chunk represents a single literal `!`. Returns list of chunk strings with
|
||||
;; surrounding whitespace trimmed.
|
||||
(define
|
||||
st-read-chunks
|
||||
(fn
|
||||
(src)
|
||||
(let
|
||||
((chunks (list))
|
||||
(buf (list))
|
||||
(pos 0)
|
||||
(n (len src)))
|
||||
(begin
|
||||
(define
|
||||
flush!
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((s (st-trim (join "" buf))))
|
||||
(begin (append! chunks s) (set! buf (list))))))
|
||||
(define
|
||||
rc-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(< pos n)
|
||||
(let
|
||||
((c (nth src pos)))
|
||||
(cond
|
||||
((= c "!")
|
||||
(cond
|
||||
((and (< (+ pos 1) n) (= (nth src (+ pos 1)) "!"))
|
||||
(begin (append! buf "!") (set! pos (+ pos 2)) (rc-loop)))
|
||||
(else
|
||||
(begin (flush!) (set! pos (+ pos 1)) (rc-loop)))))
|
||||
(else
|
||||
(begin (append! buf c) (set! pos (+ pos 1)) (rc-loop))))))))
|
||||
(rc-loop)
|
||||
;; trailing text without a closing `!` — preserve as a chunk
|
||||
(when (> (len buf) 0) (flush!))
|
||||
chunks))))
|
||||
|
||||
(define
|
||||
st-trim
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((n (len s)) (i 0) (j 0))
|
||||
(begin
|
||||
(set! j n)
|
||||
(define
|
||||
tl-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (< i n) (st-trim-ws? (nth s i)))
|
||||
(begin (set! i (+ i 1)) (tl-loop)))))
|
||||
(tl-loop)
|
||||
(define
|
||||
tr-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (> j i) (st-trim-ws? (nth s (- j 1))))
|
||||
(begin (set! j (- j 1)) (tr-loop)))))
|
||||
(tr-loop)
|
||||
(slice s i j)))))
|
||||
|
||||
(define
|
||||
st-trim-ws?
|
||||
(fn (c) (or (= c " ") (= c "\t") (= c "\n") (= c "\r"))))
|
||||
|
||||
;; Parse a chunk stream. Walks chunks and applies the Pharo file-in
|
||||
;; convention: a chunk that evaluates to "X methodsFor: 'cat'" or
|
||||
;; "X class methodsFor: 'cat'" enters a methods batch — subsequent chunks
|
||||
;; are method source until an empty chunk closes the batch.
|
||||
;;
|
||||
;; Returns list of entries:
|
||||
;; {:kind "expr" :ast EXPR-AST}
|
||||
;; {:kind "method" :class CLS :class-side? BOOL :category CAT :ast METHOD-AST}
|
||||
;; {:kind "blank"} (empty chunks outside a methods batch)
|
||||
;; {:kind "end-methods"} (empty chunk closing a methods batch)
|
||||
(define
|
||||
st-parse-chunks
|
||||
(fn
|
||||
(src)
|
||||
(let
|
||||
((chunks (st-read-chunks src))
|
||||
(entries (list))
|
||||
(mode "do-it")
|
||||
(cls-name nil)
|
||||
(class-side? false)
|
||||
(category nil))
|
||||
(begin
|
||||
(for-each
|
||||
(fn
|
||||
(chunk)
|
||||
(cond
|
||||
((= chunk "")
|
||||
(cond
|
||||
((= mode "methods")
|
||||
(begin
|
||||
(append! entries {:kind "end-methods"})
|
||||
(set! mode "do-it")
|
||||
(set! cls-name nil)
|
||||
(set! class-side? false)
|
||||
(set! category nil)))
|
||||
(else (append! entries {:kind "blank"}))))
|
||||
((= mode "methods")
|
||||
(append!
|
||||
entries
|
||||
{:kind "method"
|
||||
:class cls-name
|
||||
:class-side? class-side?
|
||||
:category category
|
||||
:ast (st-parse-method chunk)}))
|
||||
(else
|
||||
(let
|
||||
((ast (st-parse-expr chunk)))
|
||||
(begin
|
||||
(append! entries {:kind "expr" :ast ast})
|
||||
(let
|
||||
((mf (st-detect-methods-for ast)))
|
||||
(when
|
||||
(not (= mf nil))
|
||||
(begin
|
||||
(set! mode "methods")
|
||||
(set! cls-name (get mf :class))
|
||||
(set! class-side? (get mf :class-side?))
|
||||
(set! category (get mf :category))))))))))
|
||||
chunks)
|
||||
entries))))
|
||||
|
||||
;; Recognise `Foo methodsFor: 'cat'` (and related) as starting a methods batch.
|
||||
;; Returns nil if the AST doesn't look like one of these forms.
|
||||
(define
|
||||
st-detect-methods-for
|
||||
(fn
|
||||
(ast)
|
||||
(cond
|
||||
((not (= (get ast :type) "send")) nil)
|
||||
((not (st-is-methods-for-selector? (get ast :selector))) nil)
|
||||
(else
|
||||
(let
|
||||
((recv (get ast :receiver)) (args (get ast :args)))
|
||||
(let
|
||||
((cat-arg (if (> (len args) 0) (nth args 0) nil)))
|
||||
(let
|
||||
((category
|
||||
(cond
|
||||
((= cat-arg nil) nil)
|
||||
((= (get cat-arg :type) "lit-string") (get cat-arg :value))
|
||||
((= (get cat-arg :type) "lit-symbol") (get cat-arg :value))
|
||||
(else nil))))
|
||||
(cond
|
||||
((= (get recv :type) "ident")
|
||||
{:class (get recv :name)
|
||||
:class-side? false
|
||||
:category category})
|
||||
;; `Foo class methodsFor: 'cat'` — recv is a unary send `Foo class`
|
||||
((and
|
||||
(= (get recv :type) "send")
|
||||
(= (get recv :selector) "class")
|
||||
(= (get (get recv :receiver) :type) "ident"))
|
||||
{:class (get (get recv :receiver) :name)
|
||||
:class-side? true
|
||||
:category category})
|
||||
(else nil)))))))))
|
||||
|
||||
(define
|
||||
st-is-methods-for-selector?
|
||||
(fn
|
||||
(sel)
|
||||
(or
|
||||
(= sel "methodsFor:")
|
||||
(= sel "methodsFor:stamp:")
|
||||
(= sel "category:"))))
|
||||
|
||||
(define st-tok-type (fn (t) (if (= t nil) "eof" (get t :type))))
|
||||
|
||||
(define st-tok-value (fn (t) (if (= t nil) nil (get t :value))))
|
||||
|
||||
;; Parse a *single* Smalltalk expression from source.
|
||||
(define st-parse-expr (fn (src) (st-parse-with src "expr")))
|
||||
|
||||
;; Parse a sequence of statements separated by '.' Returns a {:type "seq"} node.
|
||||
(define st-parse (fn (src) (st-parse-with src "seq")))
|
||||
|
||||
;; Parse a method body — `selector params | temps | body`.
|
||||
;; Only the "method header + body" form (no chunk delimiters).
|
||||
(define st-parse-method (fn (src) (st-parse-with src "method")))
|
||||
|
||||
(define
|
||||
st-parse-with
|
||||
(fn
|
||||
(src mode)
|
||||
(let
|
||||
((tokens (st-tokenize src)) (idx 0) (tok-len 0))
|
||||
(begin
|
||||
(set! tok-len (len tokens))
|
||||
(define peek-tok (fn () (nth tokens idx)))
|
||||
(define
|
||||
peek-tok-at
|
||||
(fn (n) (if (< (+ idx n) tok-len) (nth tokens (+ idx n)) nil)))
|
||||
(define advance-tok! (fn () (set! idx (+ idx 1))))
|
||||
(define
|
||||
at?
|
||||
(fn
|
||||
(type value)
|
||||
(let
|
||||
((t (peek-tok)))
|
||||
(and
|
||||
(= (st-tok-type t) type)
|
||||
(or (= value nil) (= (st-tok-value t) value))))))
|
||||
(define at-type? (fn (type) (= (st-tok-type (peek-tok)) type)))
|
||||
(define
|
||||
consume!
|
||||
(fn
|
||||
(type value)
|
||||
(if
|
||||
(at? type value)
|
||||
(let ((t (peek-tok))) (begin (advance-tok!) t))
|
||||
(error
|
||||
(str
|
||||
"st-parse: expected "
|
||||
type
|
||||
(if (= value nil) "" (str " '" value "'"))
|
||||
" got "
|
||||
(st-tok-type (peek-tok))
|
||||
" '"
|
||||
(st-tok-value (peek-tok))
|
||||
"' at idx "
|
||||
idx)))))
|
||||
|
||||
;; ── Primary: atoms, paren'd expr, blocks, literal arrays, byte arrays.
|
||||
(define
|
||||
parse-primary
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((t (peek-tok)))
|
||||
(let
|
||||
((ty (st-tok-type t)) (v (st-tok-value t)))
|
||||
(cond
|
||||
((= ty "number")
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(cond
|
||||
((number? v) {:type (if (integer? v) "lit-int" "lit-float") :value v})
|
||||
(else {:type "lit-int" :value v}))))
|
||||
((= ty "string")
|
||||
(begin (advance-tok!) {:type "lit-string" :value v}))
|
||||
((= ty "char")
|
||||
(begin (advance-tok!) {:type "lit-char" :value v}))
|
||||
((= ty "symbol")
|
||||
(begin (advance-tok!) {:type "lit-symbol" :value v}))
|
||||
((= ty "array-open") (parse-literal-array))
|
||||
((= ty "byte-array-open") (parse-byte-array))
|
||||
((= ty "lparen")
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(let
|
||||
((e (parse-expression)))
|
||||
(begin (consume! "rparen" nil) e))))
|
||||
((= ty "lbracket") (parse-block))
|
||||
((= ty "ident")
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(cond
|
||||
((= v "nil") {:type "lit-nil"})
|
||||
((= v "true") {:type "lit-true"})
|
||||
((= v "false") {:type "lit-false"})
|
||||
((= v "self") {:type "self"})
|
||||
((= v "super") {:type "super"})
|
||||
((= v "thisContext") {:type "thisContext"})
|
||||
(else {:type "ident" :name v}))))
|
||||
((= ty "binary")
|
||||
;; Negative numeric literal: '-' immediately before a number.
|
||||
(cond
|
||||
((and (= v "-") (= (st-tok-type (peek-tok-at 1)) "number"))
|
||||
(let
|
||||
((n (st-tok-value (peek-tok-at 1))))
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(advance-tok!)
|
||||
(cond
|
||||
((dict? n) {:type "lit-int" :value n})
|
||||
((integer? n) {:type "lit-int" :value (- 0 n)})
|
||||
(else {:type "lit-float" :value (- 0 n)})))))
|
||||
(else
|
||||
(error
|
||||
(str "st-parse: unexpected binary '" v "' at idx " idx)))))
|
||||
(else
|
||||
(error
|
||||
(str
|
||||
"st-parse: unexpected "
|
||||
ty
|
||||
" '"
|
||||
v
|
||||
"' at idx "
|
||||
idx))))))))
|
||||
|
||||
;; #(elem elem ...) — elements are atoms or nested parenthesised arrays.
|
||||
(define
|
||||
parse-literal-array
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((items (list)))
|
||||
(begin
|
||||
(consume! "array-open" nil)
|
||||
(define
|
||||
arr-loop
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((at? "rparen" nil) (advance-tok!))
|
||||
(else
|
||||
(begin
|
||||
(append! items (parse-array-element))
|
||||
(arr-loop))))))
|
||||
(arr-loop)
|
||||
{:type "lit-array" :elements items}))))
|
||||
|
||||
;; #[1 2 3]
|
||||
(define
|
||||
parse-byte-array
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((items (list)))
|
||||
(begin
|
||||
(consume! "byte-array-open" nil)
|
||||
(define
|
||||
ba-loop
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((at? "rbracket" nil) (advance-tok!))
|
||||
(else
|
||||
(let
|
||||
((t (peek-tok)))
|
||||
(cond
|
||||
((= (st-tok-type t) "number")
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(append! items (st-tok-value t))
|
||||
(ba-loop)))
|
||||
(else
|
||||
(error
|
||||
(str
|
||||
"st-parse: byte array expects number, got "
|
||||
(st-tok-type t))))))))))
|
||||
(ba-loop)
|
||||
{:type "lit-byte-array" :elements items}))))
|
||||
|
||||
;; Inside a literal array: bare idents become symbols, nested (...) is a sub-array.
|
||||
(define
|
||||
parse-array-element
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((t (peek-tok)))
|
||||
(let
|
||||
((ty (st-tok-type t)) (v (st-tok-value t)))
|
||||
(cond
|
||||
((= ty "number") (begin (advance-tok!) {:type "lit-int" :value v}))
|
||||
((= ty "string") (begin (advance-tok!) {:type "lit-string" :value v}))
|
||||
((= ty "char") (begin (advance-tok!) {:type "lit-char" :value v}))
|
||||
((= ty "symbol") (begin (advance-tok!) {:type "lit-symbol" :value v}))
|
||||
((= ty "ident")
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(cond
|
||||
((= v "nil") {:type "lit-nil"})
|
||||
((= v "true") {:type "lit-true"})
|
||||
((= v "false") {:type "lit-false"})
|
||||
(else {:type "lit-symbol" :value v}))))
|
||||
((= ty "keyword") (begin (advance-tok!) {:type "lit-symbol" :value v}))
|
||||
((= ty "binary") (begin (advance-tok!) {:type "lit-symbol" :value v}))
|
||||
((= ty "lparen")
|
||||
(let ((items (list)))
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(define
|
||||
sub-loop
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((at? "rparen" nil) (advance-tok!))
|
||||
(else
|
||||
(begin (append! items (parse-array-element)) (sub-loop))))))
|
||||
(sub-loop)
|
||||
{:type "lit-array" :elements items})))
|
||||
((= ty "array-open") (parse-literal-array))
|
||||
((= ty "byte-array-open") (parse-byte-array))
|
||||
(else
|
||||
(error
|
||||
(str "st-parse: bad literal-array element " ty " '" v "'"))))))))
|
||||
|
||||
;; [:a :b | | t1 t2 | body. body. ...]
|
||||
(define
|
||||
parse-block
|
||||
(fn
|
||||
()
|
||||
(begin
|
||||
(consume! "lbracket" nil)
|
||||
(let
|
||||
((params (list)) (temps (list)))
|
||||
(begin
|
||||
;; Block params
|
||||
(define
|
||||
p-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(at? "colon" nil)
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(let
|
||||
((t (consume! "ident" nil)))
|
||||
(begin
|
||||
(append! params (st-tok-value t))
|
||||
(p-loop)))))))
|
||||
(p-loop)
|
||||
(when (> (len params) 0) (consume! "bar" nil))
|
||||
;; Block temps: | t1 t2 |
|
||||
(when
|
||||
(and
|
||||
(at? "bar" nil)
|
||||
;; Not `|` followed immediately by binary content — the only
|
||||
;; legitimate `|` inside a block here is the temp delimiter.
|
||||
true)
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(define
|
||||
t-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(at? "ident" nil)
|
||||
(let
|
||||
((t (peek-tok)))
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(append! temps (st-tok-value t))
|
||||
(t-loop))))))
|
||||
(t-loop)
|
||||
(consume! "bar" nil)))
|
||||
;; Body: statements terminated by `.` or `]`
|
||||
(let
|
||||
((body (parse-statements "rbracket")))
|
||||
(begin
|
||||
(consume! "rbracket" nil)
|
||||
{:type "block" :params params :temps temps :body body})))))))
|
||||
|
||||
;; Parse statements up to a closing token (rbracket or eof). Returns list.
|
||||
(define
|
||||
parse-statements
|
||||
(fn
|
||||
(terminator)
|
||||
(let
|
||||
((stmts (list)))
|
||||
(begin
|
||||
(define
|
||||
s-loop
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((at-type? terminator) nil)
|
||||
((at-type? "eof") nil)
|
||||
(else
|
||||
(begin
|
||||
(append! stmts (parse-statement))
|
||||
;; consume optional period(s)
|
||||
(define
|
||||
dot-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(at? "period" nil)
|
||||
(begin (advance-tok!) (dot-loop)))))
|
||||
(dot-loop)
|
||||
(s-loop))))))
|
||||
(s-loop)
|
||||
stmts))))
|
||||
|
||||
;; Statement: ^expr | ident := expr | expr
|
||||
(define
|
||||
parse-statement
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((at? "caret" nil)
|
||||
(begin
|
||||
(advance-tok!)
|
||||
{:type "return" :expr (parse-expression)}))
|
||||
((and (at-type? "ident") (= (st-tok-type (peek-tok-at 1)) "assign"))
|
||||
(let
|
||||
((name-tok (peek-tok)))
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(advance-tok!)
|
||||
{:type "assign"
|
||||
:name (st-tok-value name-tok)
|
||||
:expr (parse-expression)})))
|
||||
(else (parse-expression)))))
|
||||
|
||||
;; Top-level expression. Assignment (right-associative chain) sits at
|
||||
;; the top; cascade is below.
|
||||
(define
|
||||
parse-expression
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((and (at-type? "ident") (= (st-tok-type (peek-tok-at 1)) "assign"))
|
||||
(let
|
||||
((name-tok (peek-tok)))
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(advance-tok!)
|
||||
{:type "assign"
|
||||
:name (st-tok-value name-tok)
|
||||
:expr (parse-expression)})))
|
||||
(else (parse-cascade)))))
|
||||
|
||||
(define
|
||||
parse-cascade
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((head (parse-keyword-message)))
|
||||
(cond
|
||||
((at? "semi" nil)
|
||||
(let
|
||||
((receiver (cascade-receiver head))
|
||||
(first-msg (cascade-first-message head))
|
||||
(msgs (list)))
|
||||
(begin
|
||||
(append! msgs first-msg)
|
||||
(define
|
||||
c-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(at? "semi" nil)
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(append! msgs (parse-cascade-message))
|
||||
(c-loop)))))
|
||||
(c-loop)
|
||||
{:type "cascade" :receiver receiver :messages msgs})))
|
||||
(else head)))))
|
||||
|
||||
;; Extract the receiver from a head send so cascades share it.
|
||||
(define
|
||||
cascade-receiver
|
||||
(fn
|
||||
(head)
|
||||
(cond
|
||||
((= (get head :type) "send") (get head :receiver))
|
||||
(else head))))
|
||||
|
||||
(define
|
||||
cascade-first-message
|
||||
(fn
|
||||
(head)
|
||||
(cond
|
||||
((= (get head :type) "send")
|
||||
{:selector (get head :selector) :args (get head :args)})
|
||||
(else
|
||||
;; Shouldn't happen — cascade requires at least one prior message.
|
||||
(error "st-parse: cascade with no prior message")))))
|
||||
|
||||
;; Subsequent cascade message (after the `;`): unary | binary | keyword
|
||||
(define
|
||||
parse-cascade-message
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((at-type? "ident")
|
||||
(let ((t (peek-tok)))
|
||||
(begin
|
||||
(advance-tok!)
|
||||
{:selector (st-tok-value t) :args (list)})))
|
||||
((at-type? "binary")
|
||||
(let ((t (peek-tok)))
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(let
|
||||
((arg (parse-unary-message)))
|
||||
{:selector (st-tok-value t) :args (list arg)}))))
|
||||
((at-type? "keyword")
|
||||
(let
|
||||
((sel-parts (list)) (args (list)))
|
||||
(begin
|
||||
(define
|
||||
kw-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(at-type? "keyword")
|
||||
(let ((t (peek-tok)))
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(append! sel-parts (st-tok-value t))
|
||||
(append! args (parse-binary-message))
|
||||
(kw-loop))))))
|
||||
(kw-loop)
|
||||
{:selector (join "" sel-parts) :args args})))
|
||||
(else
|
||||
(error
|
||||
(str "st-parse: bad cascade message at idx " idx))))))
|
||||
|
||||
;; Keyword message: <binary> (kw <binary>)+
|
||||
(define
|
||||
parse-keyword-message
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((receiver (parse-binary-message)))
|
||||
(cond
|
||||
((at-type? "keyword")
|
||||
(let
|
||||
((sel-parts (list)) (args (list)))
|
||||
(begin
|
||||
(define
|
||||
kw-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(at-type? "keyword")
|
||||
(let ((t (peek-tok)))
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(append! sel-parts (st-tok-value t))
|
||||
(append! args (parse-binary-message))
|
||||
(kw-loop))))))
|
||||
(kw-loop)
|
||||
{:type "send"
|
||||
:receiver receiver
|
||||
:selector (join "" sel-parts)
|
||||
:args args})))
|
||||
(else receiver)))))
|
||||
|
||||
;; Binary message: <unary> (binop <unary>)*
|
||||
(define
|
||||
parse-binary-message
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((receiver (parse-unary-message)))
|
||||
(begin
|
||||
(define
|
||||
b-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(at-type? "binary")
|
||||
(let ((t (peek-tok)))
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(let
|
||||
((arg (parse-unary-message)))
|
||||
(set!
|
||||
receiver
|
||||
{:type "send"
|
||||
:receiver receiver
|
||||
:selector (st-tok-value t)
|
||||
:args (list arg)}))
|
||||
(b-loop))))))
|
||||
(b-loop)
|
||||
receiver))))
|
||||
|
||||
;; Unary message: <primary> ident* (ident NOT followed by ':')
|
||||
(define
|
||||
parse-unary-message
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((receiver (parse-primary)))
|
||||
(begin
|
||||
(define
|
||||
u-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and
|
||||
(at-type? "ident")
|
||||
(let
|
||||
((nxt (peek-tok-at 1)))
|
||||
(not (= (st-tok-type nxt) "assign"))))
|
||||
(let ((t (peek-tok)))
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(set!
|
||||
receiver
|
||||
{:type "send"
|
||||
:receiver receiver
|
||||
:selector (st-tok-value t)
|
||||
:args (list)})
|
||||
(u-loop))))))
|
||||
(u-loop)
|
||||
receiver))))
|
||||
|
||||
;; Parse a single pragma: `<keyword: literal (keyword: literal)* >`
|
||||
;; Returns {:selector "primitive:" :args (list literal-asts)}.
|
||||
(define
|
||||
parse-pragma
|
||||
(fn
|
||||
()
|
||||
(begin
|
||||
(consume! "binary" "<")
|
||||
(let
|
||||
((sel-parts (list)) (args (list)))
|
||||
(begin
|
||||
(define
|
||||
pr-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(at-type? "keyword")
|
||||
(let ((t (peek-tok)))
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(append! sel-parts (st-tok-value t))
|
||||
(append! args (parse-pragma-arg))
|
||||
(pr-loop))))))
|
||||
(pr-loop)
|
||||
(consume! "binary" ">")
|
||||
{:selector (join "" sel-parts) :args args})))))
|
||||
|
||||
;; Pragma arguments are literals only.
|
||||
(define
|
||||
parse-pragma-arg
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((t (peek-tok)))
|
||||
(let
|
||||
((ty (st-tok-type t)) (v (st-tok-value t)))
|
||||
(cond
|
||||
((= ty "number")
|
||||
(begin
|
||||
(advance-tok!)
|
||||
{:type (if (integer? v) "lit-int" "lit-float") :value v}))
|
||||
((= ty "string") (begin (advance-tok!) {:type "lit-string" :value v}))
|
||||
((= ty "char") (begin (advance-tok!) {:type "lit-char" :value v}))
|
||||
((= ty "symbol") (begin (advance-tok!) {:type "lit-symbol" :value v}))
|
||||
((= ty "ident")
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(cond
|
||||
((= v "nil") {:type "lit-nil"})
|
||||
((= v "true") {:type "lit-true"})
|
||||
((= v "false") {:type "lit-false"})
|
||||
(else (error (str "st-parse: pragma arg must be literal, got ident " v))))))
|
||||
((and (= ty "binary") (= v "-")
|
||||
(= (st-tok-type (peek-tok-at 1)) "number"))
|
||||
(let ((n (st-tok-value (peek-tok-at 1))))
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(advance-tok!)
|
||||
{:type (if (integer? n) "lit-int" "lit-float")
|
||||
:value (- 0 n)})))
|
||||
(else
|
||||
(error
|
||||
(str "st-parse: pragma arg must be literal, got " ty))))))))
|
||||
|
||||
;; Method header: unary | binary arg | (kw arg)+
|
||||
(define
|
||||
parse-method
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((sel "")
|
||||
(params (list))
|
||||
(temps (list))
|
||||
(pragmas (list))
|
||||
(body (list)))
|
||||
(begin
|
||||
(cond
|
||||
;; Unary header
|
||||
((at-type? "ident")
|
||||
(let ((t (peek-tok)))
|
||||
(begin (advance-tok!) (set! sel (st-tok-value t)))))
|
||||
;; Binary header: binop ident
|
||||
((at-type? "binary")
|
||||
(let ((t (peek-tok)))
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(set! sel (st-tok-value t))
|
||||
(let ((p (consume! "ident" nil)))
|
||||
(append! params (st-tok-value p))))))
|
||||
;; Keyword header: (kw ident)+
|
||||
((at-type? "keyword")
|
||||
(let ((sel-parts (list)))
|
||||
(begin
|
||||
(define
|
||||
kh-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(at-type? "keyword")
|
||||
(let ((t (peek-tok)))
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(append! sel-parts (st-tok-value t))
|
||||
(let ((p (consume! "ident" nil)))
|
||||
(append! params (st-tok-value p)))
|
||||
(kh-loop))))))
|
||||
(kh-loop)
|
||||
(set! sel (join "" sel-parts)))))
|
||||
(else
|
||||
(error
|
||||
(str
|
||||
"st-parse-method: expected selector header, got "
|
||||
(st-tok-type (peek-tok))))))
|
||||
;; Pragmas and temps may appear in either order. Allow many
|
||||
;; pragmas; one temps section.
|
||||
(define
|
||||
parse-temps!
|
||||
(fn
|
||||
()
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(define
|
||||
th-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(at-type? "ident")
|
||||
(let ((t (peek-tok)))
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(append! temps (st-tok-value t))
|
||||
(th-loop))))))
|
||||
(th-loop)
|
||||
(consume! "bar" nil))))
|
||||
(define
|
||||
pt-loop
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((and
|
||||
(at? "binary" "<")
|
||||
(= (st-tok-type (peek-tok-at 1)) "keyword"))
|
||||
(begin (append! pragmas (parse-pragma)) (pt-loop)))
|
||||
((and (at? "bar" nil) (= (len temps) 0))
|
||||
(begin (parse-temps!) (pt-loop)))
|
||||
(else nil))))
|
||||
(pt-loop)
|
||||
;; Body statements
|
||||
(set! body (parse-statements "eof"))
|
||||
{:type "method"
|
||||
:selector sel
|
||||
:params params
|
||||
:temps temps
|
||||
:pragmas pragmas
|
||||
:body body}))))
|
||||
|
||||
;; Top-level program: statements separated by '.'
|
||||
(cond
|
||||
((= mode "expr") (parse-expression))
|
||||
((= mode "method") (parse-method))
|
||||
(else
|
||||
{:type "seq" :exprs (parse-statements "eof")}))))))
|
||||
291
lib/smalltalk/runtime.sx
Normal file
291
lib/smalltalk/runtime.sx
Normal file
@@ -0,0 +1,291 @@
|
||||
;; Smalltalk runtime — class table, bootstrap hierarchy, type→class mapping,
|
||||
;; instance construction. Method dispatch / eval-ast live in a later layer.
|
||||
;;
|
||||
;; Class record shape:
|
||||
;; {:name "Foo"
|
||||
;; :superclass "Object" ; or nil for Object itself
|
||||
;; :ivars (list "x" "y") ; instance variable names declared on this class
|
||||
;; :methods (dict selector→method-record)
|
||||
;; :class-methods (dict selector→method-record)}
|
||||
;;
|
||||
;; A method record is the AST returned by st-parse-method, plus a :defining-class
|
||||
;; field so super-sends can resolve from the right place. (Methods are registered
|
||||
;; via runtime helpers that fill the field.)
|
||||
;;
|
||||
;; The class table is a single dict keyed by class name. Bootstrap installs the
|
||||
;; canonical hierarchy. Test code resets it via (st-bootstrap-classes!).
|
||||
|
||||
(define st-class-table {})
|
||||
|
||||
(define st-class-table-clear! (fn () (set! st-class-table {})))
|
||||
|
||||
(define
|
||||
st-class-define!
|
||||
(fn
|
||||
(name superclass ivars)
|
||||
(begin
|
||||
(set!
|
||||
st-class-table
|
||||
(assoc
|
||||
st-class-table
|
||||
name
|
||||
{:name name
|
||||
:superclass superclass
|
||||
:ivars ivars
|
||||
:methods {}
|
||||
:class-methods {}}))
|
||||
name)))
|
||||
|
||||
(define
|
||||
st-class-get
|
||||
(fn (name) (if (has-key? st-class-table name) (get st-class-table name) nil)))
|
||||
|
||||
(define
|
||||
st-class-exists?
|
||||
(fn (name) (has-key? st-class-table name)))
|
||||
|
||||
(define
|
||||
st-class-superclass
|
||||
(fn
|
||||
(name)
|
||||
(let
|
||||
((c (st-class-get name)))
|
||||
(cond ((= c nil) nil) (else (get c :superclass))))))
|
||||
|
||||
;; Walk class chain root-to-leaf? No, follow superclass chain leaf-to-root.
|
||||
;; Returns list of class names starting at `name` and ending with the root.
|
||||
(define
|
||||
st-class-chain
|
||||
(fn
|
||||
(name)
|
||||
(let ((acc (list)) (cur name))
|
||||
(begin
|
||||
(define
|
||||
ch-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (not (= cur nil)) (st-class-exists? cur))
|
||||
(begin
|
||||
(append! acc cur)
|
||||
(set! cur (st-class-superclass cur))
|
||||
(ch-loop)))))
|
||||
(ch-loop)
|
||||
acc))))
|
||||
|
||||
;; Inherited + own ivars in declaration order from root to leaf.
|
||||
(define
|
||||
st-class-all-ivars
|
||||
(fn
|
||||
(name)
|
||||
(let ((chain (reverse (st-class-chain name))) (out (list)))
|
||||
(begin
|
||||
(for-each
|
||||
(fn
|
||||
(cn)
|
||||
(let
|
||||
((c (st-class-get cn)))
|
||||
(when
|
||||
(not (= c nil))
|
||||
(for-each (fn (iv) (append! out iv)) (get c :ivars)))))
|
||||
chain)
|
||||
out))))
|
||||
|
||||
;; Method install. The defining-class field is stamped on the method record
|
||||
;; so super-sends look up from the right point in the chain.
|
||||
(define
|
||||
st-class-add-method!
|
||||
(fn
|
||||
(cls-name selector method-ast)
|
||||
(let
|
||||
((cls (st-class-get cls-name)))
|
||||
(cond
|
||||
((= cls nil) (error (str "st-class-add-method!: unknown class " cls-name)))
|
||||
(else
|
||||
(let
|
||||
((m (assoc method-ast :defining-class cls-name)))
|
||||
(begin
|
||||
(set!
|
||||
st-class-table
|
||||
(assoc
|
||||
st-class-table
|
||||
cls-name
|
||||
(assoc
|
||||
cls
|
||||
:methods
|
||||
(assoc (get cls :methods) selector m))))
|
||||
selector)))))))
|
||||
|
||||
(define
|
||||
st-class-add-class-method!
|
||||
(fn
|
||||
(cls-name selector method-ast)
|
||||
(let
|
||||
((cls (st-class-get cls-name)))
|
||||
(cond
|
||||
((= cls nil) (error (str "st-class-add-class-method!: unknown class " cls-name)))
|
||||
(else
|
||||
(let
|
||||
((m (assoc method-ast :defining-class cls-name)))
|
||||
(begin
|
||||
(set!
|
||||
st-class-table
|
||||
(assoc
|
||||
st-class-table
|
||||
cls-name
|
||||
(assoc
|
||||
cls
|
||||
:class-methods
|
||||
(assoc (get cls :class-methods) selector m))))
|
||||
selector)))))))
|
||||
|
||||
;; Method lookup: walk superclass chain starting at `cls-name`.
|
||||
;; class-side? = true searches :class-methods, false searches :methods.
|
||||
;; Returns the method record (with :defining-class) or nil.
|
||||
(define
|
||||
st-method-lookup
|
||||
(fn
|
||||
(cls-name selector class-side?)
|
||||
(let
|
||||
((found nil))
|
||||
(begin
|
||||
(define
|
||||
ml-loop
|
||||
(fn
|
||||
(cur)
|
||||
(when
|
||||
(and (= found nil) (not (= cur nil)) (st-class-exists? cur))
|
||||
(let
|
||||
((c (st-class-get cur)))
|
||||
(let
|
||||
((dict (if class-side? (get c :class-methods) (get c :methods))))
|
||||
(cond
|
||||
((has-key? dict selector) (set! found (get dict selector)))
|
||||
(else (ml-loop (get c :superclass)))))))))
|
||||
(ml-loop cls-name)
|
||||
found))))
|
||||
|
||||
;; SX value → Smalltalk class name. Native types are not boxed.
|
||||
(define
|
||||
st-class-of
|
||||
(fn
|
||||
(v)
|
||||
(cond
|
||||
((= v nil) "UndefinedObject")
|
||||
((= v true) "True")
|
||||
((= v false) "False")
|
||||
((integer? v) "SmallInteger")
|
||||
((number? v) "Float")
|
||||
((string? v) "String")
|
||||
((symbol? v) "Symbol")
|
||||
((list? v) "Array")
|
||||
((and (dict? v) (has-key? v :type) (= (get v :type) "st-instance"))
|
||||
(get v :class))
|
||||
((and (dict? v) (has-key? v :type) (= (get v :type) "block"))
|
||||
"BlockClosure")
|
||||
((and (dict? v) (has-key? v :st-block?) (get v :st-block?))
|
||||
"BlockClosure")
|
||||
((dict? v) "Dictionary")
|
||||
((lambda? v) "BlockClosure")
|
||||
(else "Object"))))
|
||||
|
||||
;; Construct a fresh instance of cls-name. Ivars (own + inherited) start as nil.
|
||||
(define
|
||||
st-make-instance
|
||||
(fn
|
||||
(cls-name)
|
||||
(cond
|
||||
((not (st-class-exists? cls-name))
|
||||
(error (str "st-make-instance: unknown class " cls-name)))
|
||||
(else
|
||||
(let
|
||||
((iv-names (st-class-all-ivars cls-name)) (ivars {}))
|
||||
(begin
|
||||
(for-each (fn (n) (set! ivars (assoc ivars n nil))) iv-names)
|
||||
{:type "st-instance" :class cls-name :ivars ivars}))))))
|
||||
|
||||
(define
|
||||
st-instance?
|
||||
(fn
|
||||
(v)
|
||||
(and (dict? v) (has-key? v :type) (= (get v :type) "st-instance"))))
|
||||
|
||||
(define
|
||||
st-iv-get
|
||||
(fn
|
||||
(inst name)
|
||||
(let ((ivs (get inst :ivars)))
|
||||
(if (has-key? ivs name) (get ivs name) nil))))
|
||||
|
||||
(define
|
||||
st-iv-set!
|
||||
(fn
|
||||
(inst name value)
|
||||
(let
|
||||
((new-ivars (assoc (get inst :ivars) name value)))
|
||||
(assoc inst :ivars new-ivars))))
|
||||
|
||||
;; Inherits-from check: is `descendant` either equal to `ancestor` or a subclass?
|
||||
(define
|
||||
st-class-inherits-from?
|
||||
(fn
|
||||
(descendant ancestor)
|
||||
(let ((found false) (cur descendant))
|
||||
(begin
|
||||
(define
|
||||
ih-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (not found) (not (= cur nil)) (st-class-exists? cur))
|
||||
(cond
|
||||
((= cur ancestor) (set! found true))
|
||||
(else
|
||||
(begin
|
||||
(set! cur (st-class-superclass cur))
|
||||
(ih-loop)))))))
|
||||
(ih-loop)
|
||||
found))))
|
||||
|
||||
;; Bootstrap the canonical class hierarchy. Reset and rebuild.
|
||||
(define
|
||||
st-bootstrap-classes!
|
||||
(fn
|
||||
()
|
||||
(begin
|
||||
(st-class-table-clear!)
|
||||
;; Root
|
||||
(st-class-define! "Object" nil (list))
|
||||
;; Class side machinery
|
||||
(st-class-define! "Behavior" "Object" (list "superclass" "methodDict" "format"))
|
||||
(st-class-define! "ClassDescription" "Behavior" (list "instanceVariables" "organization"))
|
||||
(st-class-define! "Class" "ClassDescription" (list "name" "subclasses"))
|
||||
(st-class-define! "Metaclass" "ClassDescription" (list "thisClass"))
|
||||
;; Pseudo-variable types
|
||||
(st-class-define! "UndefinedObject" "Object" (list))
|
||||
(st-class-define! "Boolean" "Object" (list))
|
||||
(st-class-define! "True" "Boolean" (list))
|
||||
(st-class-define! "False" "Boolean" (list))
|
||||
;; Magnitudes
|
||||
(st-class-define! "Magnitude" "Object" (list))
|
||||
(st-class-define! "Number" "Magnitude" (list))
|
||||
(st-class-define! "Integer" "Number" (list))
|
||||
(st-class-define! "SmallInteger" "Integer" (list))
|
||||
(st-class-define! "LargePositiveInteger" "Integer" (list))
|
||||
(st-class-define! "Float" "Number" (list))
|
||||
(st-class-define! "Character" "Magnitude" (list "value"))
|
||||
;; Collections
|
||||
(st-class-define! "Collection" "Object" (list))
|
||||
(st-class-define! "SequenceableCollection" "Collection" (list))
|
||||
(st-class-define! "ArrayedCollection" "SequenceableCollection" (list))
|
||||
(st-class-define! "Array" "ArrayedCollection" (list))
|
||||
(st-class-define! "String" "ArrayedCollection" (list))
|
||||
(st-class-define! "Symbol" "String" (list))
|
||||
(st-class-define! "OrderedCollection" "SequenceableCollection" (list "array" "firstIndex" "lastIndex"))
|
||||
(st-class-define! "Dictionary" "Collection" (list))
|
||||
;; Blocks / contexts
|
||||
(st-class-define! "BlockClosure" "Object" (list))
|
||||
"ok")))
|
||||
|
||||
;; Initialise on load. Tests can re-bootstrap to reset state.
|
||||
(st-bootstrap-classes!)
|
||||
137
lib/smalltalk/test.sh
Executable file
137
lib/smalltalk/test.sh
Executable file
@@ -0,0 +1,137 @@
|
||||
#!/usr/bin/env bash
|
||||
# Fast Smalltalk-on-SX test runner — pipes directly to sx_server.exe.
|
||||
# Mirrors lib/haskell/test.sh.
|
||||
#
|
||||
# Usage:
|
||||
# bash lib/smalltalk/test.sh # run all tests
|
||||
# bash lib/smalltalk/test.sh -v # verbose
|
||||
# bash lib/smalltalk/test.sh tests/tokenize.sx # run one file
|
||||
|
||||
set -uo pipefail
|
||||
cd "$(git rev-parse --show-toplevel)"
|
||||
|
||||
SX_SERVER="hosts/ocaml/_build/default/bin/sx_server.exe"
|
||||
if [ ! -x "$SX_SERVER" ]; then
|
||||
MAIN_ROOT=$(git worktree list | head -1 | awk '{print $1}')
|
||||
if [ -x "$MAIN_ROOT/$SX_SERVER" ]; then
|
||||
SX_SERVER="$MAIN_ROOT/$SX_SERVER"
|
||||
else
|
||||
echo "ERROR: sx_server.exe not found. Run: cd hosts/ocaml && dune build"
|
||||
exit 1
|
||||
fi
|
||||
fi
|
||||
|
||||
VERBOSE=""
|
||||
FILES=()
|
||||
for arg in "$@"; do
|
||||
case "$arg" in
|
||||
-v|--verbose) VERBOSE=1 ;;
|
||||
*) FILES+=("$arg") ;;
|
||||
esac
|
||||
done
|
||||
|
||||
if [ ${#FILES[@]} -eq 0 ]; then
|
||||
# tokenize.sx must load first — it defines the st-test helpers reused by
|
||||
# subsequent test files. Sort enforces this lexicographically.
|
||||
mapfile -t FILES < <(find lib/smalltalk/tests -maxdepth 2 -name '*.sx' | sort)
|
||||
fi
|
||||
|
||||
TOTAL_PASS=0
|
||||
TOTAL_FAIL=0
|
||||
FAILED_FILES=()
|
||||
|
||||
for FILE in "${FILES[@]}"; do
|
||||
[ -f "$FILE" ] || { echo "skip $FILE (not found)"; continue; }
|
||||
TMPFILE=$(mktemp)
|
||||
if [ "$(basename "$FILE")" = "tokenize.sx" ]; then
|
||||
cat > "$TMPFILE" <<EPOCHS
|
||||
(epoch 1)
|
||||
(load "lib/smalltalk/tokenizer.sx")
|
||||
(epoch 2)
|
||||
(load "$FILE")
|
||||
(epoch 3)
|
||||
(eval "(list st-test-pass st-test-fail)")
|
||||
EPOCHS
|
||||
else
|
||||
cat > "$TMPFILE" <<EPOCHS
|
||||
(epoch 1)
|
||||
(load "lib/smalltalk/tokenizer.sx")
|
||||
(epoch 2)
|
||||
(load "lib/smalltalk/parser.sx")
|
||||
(epoch 3)
|
||||
(load "lib/smalltalk/runtime.sx")
|
||||
(epoch 4)
|
||||
(load "lib/smalltalk/tests/tokenize.sx")
|
||||
(epoch 5)
|
||||
(load "$FILE")
|
||||
(epoch 6)
|
||||
(eval "(list st-test-pass st-test-fail)")
|
||||
EPOCHS
|
||||
fi
|
||||
|
||||
OUTPUT=$(timeout 60 "$SX_SERVER" < "$TMPFILE" 2>&1 || true)
|
||||
rm -f "$TMPFILE"
|
||||
|
||||
# Final epoch's value: either (ok N (P F)) on one line or
|
||||
# (ok-len N M)\n(P F) where the value is on the following line.
|
||||
LINE=$(echo "$OUTPUT" | awk '/^\(ok-len [0-9]+ / {getline; print}' | tail -1)
|
||||
if [ -z "$LINE" ]; then
|
||||
LINE=$(echo "$OUTPUT" | grep -E '^\(ok [0-9]+ \([0-9]+ [0-9]+\)\)' | tail -1 \
|
||||
| sed -E 's/^\(ok [0-9]+ //; s/\)$//')
|
||||
fi
|
||||
if [ -z "$LINE" ]; then
|
||||
echo "X $FILE: could not extract summary"
|
||||
echo "$OUTPUT" | tail -30
|
||||
TOTAL_FAIL=$((TOTAL_FAIL + 1))
|
||||
FAILED_FILES+=("$FILE")
|
||||
continue
|
||||
fi
|
||||
P=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\1/')
|
||||
F=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\2/')
|
||||
TOTAL_PASS=$((TOTAL_PASS + P))
|
||||
TOTAL_FAIL=$((TOTAL_FAIL + F))
|
||||
if [ "$F" -gt 0 ]; then
|
||||
FAILED_FILES+=("$FILE")
|
||||
printf 'X %-40s %d/%d\n' "$FILE" "$P" "$((P+F))"
|
||||
TMPFILE2=$(mktemp)
|
||||
if [ "$(basename "$FILE")" = "tokenize.sx" ]; then
|
||||
cat > "$TMPFILE2" <<EPOCHS
|
||||
(epoch 1)
|
||||
(load "lib/smalltalk/tokenizer.sx")
|
||||
(epoch 2)
|
||||
(load "$FILE")
|
||||
(epoch 3)
|
||||
(eval "(map (fn (f) (get f :name)) st-test-fails)")
|
||||
EPOCHS
|
||||
else
|
||||
cat > "$TMPFILE2" <<EPOCHS
|
||||
(epoch 1)
|
||||
(load "lib/smalltalk/tokenizer.sx")
|
||||
(epoch 2)
|
||||
(load "lib/smalltalk/parser.sx")
|
||||
(epoch 3)
|
||||
(load "lib/smalltalk/runtime.sx")
|
||||
(epoch 4)
|
||||
(load "lib/smalltalk/tests/tokenize.sx")
|
||||
(epoch 5)
|
||||
(load "$FILE")
|
||||
(epoch 6)
|
||||
(eval "(map (fn (f) (get f :name)) st-test-fails)")
|
||||
EPOCHS
|
||||
fi
|
||||
FAILS=$(timeout 60 "$SX_SERVER" < "$TMPFILE2" 2>&1 | grep -E '^\(ok [0-9]+ \(' | tail -1 || true)
|
||||
rm -f "$TMPFILE2"
|
||||
echo " $FAILS"
|
||||
elif [ "$VERBOSE" = "1" ]; then
|
||||
printf 'OK %-40s %d passed\n' "$FILE" "$P"
|
||||
fi
|
||||
done
|
||||
|
||||
TOTAL=$((TOTAL_PASS + TOTAL_FAIL))
|
||||
if [ $TOTAL_FAIL -eq 0 ]; then
|
||||
echo "OK $TOTAL_PASS/$TOTAL smalltalk-on-sx tests passed"
|
||||
else
|
||||
echo "FAIL $TOTAL_PASS/$TOTAL passed, $TOTAL_FAIL failed in: ${FAILED_FILES[*]}"
|
||||
fi
|
||||
|
||||
[ $TOTAL_FAIL -eq 0 ]
|
||||
369
lib/smalltalk/tests/parse.sx
Normal file
369
lib/smalltalk/tests/parse.sx
Normal file
@@ -0,0 +1,369 @@
|
||||
;; Smalltalk parser tests.
|
||||
;;
|
||||
;; Reuses helpers (st-test, st-deep=?) from tokenize.sx. Counters reset
|
||||
;; here so this file's summary covers parse tests only.
|
||||
|
||||
(set! st-test-pass 0)
|
||||
(set! st-test-fail 0)
|
||||
(set! st-test-fails (list))
|
||||
|
||||
;; ── 1. Atoms ──
|
||||
(st-test "int" (st-parse-expr "42") {:type "lit-int" :value 42})
|
||||
(st-test "float" (st-parse-expr "3.14") {:type "lit-float" :value 3.14})
|
||||
(st-test "string" (st-parse-expr "'hi'") {:type "lit-string" :value "hi"})
|
||||
(st-test "char" (st-parse-expr "$x") {:type "lit-char" :value "x"})
|
||||
(st-test "symbol" (st-parse-expr "#foo") {:type "lit-symbol" :value "foo"})
|
||||
(st-test "binary symbol" (st-parse-expr "#+") {:type "lit-symbol" :value "+"})
|
||||
(st-test "keyword symbol" (st-parse-expr "#at:put:") {:type "lit-symbol" :value "at:put:"})
|
||||
(st-test "nil" (st-parse-expr "nil") {:type "lit-nil"})
|
||||
(st-test "true" (st-parse-expr "true") {:type "lit-true"})
|
||||
(st-test "false" (st-parse-expr "false") {:type "lit-false"})
|
||||
(st-test "self" (st-parse-expr "self") {:type "self"})
|
||||
(st-test "super" (st-parse-expr "super") {:type "super"})
|
||||
(st-test "ident" (st-parse-expr "x") {:type "ident" :name "x"})
|
||||
(st-test "negative int" (st-parse-expr "-3") {:type "lit-int" :value -3})
|
||||
|
||||
;; ── 2. Literal arrays ──
|
||||
(st-test
|
||||
"literal array of ints"
|
||||
(st-parse-expr "#(1 2 3)")
|
||||
{:type "lit-array"
|
||||
:elements (list
|
||||
{:type "lit-int" :value 1}
|
||||
{:type "lit-int" :value 2}
|
||||
{:type "lit-int" :value 3})})
|
||||
|
||||
(st-test
|
||||
"literal array mixed"
|
||||
(st-parse-expr "#(1 #foo 'x' true)")
|
||||
{:type "lit-array"
|
||||
:elements (list
|
||||
{:type "lit-int" :value 1}
|
||||
{:type "lit-symbol" :value "foo"}
|
||||
{:type "lit-string" :value "x"}
|
||||
{:type "lit-true"})})
|
||||
|
||||
(st-test
|
||||
"literal array bare ident is symbol"
|
||||
(st-parse-expr "#(foo bar)")
|
||||
{:type "lit-array"
|
||||
:elements (list
|
||||
{:type "lit-symbol" :value "foo"}
|
||||
{:type "lit-symbol" :value "bar"})})
|
||||
|
||||
(st-test
|
||||
"nested literal array"
|
||||
(st-parse-expr "#(1 (2 3) 4)")
|
||||
{:type "lit-array"
|
||||
:elements (list
|
||||
{:type "lit-int" :value 1}
|
||||
{:type "lit-array"
|
||||
:elements (list
|
||||
{:type "lit-int" :value 2}
|
||||
{:type "lit-int" :value 3})}
|
||||
{:type "lit-int" :value 4})})
|
||||
|
||||
(st-test
|
||||
"byte array"
|
||||
(st-parse-expr "#[1 2 3]")
|
||||
{:type "lit-byte-array" :elements (list 1 2 3)})
|
||||
|
||||
;; ── 3. Unary messages ──
|
||||
(st-test
|
||||
"unary single"
|
||||
(st-parse-expr "x foo")
|
||||
{:type "send"
|
||||
:receiver {:type "ident" :name "x"}
|
||||
:selector "foo"
|
||||
:args (list)})
|
||||
|
||||
(st-test
|
||||
"unary chain"
|
||||
(st-parse-expr "x foo bar baz")
|
||||
{:type "send"
|
||||
:receiver {:type "send"
|
||||
:receiver {:type "send"
|
||||
:receiver {:type "ident" :name "x"}
|
||||
:selector "foo"
|
||||
:args (list)}
|
||||
:selector "bar"
|
||||
:args (list)}
|
||||
:selector "baz"
|
||||
:args (list)})
|
||||
|
||||
(st-test
|
||||
"unary on literal"
|
||||
(st-parse-expr "42 printNl")
|
||||
{:type "send"
|
||||
:receiver {:type "lit-int" :value 42}
|
||||
:selector "printNl"
|
||||
:args (list)})
|
||||
|
||||
;; ── 4. Binary messages ──
|
||||
(st-test
|
||||
"binary single"
|
||||
(st-parse-expr "1 + 2")
|
||||
{:type "send"
|
||||
:receiver {:type "lit-int" :value 1}
|
||||
:selector "+"
|
||||
:args (list {:type "lit-int" :value 2})})
|
||||
|
||||
(st-test
|
||||
"binary left-assoc"
|
||||
(st-parse-expr "1 + 2 + 3")
|
||||
{:type "send"
|
||||
:receiver {:type "send"
|
||||
:receiver {:type "lit-int" :value 1}
|
||||
:selector "+"
|
||||
:args (list {:type "lit-int" :value 2})}
|
||||
:selector "+"
|
||||
:args (list {:type "lit-int" :value 3})})
|
||||
|
||||
(st-test
|
||||
"binary same precedence l-to-r"
|
||||
(st-parse-expr "1 + 2 * 3")
|
||||
{:type "send"
|
||||
:receiver {:type "send"
|
||||
:receiver {:type "lit-int" :value 1}
|
||||
:selector "+"
|
||||
:args (list {:type "lit-int" :value 2})}
|
||||
:selector "*"
|
||||
:args (list {:type "lit-int" :value 3})})
|
||||
|
||||
;; ── 5. Precedence: unary binds tighter than binary ──
|
||||
(st-test
|
||||
"unary tighter than binary"
|
||||
(st-parse-expr "3 + 4 factorial")
|
||||
{:type "send"
|
||||
:receiver {:type "lit-int" :value 3}
|
||||
:selector "+"
|
||||
:args (list
|
||||
{:type "send"
|
||||
:receiver {:type "lit-int" :value 4}
|
||||
:selector "factorial"
|
||||
:args (list)})})
|
||||
|
||||
;; ── 6. Keyword messages ──
|
||||
(st-test
|
||||
"keyword single"
|
||||
(st-parse-expr "x at: 1")
|
||||
{:type "send"
|
||||
:receiver {:type "ident" :name "x"}
|
||||
:selector "at:"
|
||||
:args (list {:type "lit-int" :value 1})})
|
||||
|
||||
(st-test
|
||||
"keyword chain"
|
||||
(st-parse-expr "x at: 1 put: 'a'")
|
||||
{:type "send"
|
||||
:receiver {:type "ident" :name "x"}
|
||||
:selector "at:put:"
|
||||
:args (list {:type "lit-int" :value 1} {:type "lit-string" :value "a"})})
|
||||
|
||||
;; ── 7. Precedence: binary tighter than keyword ──
|
||||
(st-test
|
||||
"binary tighter than keyword"
|
||||
(st-parse-expr "x at: 1 + 2")
|
||||
{:type "send"
|
||||
:receiver {:type "ident" :name "x"}
|
||||
:selector "at:"
|
||||
:args (list
|
||||
{:type "send"
|
||||
:receiver {:type "lit-int" :value 1}
|
||||
:selector "+"
|
||||
:args (list {:type "lit-int" :value 2})})})
|
||||
|
||||
(st-test
|
||||
"keyword absorbs trailing unary"
|
||||
(st-parse-expr "a foo: b bar")
|
||||
{:type "send"
|
||||
:receiver {:type "ident" :name "a"}
|
||||
:selector "foo:"
|
||||
:args (list
|
||||
{:type "send"
|
||||
:receiver {:type "ident" :name "b"}
|
||||
:selector "bar"
|
||||
:args (list)})})
|
||||
|
||||
;; ── 8. Parens override precedence ──
|
||||
(st-test
|
||||
"paren forces grouping"
|
||||
(st-parse-expr "(1 + 2) * 3")
|
||||
{:type "send"
|
||||
:receiver {:type "send"
|
||||
:receiver {:type "lit-int" :value 1}
|
||||
:selector "+"
|
||||
:args (list {:type "lit-int" :value 2})}
|
||||
:selector "*"
|
||||
:args (list {:type "lit-int" :value 3})})
|
||||
|
||||
;; ── 9. Cascade ──
|
||||
(st-test
|
||||
"simple cascade"
|
||||
(st-parse-expr "x m1; m2")
|
||||
{:type "cascade"
|
||||
:receiver {:type "ident" :name "x"}
|
||||
:messages (list
|
||||
{:selector "m1" :args (list)}
|
||||
{:selector "m2" :args (list)})})
|
||||
|
||||
(st-test
|
||||
"cascade with binary and keyword"
|
||||
(st-parse-expr "Stream new nl; tab; print: 1")
|
||||
{:type "cascade"
|
||||
:receiver {:type "send"
|
||||
:receiver {:type "ident" :name "Stream"}
|
||||
:selector "new"
|
||||
:args (list)}
|
||||
:messages (list
|
||||
{:selector "nl" :args (list)}
|
||||
{:selector "tab" :args (list)}
|
||||
{:selector "print:" :args (list {:type "lit-int" :value 1})})})
|
||||
|
||||
;; ── 10. Blocks ──
|
||||
(st-test
|
||||
"empty block"
|
||||
(st-parse-expr "[]")
|
||||
{:type "block" :params (list) :temps (list) :body (list)})
|
||||
|
||||
(st-test
|
||||
"block one expr"
|
||||
(st-parse-expr "[1 + 2]")
|
||||
{:type "block"
|
||||
:params (list)
|
||||
:temps (list)
|
||||
:body (list
|
||||
{:type "send"
|
||||
:receiver {:type "lit-int" :value 1}
|
||||
:selector "+"
|
||||
:args (list {:type "lit-int" :value 2})})})
|
||||
|
||||
(st-test
|
||||
"block with params"
|
||||
(st-parse-expr "[:a :b | a + b]")
|
||||
{:type "block"
|
||||
:params (list "a" "b")
|
||||
:temps (list)
|
||||
:body (list
|
||||
{:type "send"
|
||||
:receiver {:type "ident" :name "a"}
|
||||
:selector "+"
|
||||
:args (list {:type "ident" :name "b"})})})
|
||||
|
||||
(st-test
|
||||
"block with temps"
|
||||
(st-parse-expr "[| t | t := 1. t]")
|
||||
{:type "block"
|
||||
:params (list)
|
||||
:temps (list "t")
|
||||
:body (list
|
||||
{:type "assign" :name "t" :expr {:type "lit-int" :value 1}}
|
||||
{:type "ident" :name "t"})})
|
||||
|
||||
(st-test
|
||||
"block with params and temps"
|
||||
(st-parse-expr "[:x | | t | t := x + 1. t]")
|
||||
{:type "block"
|
||||
:params (list "x")
|
||||
:temps (list "t")
|
||||
:body (list
|
||||
{:type "assign"
|
||||
:name "t"
|
||||
:expr {:type "send"
|
||||
:receiver {:type "ident" :name "x"}
|
||||
:selector "+"
|
||||
:args (list {:type "lit-int" :value 1})}}
|
||||
{:type "ident" :name "t"})})
|
||||
|
||||
;; ── 11. Assignment / return / statements ──
|
||||
(st-test
|
||||
"assignment"
|
||||
(st-parse-expr "x := 1")
|
||||
{:type "assign" :name "x" :expr {:type "lit-int" :value 1}})
|
||||
|
||||
(st-test
|
||||
"return"
|
||||
(st-parse-expr "1")
|
||||
{:type "lit-int" :value 1})
|
||||
|
||||
(st-test
|
||||
"return statement at top level"
|
||||
(st-parse "^ 1")
|
||||
{:type "seq"
|
||||
:exprs (list {:type "return" :expr {:type "lit-int" :value 1}})})
|
||||
|
||||
(st-test
|
||||
"two statements"
|
||||
(st-parse "x := 1. y := 2")
|
||||
{:type "seq"
|
||||
:exprs (list
|
||||
{:type "assign" :name "x" :expr {:type "lit-int" :value 1}}
|
||||
{:type "assign" :name "y" :expr {:type "lit-int" :value 2}})})
|
||||
|
||||
(st-test
|
||||
"trailing dot allowed"
|
||||
(st-parse "1. 2.")
|
||||
{:type "seq"
|
||||
:exprs (list {:type "lit-int" :value 1} {:type "lit-int" :value 2})})
|
||||
|
||||
;; ── 12. Method headers ──
|
||||
(st-test
|
||||
"unary method"
|
||||
(st-parse-method "factorial ^ self * (self - 1) factorial")
|
||||
{:type "method"
|
||||
:selector "factorial"
|
||||
:params (list)
|
||||
:temps (list)
|
||||
:pragmas (list)
|
||||
:body (list
|
||||
{:type "return"
|
||||
:expr {:type "send"
|
||||
:receiver {:type "self"}
|
||||
:selector "*"
|
||||
:args (list
|
||||
{:type "send"
|
||||
:receiver {:type "send"
|
||||
:receiver {:type "self"}
|
||||
:selector "-"
|
||||
:args (list {:type "lit-int" :value 1})}
|
||||
:selector "factorial"
|
||||
:args (list)})}})})
|
||||
|
||||
(st-test
|
||||
"binary method"
|
||||
(st-parse-method "+ other ^ 'plus'")
|
||||
{:type "method"
|
||||
:selector "+"
|
||||
:params (list "other")
|
||||
:temps (list)
|
||||
:pragmas (list)
|
||||
:body (list {:type "return" :expr {:type "lit-string" :value "plus"}})})
|
||||
|
||||
(st-test
|
||||
"keyword method"
|
||||
(st-parse-method "at: i put: v ^ v")
|
||||
{:type "method"
|
||||
:selector "at:put:"
|
||||
:params (list "i" "v")
|
||||
:temps (list)
|
||||
:pragmas (list)
|
||||
:body (list {:type "return" :expr {:type "ident" :name "v"}})})
|
||||
|
||||
(st-test
|
||||
"method with temps"
|
||||
(st-parse-method "twice: x | t | t := x + x. ^ t")
|
||||
{:type "method"
|
||||
:selector "twice:"
|
||||
:params (list "x")
|
||||
:temps (list "t")
|
||||
:pragmas (list)
|
||||
:body (list
|
||||
{:type "assign"
|
||||
:name "t"
|
||||
:expr {:type "send"
|
||||
:receiver {:type "ident" :name "x"}
|
||||
:selector "+"
|
||||
:args (list {:type "ident" :name "x"})}}
|
||||
{:type "return" :expr {:type "ident" :name "t"}})})
|
||||
|
||||
(list st-test-pass st-test-fail)
|
||||
294
lib/smalltalk/tests/parse_chunks.sx
Normal file
294
lib/smalltalk/tests/parse_chunks.sx
Normal file
@@ -0,0 +1,294 @@
|
||||
;; Smalltalk chunk-stream parser + pragma tests.
|
||||
;;
|
||||
;; Reuses helpers (st-test, st-deep=?) from tokenize.sx. Counters reset
|
||||
;; here so this file's summary covers chunk + pragma tests only.
|
||||
|
||||
(set! st-test-pass 0)
|
||||
(set! st-test-fail 0)
|
||||
(set! st-test-fails (list))
|
||||
|
||||
;; ── 1. Raw chunk reader ──
|
||||
(st-test "empty source" (st-read-chunks "") (list))
|
||||
(st-test "single chunk" (st-read-chunks "foo!") (list "foo"))
|
||||
(st-test "two chunks" (st-read-chunks "a! b!") (list "a" "b"))
|
||||
(st-test "trailing no bang" (st-read-chunks "a! b") (list "a" "b"))
|
||||
(st-test "empty chunk" (st-read-chunks "a! ! b!") (list "a" "" "b"))
|
||||
(st-test
|
||||
"doubled bang escapes"
|
||||
(st-read-chunks "yes!! no!yes!")
|
||||
(list "yes! no" "yes"))
|
||||
(st-test
|
||||
"whitespace trimmed"
|
||||
(st-read-chunks " \n hello \n !")
|
||||
(list "hello"))
|
||||
|
||||
;; ── 2. Chunk parser — do-it mode ──
|
||||
(st-test
|
||||
"single do-it chunk"
|
||||
(st-parse-chunks "1 + 2!")
|
||||
(list
|
||||
{:kind "expr"
|
||||
:ast {:type "send"
|
||||
:receiver {:type "lit-int" :value 1}
|
||||
:selector "+"
|
||||
:args (list {:type "lit-int" :value 2})}}))
|
||||
|
||||
(st-test
|
||||
"two do-it chunks"
|
||||
(st-parse-chunks "x := 1! y := 2!")
|
||||
(list
|
||||
{:kind "expr"
|
||||
:ast {:type "assign" :name "x" :expr {:type "lit-int" :value 1}}}
|
||||
{:kind "expr"
|
||||
:ast {:type "assign" :name "y" :expr {:type "lit-int" :value 2}}}))
|
||||
|
||||
(st-test
|
||||
"blank chunk outside methods"
|
||||
(st-parse-chunks "1! ! 2!")
|
||||
(list
|
||||
{:kind "expr" :ast {:type "lit-int" :value 1}}
|
||||
{:kind "blank"}
|
||||
{:kind "expr" :ast {:type "lit-int" :value 2}}))
|
||||
|
||||
;; ── 3. Methods batch ──
|
||||
(st-test
|
||||
"methodsFor opens method batch"
|
||||
(st-parse-chunks
|
||||
"Foo methodsFor: 'access'! foo ^ 1! bar ^ 2! !")
|
||||
(list
|
||||
{:kind "expr"
|
||||
:ast {:type "send"
|
||||
:receiver {:type "ident" :name "Foo"}
|
||||
:selector "methodsFor:"
|
||||
:args (list {:type "lit-string" :value "access"})}}
|
||||
{:kind "method"
|
||||
:class "Foo"
|
||||
:class-side? false
|
||||
:category "access"
|
||||
:ast {:type "method"
|
||||
:selector "foo"
|
||||
:params (list)
|
||||
:temps (list)
|
||||
:pragmas (list)
|
||||
:body (list
|
||||
{:type "return" :expr {:type "lit-int" :value 1}})}}
|
||||
{:kind "method"
|
||||
:class "Foo"
|
||||
:class-side? false
|
||||
:category "access"
|
||||
:ast {:type "method"
|
||||
:selector "bar"
|
||||
:params (list)
|
||||
:temps (list)
|
||||
:pragmas (list)
|
||||
:body (list
|
||||
{:type "return" :expr {:type "lit-int" :value 2}})}}
|
||||
{:kind "end-methods"}))
|
||||
|
||||
(st-test
|
||||
"class-side methodsFor"
|
||||
(st-parse-chunks
|
||||
"Foo class methodsFor: 'creation'! make ^ self new! !")
|
||||
(list
|
||||
{:kind "expr"
|
||||
:ast {:type "send"
|
||||
:receiver {:type "send"
|
||||
:receiver {:type "ident" :name "Foo"}
|
||||
:selector "class"
|
||||
:args (list)}
|
||||
:selector "methodsFor:"
|
||||
:args (list {:type "lit-string" :value "creation"})}}
|
||||
{:kind "method"
|
||||
:class "Foo"
|
||||
:class-side? true
|
||||
:category "creation"
|
||||
:ast {:type "method"
|
||||
:selector "make"
|
||||
:params (list)
|
||||
:temps (list)
|
||||
:pragmas (list)
|
||||
:body (list
|
||||
{:type "return"
|
||||
:expr {:type "send"
|
||||
:receiver {:type "self"}
|
||||
:selector "new"
|
||||
:args (list)}})}}
|
||||
{:kind "end-methods"}))
|
||||
|
||||
(st-test
|
||||
"method batch returns to do-it after empty chunk"
|
||||
(st-parse-chunks
|
||||
"Foo methodsFor: 'a'! m1 ^ 1! ! 99!")
|
||||
(list
|
||||
{:kind "expr"
|
||||
:ast {:type "send"
|
||||
:receiver {:type "ident" :name "Foo"}
|
||||
:selector "methodsFor:"
|
||||
:args (list {:type "lit-string" :value "a"})}}
|
||||
{:kind "method"
|
||||
:class "Foo"
|
||||
:class-side? false
|
||||
:category "a"
|
||||
:ast {:type "method"
|
||||
:selector "m1"
|
||||
:params (list)
|
||||
:temps (list)
|
||||
:pragmas (list)
|
||||
:body (list
|
||||
{:type "return" :expr {:type "lit-int" :value 1}})}}
|
||||
{:kind "end-methods"}
|
||||
{:kind "expr" :ast {:type "lit-int" :value 99}}))
|
||||
|
||||
;; ── 4. Pragmas in method bodies ──
|
||||
(st-test
|
||||
"single pragma"
|
||||
(st-parse-method "primAt: i <primitive: 60> ^ self")
|
||||
{:type "method"
|
||||
:selector "primAt:"
|
||||
:params (list "i")
|
||||
:temps (list)
|
||||
:pragmas (list
|
||||
{:selector "primitive:"
|
||||
:args (list {:type "lit-int" :value 60})})
|
||||
:body (list {:type "return" :expr {:type "self"}})})
|
||||
|
||||
(st-test
|
||||
"pragma with two keyword pairs"
|
||||
(st-parse-method "fft <primitive: 1 module: 'fft'> ^ nil")
|
||||
{:type "method"
|
||||
:selector "fft"
|
||||
:params (list)
|
||||
:temps (list)
|
||||
:pragmas (list
|
||||
{:selector "primitive:module:"
|
||||
:args (list
|
||||
{:type "lit-int" :value 1}
|
||||
{:type "lit-string" :value "fft"})})
|
||||
:body (list {:type "return" :expr {:type "lit-nil"}})})
|
||||
|
||||
(st-test
|
||||
"pragma with negative number"
|
||||
(st-parse-method "neg <primitive: -1> ^ nil")
|
||||
{:type "method"
|
||||
:selector "neg"
|
||||
:params (list)
|
||||
:temps (list)
|
||||
:pragmas (list
|
||||
{:selector "primitive:"
|
||||
:args (list {:type "lit-int" :value -1})})
|
||||
:body (list {:type "return" :expr {:type "lit-nil"}})})
|
||||
|
||||
(st-test
|
||||
"pragma with symbol arg"
|
||||
(st-parse-method "tagged <category: #algebra> ^ nil")
|
||||
{:type "method"
|
||||
:selector "tagged"
|
||||
:params (list)
|
||||
:temps (list)
|
||||
:pragmas (list
|
||||
{:selector "category:"
|
||||
:args (list {:type "lit-symbol" :value "algebra"})})
|
||||
:body (list {:type "return" :expr {:type "lit-nil"}})})
|
||||
|
||||
(st-test
|
||||
"pragma then temps"
|
||||
(st-parse-method "calc <primitive: 1> | t | t := 5. ^ t")
|
||||
{:type "method"
|
||||
:selector "calc"
|
||||
:params (list)
|
||||
:temps (list "t")
|
||||
:pragmas (list
|
||||
{:selector "primitive:"
|
||||
:args (list {:type "lit-int" :value 1})})
|
||||
:body (list
|
||||
{:type "assign" :name "t" :expr {:type "lit-int" :value 5}}
|
||||
{:type "return" :expr {:type "ident" :name "t"}})})
|
||||
|
||||
(st-test
|
||||
"temps then pragma"
|
||||
(st-parse-method "calc | t | <primitive: 1> t := 5. ^ t")
|
||||
{:type "method"
|
||||
:selector "calc"
|
||||
:params (list)
|
||||
:temps (list "t")
|
||||
:pragmas (list
|
||||
{:selector "primitive:"
|
||||
:args (list {:type "lit-int" :value 1})})
|
||||
:body (list
|
||||
{:type "assign" :name "t" :expr {:type "lit-int" :value 5}}
|
||||
{:type "return" :expr {:type "ident" :name "t"}})})
|
||||
|
||||
(st-test
|
||||
"two pragmas"
|
||||
(st-parse-method "m <primitive: 1> <category: 'a'> ^ self")
|
||||
{:type "method"
|
||||
:selector "m"
|
||||
:params (list)
|
||||
:temps (list)
|
||||
:pragmas (list
|
||||
{:selector "primitive:"
|
||||
:args (list {:type "lit-int" :value 1})}
|
||||
{:selector "category:"
|
||||
:args (list {:type "lit-string" :value "a"})})
|
||||
:body (list {:type "return" :expr {:type "self"}})})
|
||||
|
||||
;; ── 5. End-to-end: a small "filed-in" snippet ──
|
||||
(st-test
|
||||
"small filed-in class snippet"
|
||||
(st-parse-chunks
|
||||
"Object subclass: #Account
|
||||
instanceVariableNames: 'balance'!
|
||||
|
||||
!Account methodsFor: 'access'!
|
||||
balance
|
||||
^ balance!
|
||||
|
||||
deposit: amount
|
||||
balance := balance + amount.
|
||||
^ self! !")
|
||||
(list
|
||||
{:kind "expr"
|
||||
:ast {:type "send"
|
||||
:receiver {:type "ident" :name "Object"}
|
||||
:selector "subclass:instanceVariableNames:"
|
||||
:args (list
|
||||
{:type "lit-symbol" :value "Account"}
|
||||
{:type "lit-string" :value "balance"})}}
|
||||
{:kind "blank"}
|
||||
{:kind "expr"
|
||||
:ast {:type "send"
|
||||
:receiver {:type "ident" :name "Account"}
|
||||
:selector "methodsFor:"
|
||||
:args (list {:type "lit-string" :value "access"})}}
|
||||
{:kind "method"
|
||||
:class "Account"
|
||||
:class-side? false
|
||||
:category "access"
|
||||
:ast {:type "method"
|
||||
:selector "balance"
|
||||
:params (list)
|
||||
:temps (list)
|
||||
:pragmas (list)
|
||||
:body (list
|
||||
{:type "return"
|
||||
:expr {:type "ident" :name "balance"}})}}
|
||||
{:kind "method"
|
||||
:class "Account"
|
||||
:class-side? false
|
||||
:category "access"
|
||||
:ast {:type "method"
|
||||
:selector "deposit:"
|
||||
:params (list "amount")
|
||||
:temps (list)
|
||||
:pragmas (list)
|
||||
:body (list
|
||||
{:type "assign"
|
||||
:name "balance"
|
||||
:expr {:type "send"
|
||||
:receiver {:type "ident" :name "balance"}
|
||||
:selector "+"
|
||||
:args (list {:type "ident" :name "amount"})}}
|
||||
{:type "return" :expr {:type "self"}})}}
|
||||
{:kind "end-methods"}))
|
||||
|
||||
(list st-test-pass st-test-fail)
|
||||
182
lib/smalltalk/tests/runtime.sx
Normal file
182
lib/smalltalk/tests/runtime.sx
Normal file
@@ -0,0 +1,182 @@
|
||||
;; Smalltalk runtime tests — class table, type→class mapping, instances.
|
||||
;;
|
||||
;; Reuses helpers (st-test, st-deep=?) from tokenize.sx. Counters reset
|
||||
;; here so this file's summary covers runtime tests only.
|
||||
|
||||
(set! st-test-pass 0)
|
||||
(set! st-test-fail 0)
|
||||
(set! st-test-fails (list))
|
||||
|
||||
;; Fresh hierarchy for every test file.
|
||||
(st-bootstrap-classes!)
|
||||
|
||||
;; ── 1. Bootstrap installed expected classes ──
|
||||
(st-test "Object exists" (st-class-exists? "Object") true)
|
||||
(st-test "Behavior exists" (st-class-exists? "Behavior") true)
|
||||
(st-test "Metaclass exists" (st-class-exists? "Metaclass") true)
|
||||
(st-test "True/False/UndefinedObject"
|
||||
(and
|
||||
(st-class-exists? "True")
|
||||
(st-class-exists? "False")
|
||||
(st-class-exists? "UndefinedObject"))
|
||||
true)
|
||||
(st-test "SmallInteger / Float / Symbol exist"
|
||||
(and
|
||||
(st-class-exists? "SmallInteger")
|
||||
(st-class-exists? "Float")
|
||||
(st-class-exists? "Symbol"))
|
||||
true)
|
||||
(st-test "BlockClosure exists" (st-class-exists? "BlockClosure") true)
|
||||
|
||||
;; ── 2. Superclass chain ──
|
||||
(st-test "Object has no superclass" (st-class-superclass "Object") nil)
|
||||
(st-test "Behavior super = Object" (st-class-superclass "Behavior") "Object")
|
||||
(st-test "True super = Boolean" (st-class-superclass "True") "Boolean")
|
||||
(st-test "Symbol super = String" (st-class-superclass "Symbol") "String")
|
||||
(st-test
|
||||
"String chain"
|
||||
(st-class-chain "String")
|
||||
(list "String" "ArrayedCollection" "SequenceableCollection" "Collection" "Object"))
|
||||
(st-test
|
||||
"SmallInteger chain"
|
||||
(st-class-chain "SmallInteger")
|
||||
(list "SmallInteger" "Integer" "Number" "Magnitude" "Object"))
|
||||
|
||||
;; ── 3. inherits-from? ──
|
||||
(st-test "True inherits from Boolean" (st-class-inherits-from? "True" "Boolean") true)
|
||||
(st-test "True inherits from Object" (st-class-inherits-from? "True" "Object") true)
|
||||
(st-test "True inherits from True" (st-class-inherits-from? "True" "True") true)
|
||||
(st-test
|
||||
"True does not inherit from Number"
|
||||
(st-class-inherits-from? "True" "Number")
|
||||
false)
|
||||
(st-test
|
||||
"Object does not inherit from Number"
|
||||
(st-class-inherits-from? "Object" "Number")
|
||||
false)
|
||||
|
||||
;; ── 4. type→class mapping ──
|
||||
(st-test "class-of nil" (st-class-of nil) "UndefinedObject")
|
||||
(st-test "class-of true" (st-class-of true) "True")
|
||||
(st-test "class-of false" (st-class-of false) "False")
|
||||
(st-test "class-of int" (st-class-of 42) "SmallInteger")
|
||||
(st-test "class-of zero" (st-class-of 0) "SmallInteger")
|
||||
(st-test "class-of negative int" (st-class-of -3) "SmallInteger")
|
||||
(st-test "class-of float" (st-class-of 3.14) "Float")
|
||||
(st-test "class-of string" (st-class-of "hi") "String")
|
||||
(st-test "class-of symbol" (st-class-of (quote foo)) "Symbol")
|
||||
(st-test "class-of list" (st-class-of (list 1 2)) "Array")
|
||||
(st-test "class-of empty list" (st-class-of (list)) "Array")
|
||||
(st-test "class-of lambda" (st-class-of (fn (x) x)) "BlockClosure")
|
||||
(st-test "class-of dict" (st-class-of {:a 1}) "Dictionary")
|
||||
|
||||
;; ── 5. User class definition ──
|
||||
(st-class-define! "Account" "Object" (list "balance" "owner"))
|
||||
(st-class-define! "SavingsAccount" "Account" (list "rate"))
|
||||
|
||||
(st-test "Account exists" (st-class-exists? "Account") true)
|
||||
(st-test "Account super = Object" (st-class-superclass "Account") "Object")
|
||||
(st-test
|
||||
"SavingsAccount chain"
|
||||
(st-class-chain "SavingsAccount")
|
||||
(list "SavingsAccount" "Account" "Object"))
|
||||
(st-test
|
||||
"SavingsAccount own ivars"
|
||||
(get (st-class-get "SavingsAccount") :ivars)
|
||||
(list "rate"))
|
||||
(st-test
|
||||
"SavingsAccount inherited+own ivars"
|
||||
(st-class-all-ivars "SavingsAccount")
|
||||
(list "balance" "owner" "rate"))
|
||||
|
||||
;; ── 6. Instance construction ──
|
||||
(define a1 (st-make-instance "Account"))
|
||||
(st-test "instance is st-instance" (st-instance? a1) true)
|
||||
(st-test "instance class" (get a1 :class) "Account")
|
||||
(st-test "instance ivars start nil" (st-iv-get a1 "balance") nil)
|
||||
(st-test
|
||||
"instance has all expected ivars"
|
||||
(sort (keys (get a1 :ivars)))
|
||||
(sort (list "balance" "owner")))
|
||||
(define a2 (st-iv-set! a1 "balance" 100))
|
||||
(st-test "iv-set! returns updated copy" (st-iv-get a2 "balance") 100)
|
||||
(st-test "iv-set! does not mutate original" (st-iv-get a1 "balance") nil)
|
||||
(st-test "class-of instance" (st-class-of a1) "Account")
|
||||
|
||||
(define s1 (st-make-instance "SavingsAccount"))
|
||||
(st-test
|
||||
"subclass instance has all inherited ivars"
|
||||
(sort (keys (get s1 :ivars)))
|
||||
(sort (list "balance" "owner" "rate")))
|
||||
|
||||
;; ── 7. Method install + lookup ──
|
||||
(st-class-add-method!
|
||||
"Account"
|
||||
"balance"
|
||||
(st-parse-method "balance ^ balance"))
|
||||
(st-class-add-method!
|
||||
"Account"
|
||||
"deposit:"
|
||||
(st-parse-method "deposit: amount balance := balance + amount. ^ self"))
|
||||
|
||||
(st-test
|
||||
"method registered"
|
||||
(has-key? (get (st-class-get "Account") :methods) "balance")
|
||||
true)
|
||||
|
||||
(st-test
|
||||
"method lookup direct"
|
||||
(= (st-method-lookup "Account" "balance" false) nil)
|
||||
false)
|
||||
|
||||
(st-test
|
||||
"method lookup walks superclass"
|
||||
(= (st-method-lookup "SavingsAccount" "deposit:" false) nil)
|
||||
false)
|
||||
|
||||
(st-test
|
||||
"method lookup unknown selector"
|
||||
(st-method-lookup "Account" "frobnicate" false)
|
||||
nil)
|
||||
|
||||
(st-test
|
||||
"method lookup records defining class"
|
||||
(get (st-method-lookup "SavingsAccount" "balance" false) :defining-class)
|
||||
"Account")
|
||||
|
||||
;; SavingsAccount overrides deposit:
|
||||
(st-class-add-method!
|
||||
"SavingsAccount"
|
||||
"deposit:"
|
||||
(st-parse-method "deposit: amount ^ super deposit: amount + 1"))
|
||||
|
||||
(st-test
|
||||
"subclass override picked first"
|
||||
(get (st-method-lookup "SavingsAccount" "deposit:" false) :defining-class)
|
||||
"SavingsAccount")
|
||||
|
||||
(st-test
|
||||
"Account still finds its own deposit:"
|
||||
(get (st-method-lookup "Account" "deposit:" false) :defining-class)
|
||||
"Account")
|
||||
|
||||
;; ── 8. Class-side methods ──
|
||||
(st-class-add-class-method!
|
||||
"Account"
|
||||
"new"
|
||||
(st-parse-method "new ^ super new"))
|
||||
(st-test
|
||||
"class-side lookup"
|
||||
(= (st-method-lookup "Account" "new" true) nil)
|
||||
false)
|
||||
(st-test
|
||||
"instance-side does not find class method"
|
||||
(st-method-lookup "Account" "new" false)
|
||||
nil)
|
||||
|
||||
;; ── 9. Re-bootstrap resets table ──
|
||||
(st-bootstrap-classes!)
|
||||
(st-test "after re-bootstrap Account gone" (st-class-exists? "Account") false)
|
||||
(st-test "after re-bootstrap Object stays" (st-class-exists? "Object") true)
|
||||
|
||||
(list st-test-pass st-test-fail)
|
||||
362
lib/smalltalk/tests/tokenize.sx
Normal file
362
lib/smalltalk/tests/tokenize.sx
Normal file
@@ -0,0 +1,362 @@
|
||||
;; Smalltalk tokenizer tests.
|
||||
;;
|
||||
;; Lightweight runner: each test checks actual vs expected with structural
|
||||
;; equality and accumulates pass/fail counters. Final summary read by
|
||||
;; lib/smalltalk/test.sh.
|
||||
|
||||
(define
|
||||
st-deep=?
|
||||
(fn
|
||||
(a b)
|
||||
(cond
|
||||
((= a b) true)
|
||||
((and (dict? a) (dict? b))
|
||||
(let
|
||||
((ak (keys a)) (bk (keys b)))
|
||||
(if
|
||||
(not (= (len ak) (len bk)))
|
||||
false
|
||||
(every?
|
||||
(fn
|
||||
(k)
|
||||
(and (has-key? b k) (st-deep=? (get a k) (get b k))))
|
||||
ak))))
|
||||
((and (list? a) (list? b))
|
||||
(if
|
||||
(not (= (len a) (len b)))
|
||||
false
|
||||
(let
|
||||
((i 0) (ok true))
|
||||
(begin
|
||||
(define
|
||||
de-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and ok (< i (len a)))
|
||||
(begin
|
||||
(when
|
||||
(not (st-deep=? (nth a i) (nth b i)))
|
||||
(set! ok false))
|
||||
(set! i (+ i 1))
|
||||
(de-loop)))))
|
||||
(de-loop)
|
||||
ok))))
|
||||
(:else false))))
|
||||
|
||||
(define st-test-pass 0)
|
||||
(define st-test-fail 0)
|
||||
(define st-test-fails (list))
|
||||
|
||||
(define
|
||||
st-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(st-deep=? actual expected)
|
||||
(set! st-test-pass (+ st-test-pass 1))
|
||||
(begin
|
||||
(set! st-test-fail (+ st-test-fail 1))
|
||||
(append! st-test-fails {:actual actual :expected expected :name name})))))
|
||||
|
||||
;; Strip eof and project to just :type/:value.
|
||||
(define
|
||||
st-toks
|
||||
(fn
|
||||
(src)
|
||||
(map
|
||||
(fn (tok) {:type (get tok :type) :value (get tok :value)})
|
||||
(filter
|
||||
(fn (tok) (not (= (get tok :type) "eof")))
|
||||
(st-tokenize src)))))
|
||||
|
||||
;; ── 1. Whitespace / empty ──
|
||||
(st-test "empty input" (st-toks "") (list))
|
||||
(st-test "all whitespace" (st-toks " \t\n ") (list))
|
||||
|
||||
;; ── 2. Identifiers ──
|
||||
(st-test
|
||||
"lowercase ident"
|
||||
(st-toks "foo")
|
||||
(list {:type "ident" :value "foo"}))
|
||||
|
||||
(st-test
|
||||
"capitalised ident"
|
||||
(st-toks "Foo")
|
||||
(list {:type "ident" :value "Foo"}))
|
||||
|
||||
(st-test
|
||||
"underscore ident"
|
||||
(st-toks "_x")
|
||||
(list {:type "ident" :value "_x"}))
|
||||
|
||||
(st-test
|
||||
"digits in ident"
|
||||
(st-toks "foo123")
|
||||
(list {:type "ident" :value "foo123"}))
|
||||
|
||||
(st-test
|
||||
"two idents separated"
|
||||
(st-toks "foo bar")
|
||||
(list {:type "ident" :value "foo"} {:type "ident" :value "bar"}))
|
||||
|
||||
;; ── 3. Keyword selectors ──
|
||||
(st-test
|
||||
"keyword selector"
|
||||
(st-toks "foo:")
|
||||
(list {:type "keyword" :value "foo:"}))
|
||||
|
||||
(st-test
|
||||
"keyword call"
|
||||
(st-toks "x at: 1")
|
||||
(list
|
||||
{:type "ident" :value "x"}
|
||||
{:type "keyword" :value "at:"}
|
||||
{:type "number" :value 1}))
|
||||
|
||||
(st-test
|
||||
"two-keyword chain stays separate"
|
||||
(st-toks "at: 1 put: 2")
|
||||
(list
|
||||
{:type "keyword" :value "at:"}
|
||||
{:type "number" :value 1}
|
||||
{:type "keyword" :value "put:"}
|
||||
{:type "number" :value 2}))
|
||||
|
||||
(st-test
|
||||
"ident then assign — not a keyword"
|
||||
(st-toks "x := 1")
|
||||
(list
|
||||
{:type "ident" :value "x"}
|
||||
{:type "assign" :value ":="}
|
||||
{:type "number" :value 1}))
|
||||
|
||||
;; ── 4. Numbers ──
|
||||
(st-test
|
||||
"integer"
|
||||
(st-toks "42")
|
||||
(list {:type "number" :value 42}))
|
||||
|
||||
(st-test
|
||||
"float"
|
||||
(st-toks "3.14")
|
||||
(list {:type "number" :value 3.14}))
|
||||
|
||||
(st-test
|
||||
"hex radix"
|
||||
(st-toks "16rFF")
|
||||
(list
|
||||
{:type "number"
|
||||
:value
|
||||
{:radix 16 :digits "FF" :value 255 :kind "radix"}}))
|
||||
|
||||
(st-test
|
||||
"binary radix"
|
||||
(st-toks "2r1011")
|
||||
(list
|
||||
{:type "number"
|
||||
:value
|
||||
{:radix 2 :digits "1011" :value 11 :kind "radix"}}))
|
||||
|
||||
(st-test
|
||||
"exponent"
|
||||
(st-toks "1e3")
|
||||
(list {:type "number" :value 1000}))
|
||||
|
||||
(st-test
|
||||
"negative exponent (parser handles minus)"
|
||||
(st-toks "1.5e-2")
|
||||
(list {:type "number" :value 0.015}))
|
||||
|
||||
;; ── 5. Strings ──
|
||||
(st-test
|
||||
"simple string"
|
||||
(st-toks "'hi'")
|
||||
(list {:type "string" :value "hi"}))
|
||||
|
||||
(st-test
|
||||
"empty string"
|
||||
(st-toks "''")
|
||||
(list {:type "string" :value ""}))
|
||||
|
||||
(st-test
|
||||
"doubled-quote escape"
|
||||
(st-toks "'a''b'")
|
||||
(list {:type "string" :value "a'b"}))
|
||||
|
||||
;; ── 6. Characters ──
|
||||
(st-test
|
||||
"char literal letter"
|
||||
(st-toks "$a")
|
||||
(list {:type "char" :value "a"}))
|
||||
|
||||
(st-test
|
||||
"char literal punct"
|
||||
(st-toks "$$")
|
||||
(list {:type "char" :value "$"}))
|
||||
|
||||
(st-test
|
||||
"char literal space"
|
||||
(st-toks "$ ")
|
||||
(list {:type "char" :value " "}))
|
||||
|
||||
;; ── 7. Symbols ──
|
||||
(st-test
|
||||
"symbol ident"
|
||||
(st-toks "#foo")
|
||||
(list {:type "symbol" :value "foo"}))
|
||||
|
||||
(st-test
|
||||
"symbol binary"
|
||||
(st-toks "#+")
|
||||
(list {:type "symbol" :value "+"}))
|
||||
|
||||
(st-test
|
||||
"symbol arrow"
|
||||
(st-toks "#->")
|
||||
(list {:type "symbol" :value "->"}))
|
||||
|
||||
(st-test
|
||||
"symbol keyword chain"
|
||||
(st-toks "#at:put:")
|
||||
(list {:type "symbol" :value "at:put:"}))
|
||||
|
||||
(st-test
|
||||
"quoted symbol with spaces"
|
||||
(st-toks "#'foo bar'")
|
||||
(list {:type "symbol" :value "foo bar"}))
|
||||
|
||||
;; ── 8. Literal arrays / byte arrays ──
|
||||
(st-test
|
||||
"literal array open"
|
||||
(st-toks "#(1 2)")
|
||||
(list
|
||||
{:type "array-open" :value "#("}
|
||||
{:type "number" :value 1}
|
||||
{:type "number" :value 2}
|
||||
{:type "rparen" :value ")"}))
|
||||
|
||||
(st-test
|
||||
"byte array open"
|
||||
(st-toks "#[1 2 3]")
|
||||
(list
|
||||
{:type "byte-array-open" :value "#["}
|
||||
{:type "number" :value 1}
|
||||
{:type "number" :value 2}
|
||||
{:type "number" :value 3}
|
||||
{:type "rbracket" :value "]"}))
|
||||
|
||||
;; ── 9. Binary selectors ──
|
||||
(st-test "plus" (st-toks "+") (list {:type "binary" :value "+"}))
|
||||
(st-test "minus" (st-toks "-") (list {:type "binary" :value "-"}))
|
||||
(st-test "star" (st-toks "*") (list {:type "binary" :value "*"}))
|
||||
(st-test "double-equal" (st-toks "==") (list {:type "binary" :value "=="}))
|
||||
(st-test "leq" (st-toks "<=") (list {:type "binary" :value "<="}))
|
||||
(st-test "geq" (st-toks ">=") (list {:type "binary" :value ">="}))
|
||||
(st-test "neq" (st-toks "~=") (list {:type "binary" :value "~="}))
|
||||
(st-test "arrow" (st-toks "->") (list {:type "binary" :value "->"}))
|
||||
(st-test "comma" (st-toks ",") (list {:type "binary" :value ","}))
|
||||
|
||||
(st-test
|
||||
"binary in expression"
|
||||
(st-toks "a + b")
|
||||
(list
|
||||
{:type "ident" :value "a"}
|
||||
{:type "binary" :value "+"}
|
||||
{:type "ident" :value "b"}))
|
||||
|
||||
;; ── 10. Punctuation ──
|
||||
(st-test "lparen" (st-toks "(") (list {:type "lparen" :value "("}))
|
||||
(st-test "rparen" (st-toks ")") (list {:type "rparen" :value ")"}))
|
||||
(st-test "lbracket" (st-toks "[") (list {:type "lbracket" :value "["}))
|
||||
(st-test "rbracket" (st-toks "]") (list {:type "rbracket" :value "]"}))
|
||||
(st-test "lbrace" (st-toks "{") (list {:type "lbrace" :value "{"}))
|
||||
(st-test "rbrace" (st-toks "}") (list {:type "rbrace" :value "}"}))
|
||||
(st-test "period" (st-toks ".") (list {:type "period" :value "."}))
|
||||
(st-test "semi" (st-toks ";") (list {:type "semi" :value ";"}))
|
||||
(st-test "bar" (st-toks "|") (list {:type "bar" :value "|"}))
|
||||
(st-test "caret" (st-toks "^") (list {:type "caret" :value "^"}))
|
||||
(st-test "bang" (st-toks "!") (list {:type "bang" :value "!"}))
|
||||
(st-test "colon" (st-toks ":") (list {:type "colon" :value ":"}))
|
||||
(st-test "assign" (st-toks ":=") (list {:type "assign" :value ":="}))
|
||||
|
||||
;; ── 11. Comments ──
|
||||
(st-test "comment skipped" (st-toks "\"hello\"") (list))
|
||||
(st-test
|
||||
"comment between tokens"
|
||||
(st-toks "a \"comment\" b")
|
||||
(list {:type "ident" :value "a"} {:type "ident" :value "b"}))
|
||||
(st-test
|
||||
"multi-line comment"
|
||||
(st-toks "\"line1\nline2\"42")
|
||||
(list {:type "number" :value 42}))
|
||||
|
||||
;; ── 12. Compound expressions ──
|
||||
(st-test
|
||||
"block with params"
|
||||
(st-toks "[:a :b | a + b]")
|
||||
(list
|
||||
{:type "lbracket" :value "["}
|
||||
{:type "colon" :value ":"}
|
||||
{:type "ident" :value "a"}
|
||||
{:type "colon" :value ":"}
|
||||
{:type "ident" :value "b"}
|
||||
{:type "bar" :value "|"}
|
||||
{:type "ident" :value "a"}
|
||||
{:type "binary" :value "+"}
|
||||
{:type "ident" :value "b"}
|
||||
{:type "rbracket" :value "]"}))
|
||||
|
||||
(st-test
|
||||
"cascade"
|
||||
(st-toks "x m1; m2")
|
||||
(list
|
||||
{:type "ident" :value "x"}
|
||||
{:type "ident" :value "m1"}
|
||||
{:type "semi" :value ";"}
|
||||
{:type "ident" :value "m2"}))
|
||||
|
||||
(st-test
|
||||
"method body return"
|
||||
(st-toks "^ self foo")
|
||||
(list
|
||||
{:type "caret" :value "^"}
|
||||
{:type "ident" :value "self"}
|
||||
{:type "ident" :value "foo"}))
|
||||
|
||||
(st-test
|
||||
"class declaration head"
|
||||
(st-toks "Object subclass: #Foo")
|
||||
(list
|
||||
{:type "ident" :value "Object"}
|
||||
{:type "keyword" :value "subclass:"}
|
||||
{:type "symbol" :value "Foo"}))
|
||||
|
||||
(st-test
|
||||
"temp declaration"
|
||||
(st-toks "| t1 t2 |")
|
||||
(list
|
||||
{:type "bar" :value "|"}
|
||||
{:type "ident" :value "t1"}
|
||||
{:type "ident" :value "t2"}
|
||||
{:type "bar" :value "|"}))
|
||||
|
||||
(st-test
|
||||
"chunk separator"
|
||||
(st-toks "Foo bar !")
|
||||
(list
|
||||
{:type "ident" :value "Foo"}
|
||||
{:type "ident" :value "bar"}
|
||||
{:type "bang" :value "!"}))
|
||||
|
||||
(st-test
|
||||
"keyword call with binary precedence"
|
||||
(st-toks "x foo: 1 + 2")
|
||||
(list
|
||||
{:type "ident" :value "x"}
|
||||
{:type "keyword" :value "foo:"}
|
||||
{:type "number" :value 1}
|
||||
{:type "binary" :value "+"}
|
||||
{:type "number" :value 2}))
|
||||
|
||||
(list st-test-pass st-test-fail)
|
||||
366
lib/smalltalk/tokenizer.sx
Normal file
366
lib/smalltalk/tokenizer.sx
Normal file
@@ -0,0 +1,366 @@
|
||||
;; Smalltalk tokenizer.
|
||||
;;
|
||||
;; Token types:
|
||||
;; ident identifier (foo, Foo, _x)
|
||||
;; keyword selector keyword (foo:) — value is "foo:" with the colon
|
||||
;; binary binary selector chars run together (+, ==, ->, <=, ~=, ...)
|
||||
;; number integer or float; radix integers like 16rFF supported
|
||||
;; string 'hello''world' style
|
||||
;; char $c
|
||||
;; symbol #foo, #foo:bar:, #+, #'with spaces'
|
||||
;; array-open #(
|
||||
;; byte-array-open #[
|
||||
;; lparen rparen lbracket rbracket lbrace rbrace
|
||||
;; period semi bar caret colon assign bang
|
||||
;; eof
|
||||
;;
|
||||
;; Comments "…" are skipped.
|
||||
|
||||
(define st-make-token (fn (type value pos) {:type type :value value :pos pos}))
|
||||
|
||||
(define st-digit? (fn (c) (and (not (= c nil)) (>= c "0") (<= c "9"))))
|
||||
|
||||
(define
|
||||
st-letter?
|
||||
(fn
|
||||
(c)
|
||||
(and
|
||||
(not (= c nil))
|
||||
(or (and (>= c "a") (<= c "z")) (and (>= c "A") (<= c "Z"))))))
|
||||
|
||||
(define st-ident-start? (fn (c) (or (st-letter? c) (= c "_"))))
|
||||
|
||||
(define st-ident-char? (fn (c) (or (st-ident-start? c) (st-digit? c))))
|
||||
|
||||
(define st-ws? (fn (c) (or (= c " ") (= c "\t") (= c "\n") (= c "\r"))))
|
||||
|
||||
(define
|
||||
st-binary-chars
|
||||
(list "+" "-" "*" "/" "\\" "~" "<" ">" "=" "@" "%" "&" "?" ","))
|
||||
|
||||
(define
|
||||
st-binary-char?
|
||||
(fn (c) (and (not (= c nil)) (contains? st-binary-chars c))))
|
||||
|
||||
(define
|
||||
st-radix-digit?
|
||||
(fn
|
||||
(c)
|
||||
(and
|
||||
(not (= c nil))
|
||||
(or (st-digit? c) (and (>= c "A") (<= c "Z"))))))
|
||||
|
||||
(define
|
||||
st-tokenize
|
||||
(fn
|
||||
(src)
|
||||
(let
|
||||
((tokens (list)) (pos 0) (src-len (len src)))
|
||||
(define
|
||||
pk
|
||||
(fn
|
||||
(offset)
|
||||
(if (< (+ pos offset) src-len) (nth src (+ pos offset)) nil)))
|
||||
(define cur (fn () (pk 0)))
|
||||
(define advance! (fn (n) (set! pos (+ pos n))))
|
||||
(define
|
||||
push!
|
||||
(fn
|
||||
(type value start)
|
||||
(append! tokens (st-make-token type value start))))
|
||||
(define
|
||||
skip-comment!
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((>= pos src-len) nil)
|
||||
((= (cur) "\"") (advance! 1))
|
||||
(else (begin (advance! 1) (skip-comment!))))))
|
||||
(define
|
||||
skip-ws!
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((>= pos src-len) nil)
|
||||
((st-ws? (cur)) (begin (advance! 1) (skip-ws!)))
|
||||
((= (cur) "\"") (begin (advance! 1) (skip-comment!) (skip-ws!)))
|
||||
(else nil))))
|
||||
(define
|
||||
read-ident-chars!
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (< pos src-len) (st-ident-char? (cur)))
|
||||
(begin (advance! 1) (read-ident-chars!)))))
|
||||
(define
|
||||
read-decimal-digits!
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (< pos src-len) (st-digit? (cur)))
|
||||
(begin (advance! 1) (read-decimal-digits!)))))
|
||||
(define
|
||||
read-radix-digits!
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (< pos src-len) (st-radix-digit? (cur)))
|
||||
(begin (advance! 1) (read-radix-digits!)))))
|
||||
(define
|
||||
read-exp-part!
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and
|
||||
(< pos src-len)
|
||||
(or (= (cur) "e") (= (cur) "E"))
|
||||
(let
|
||||
((p1 (pk 1)) (p2 (pk 2)))
|
||||
(or
|
||||
(st-digit? p1)
|
||||
(and (or (= p1 "+") (= p1 "-")) (st-digit? p2)))))
|
||||
(begin
|
||||
(advance! 1)
|
||||
(when
|
||||
(and (< pos src-len) (or (= (cur) "+") (= (cur) "-")))
|
||||
(advance! 1))
|
||||
(read-decimal-digits!)))))
|
||||
(define
|
||||
read-number
|
||||
(fn
|
||||
(start)
|
||||
(begin
|
||||
(read-decimal-digits!)
|
||||
(cond
|
||||
((and (< pos src-len) (= (cur) "r"))
|
||||
(let
|
||||
((base-str (slice src start pos)))
|
||||
(begin
|
||||
(advance! 1)
|
||||
(let
|
||||
((rstart pos))
|
||||
(begin
|
||||
(read-radix-digits!)
|
||||
(let
|
||||
((digits (slice src rstart pos)))
|
||||
{:radix (parse-number base-str)
|
||||
:digits digits
|
||||
:value (parse-radix base-str digits)
|
||||
:kind "radix"}))))))
|
||||
((and
|
||||
(< pos src-len)
|
||||
(= (cur) ".")
|
||||
(st-digit? (pk 1)))
|
||||
(begin
|
||||
(advance! 1)
|
||||
(read-decimal-digits!)
|
||||
(read-exp-part!)
|
||||
(parse-number (slice src start pos))))
|
||||
(else
|
||||
(begin
|
||||
(read-exp-part!)
|
||||
(parse-number (slice src start pos))))))))
|
||||
(define
|
||||
parse-radix
|
||||
(fn
|
||||
(base-str digits)
|
||||
(let
|
||||
((base (parse-number base-str))
|
||||
(chars digits)
|
||||
(n-len (len digits))
|
||||
(idx 0)
|
||||
(acc 0))
|
||||
(begin
|
||||
(define
|
||||
rd-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(< idx n-len)
|
||||
(let
|
||||
((c (nth chars idx)))
|
||||
(let
|
||||
((d (cond
|
||||
((and (>= c "0") (<= c "9")) (- (char-code c) 48))
|
||||
((and (>= c "A") (<= c "Z")) (- (char-code c) 55))
|
||||
(else 0))))
|
||||
(begin
|
||||
(set! acc (+ (* acc base) d))
|
||||
(set! idx (+ idx 1))
|
||||
(rd-loop)))))))
|
||||
(rd-loop)
|
||||
acc))))
|
||||
(define
|
||||
read-string
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((chars (list)))
|
||||
(begin
|
||||
(advance! 1)
|
||||
(define
|
||||
loop
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((>= pos src-len) nil)
|
||||
((= (cur) "'")
|
||||
(cond
|
||||
((= (pk 1) "'")
|
||||
(begin
|
||||
(append! chars "'")
|
||||
(advance! 2)
|
||||
(loop)))
|
||||
(else (advance! 1))))
|
||||
(else
|
||||
(begin (append! chars (cur)) (advance! 1) (loop))))))
|
||||
(loop)
|
||||
(join "" chars)))))
|
||||
(define
|
||||
read-binary-run!
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((start pos))
|
||||
(begin
|
||||
(define
|
||||
bin-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (< pos src-len) (st-binary-char? (cur)))
|
||||
(begin (advance! 1) (bin-loop)))))
|
||||
(bin-loop)
|
||||
(slice src start pos)))))
|
||||
(define
|
||||
read-symbol
|
||||
(fn
|
||||
(start)
|
||||
(cond
|
||||
;; Quoted symbol: #'whatever'
|
||||
((= (cur) "'")
|
||||
(let ((s (read-string))) (push! "symbol" s start)))
|
||||
;; Binary-char symbol: #+, #==, #->, #|
|
||||
((or (st-binary-char? (cur)) (= (cur) "|"))
|
||||
(let ((b (read-binary-run!)))
|
||||
(cond
|
||||
((= b "")
|
||||
;; lone | wasn't binary; consume it
|
||||
(begin (advance! 1) (push! "symbol" "|" start)))
|
||||
(else (push! "symbol" b start)))))
|
||||
;; Identifier or keyword chain: #foo, #foo:bar:
|
||||
((st-ident-start? (cur))
|
||||
(let ((id-start pos))
|
||||
(begin
|
||||
(read-ident-chars!)
|
||||
(define
|
||||
kw-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (< pos src-len) (= (cur) ":"))
|
||||
(begin
|
||||
(advance! 1)
|
||||
(when
|
||||
(and (< pos src-len) (st-ident-start? (cur)))
|
||||
(begin (read-ident-chars!) (kw-loop)))))))
|
||||
(kw-loop)
|
||||
(push! "symbol" (slice src id-start pos) start))))
|
||||
(else
|
||||
(error
|
||||
(str "st-tokenize: bad symbol at " pos))))))
|
||||
(define
|
||||
step
|
||||
(fn
|
||||
()
|
||||
(begin
|
||||
(skip-ws!)
|
||||
(when
|
||||
(< pos src-len)
|
||||
(let
|
||||
((start pos) (c (cur)))
|
||||
(cond
|
||||
;; Identifier or keyword
|
||||
((st-ident-start? c)
|
||||
(begin
|
||||
(read-ident-chars!)
|
||||
(let
|
||||
((word (slice src start pos)))
|
||||
(cond
|
||||
;; ident immediately followed by ':' (and not ':=') => keyword
|
||||
((and
|
||||
(< pos src-len)
|
||||
(= (cur) ":")
|
||||
(not (= (pk 1) "=")))
|
||||
(begin
|
||||
(advance! 1)
|
||||
(push!
|
||||
"keyword"
|
||||
(str word ":")
|
||||
start)))
|
||||
(else (push! "ident" word start))))
|
||||
(step)))
|
||||
;; Number
|
||||
((st-digit? c)
|
||||
(let
|
||||
((v (read-number start)))
|
||||
(begin (push! "number" v start) (step))))
|
||||
;; String
|
||||
((= c "'")
|
||||
(let
|
||||
((s (read-string)))
|
||||
(begin (push! "string" s start) (step))))
|
||||
;; Character literal
|
||||
((= c "$")
|
||||
(cond
|
||||
((>= (+ pos 1) src-len)
|
||||
(error (str "st-tokenize: $ at end of input")))
|
||||
(else
|
||||
(begin
|
||||
(advance! 1)
|
||||
(push! "char" (cur) start)
|
||||
(advance! 1)
|
||||
(step)))))
|
||||
;; Symbol or array literal
|
||||
((= c "#")
|
||||
(cond
|
||||
((= (pk 1) "(")
|
||||
(begin (advance! 2) (push! "array-open" "#(" start) (step)))
|
||||
((= (pk 1) "[")
|
||||
(begin (advance! 2) (push! "byte-array-open" "#[" start) (step)))
|
||||
(else
|
||||
(begin (advance! 1) (read-symbol start) (step)))))
|
||||
;; Assignment := or bare colon
|
||||
((= c ":")
|
||||
(cond
|
||||
((= (pk 1) "=")
|
||||
(begin (advance! 2) (push! "assign" ":=" start) (step)))
|
||||
(else
|
||||
(begin (advance! 1) (push! "colon" ":" start) (step)))))
|
||||
;; Single-char structural punctuation
|
||||
((= c "(") (begin (advance! 1) (push! "lparen" "(" start) (step)))
|
||||
((= c ")") (begin (advance! 1) (push! "rparen" ")" start) (step)))
|
||||
((= c "[") (begin (advance! 1) (push! "lbracket" "[" start) (step)))
|
||||
((= c "]") (begin (advance! 1) (push! "rbracket" "]" start) (step)))
|
||||
((= c "{") (begin (advance! 1) (push! "lbrace" "{" start) (step)))
|
||||
((= c "}") (begin (advance! 1) (push! "rbrace" "}" start) (step)))
|
||||
((= c ".") (begin (advance! 1) (push! "period" "." start) (step)))
|
||||
((= c ";") (begin (advance! 1) (push! "semi" ";" start) (step)))
|
||||
((= c "|") (begin (advance! 1) (push! "bar" "|" start) (step)))
|
||||
((= c "^") (begin (advance! 1) (push! "caret" "^" start) (step)))
|
||||
((= c "!") (begin (advance! 1) (push! "bang" "!" start) (step)))
|
||||
;; Binary selector run
|
||||
((st-binary-char? c)
|
||||
(let
|
||||
((b (read-binary-run!)))
|
||||
(begin (push! "binary" b start) (step))))
|
||||
(else
|
||||
(error
|
||||
(str
|
||||
"st-tokenize: unexpected char "
|
||||
c
|
||||
" at "
|
||||
pos)))))))))
|
||||
(step)
|
||||
(push! "eof" nil pos)
|
||||
tokens)))
|
||||
77
plans/agent-briefings/smalltalk-loop.md
Normal file
77
plans/agent-briefings/smalltalk-loop.md
Normal file
@@ -0,0 +1,77 @@
|
||||
# smalltalk-on-sx loop agent (single agent, queue-driven)
|
||||
|
||||
Role: iterates `plans/smalltalk-on-sx.md` forever. Message-passing OO + **blocks with non-local return** on delimited continuations. Non-local return is the headline showcase — every other Smalltalk reinvents it on the host stack; on SX it falls out of the captured method-return continuation.
|
||||
|
||||
```
|
||||
description: smalltalk-on-sx queue loop
|
||||
subagent_type: general-purpose
|
||||
run_in_background: true
|
||||
isolation: worktree
|
||||
```
|
||||
|
||||
## Prompt
|
||||
|
||||
You are the sole background agent working `/root/rose-ash/plans/smalltalk-on-sx.md`. Isolated worktree, forever, one commit per feature. Never push.
|
||||
|
||||
## Restart baseline — check before iterating
|
||||
|
||||
1. Read `plans/smalltalk-on-sx.md` — roadmap + Progress log.
|
||||
2. `ls lib/smalltalk/` — pick up from the most advanced file.
|
||||
3. If `lib/smalltalk/tests/*.sx` exist, run them. Green before new work.
|
||||
4. If `lib/smalltalk/scoreboard.md` exists, that's your baseline.
|
||||
|
||||
## The queue
|
||||
|
||||
Phase order per `plans/smalltalk-on-sx.md`:
|
||||
|
||||
- **Phase 1** — tokenizer + parser (chunk format, identifiers, keywords `foo:`, binary selectors, `#sym`, `#(…)`, `$c`, blocks `[:a | …]`, cascades, message precedence)
|
||||
- **Phase 2** — object model + sequential eval (class table bootstrap, message dispatch, `super`, `doesNotUnderstand:`, instance variables)
|
||||
- **Phase 3** — **THE SHOWCASE**: blocks with non-local return via captured method-return continuation. `whileTrue:` / `ifTrue:ifFalse:` as block sends. 5 classic programs (eight-queens, quicksort, mandelbrot, life, fibonacci) green.
|
||||
- **Phase 4** — reflection + MOP: `perform:`, `respondsTo:`, runtime method addition, `becomeForward:`, `Exception` / `on:do:` / `ensure:` on top of `handler-bind`/`raise`
|
||||
- **Phase 5** — collections + numeric tower + streams
|
||||
- **Phase 6** — port SUnit, vendor Pharo Kernel-Tests slice, drive corpus to 200+
|
||||
- **Phase 7** — speed (optional): inline caching, block intrinsification
|
||||
|
||||
Within a phase, pick the checkbox that unlocks the most tests per effort.
|
||||
|
||||
Every iteration: implement → test → commit → tick `[ ]` → Progress log → next.
|
||||
|
||||
## Ground rules (hard)
|
||||
|
||||
- **Scope:** only `lib/smalltalk/**` and `plans/smalltalk-on-sx.md`. Do **not** edit `spec/`, `hosts/`, `shared/`, other `lib/<lang>/` dirs, `lib/stdlib.sx`, or `lib/` root. Smalltalk primitives go in `lib/smalltalk/runtime.sx`.
|
||||
- **NEVER call `sx_build`.** 600s watchdog. If sx_server binary broken → Blockers entry, stop.
|
||||
- **Shared-file issues** → plan's Blockers with minimal repro.
|
||||
- **Delimited continuations** are in `lib/callcc.sx` + `spec/evaluator.sx` Step 5. `sx_summarise` spec/evaluator.sx first — 2300+ lines.
|
||||
- **SX files:** `sx-tree` MCP tools ONLY. `sx_validate` after edits.
|
||||
- **Worktree:** commit locally. Never push. Never touch `main`.
|
||||
- **Commit granularity:** one feature per commit.
|
||||
- **Plan file:** update Progress log + tick boxes every commit.
|
||||
|
||||
## Smalltalk-specific gotchas
|
||||
|
||||
- **Method invocation captures `^k`** — the return continuation. Bind it as the block's escape token. `^expr` from inside any nested block invokes that captured `^k`. Escape past method return raises `BlockContext>>cannotReturn:`.
|
||||
- **Blocks are lambdas + escape token**, not bare lambdas. `value`/`value:`/… invoke the lambda; `^` invokes the escape.
|
||||
- **`ifTrue:` / `ifFalse:` / `whileTrue:` are ordinary block sends** — no special form. The runtime intrinsifies them in the JIT path (Tier 1 of bytecode expansion already covers this pattern).
|
||||
- **Cascade** `r m1; m2; m3` desugars to `(let ((tmp r)) (st-send tmp 'm1 ()) (st-send tmp 'm2 ()) (st-send tmp 'm3 ()))`. Result is the cascade's last send (or first, depending on parser variant — pick one and document).
|
||||
- **`super` send** looks up starting from the *defining* class's superclass, not the receiver class. Stash the defining class on the method record.
|
||||
- **Selectors are interned symbols.** Use SX symbols.
|
||||
- **Receiver dispatch:** tagged ints / floats / strings / symbols / `nil` / `true` / `false` aren't boxed. Their classes (`SmallInteger`, `Float`, `String`, `Symbol`, `UndefinedObject`, `True`, `False`) are looked up by SX type-of, not by an `:class` field.
|
||||
- **Method precedence:** unary > binary > keyword. `3 + 4 factorial` is `3 + (4 factorial)`. `a foo: b bar` is `a foo: (b bar)` (keyword absorbs trailing unary).
|
||||
- **Image / fileIn / become: between sessions** = out of scope. One-way `becomeForward:` only.
|
||||
- **Test corpus:** ~200 hand-written + a slice of Pharo Kernel-Tests. Place programs in `lib/smalltalk/tests/programs/`.
|
||||
|
||||
## General gotchas (all loops)
|
||||
|
||||
- SX `do` = R7RS iteration. Use `begin` for multi-expr sequences.
|
||||
- `cond`/`when`/`let` clauses evaluate only the last expr.
|
||||
- `type-of` on user fn returns `"lambda"`.
|
||||
- Shell heredoc `||` gets eaten — escape or use `case`.
|
||||
|
||||
## Style
|
||||
|
||||
- No comments in `.sx` unless non-obvious.
|
||||
- No new planning docs — update `plans/smalltalk-on-sx.md` inline.
|
||||
- Short, factual commit messages (`smalltalk: tokenizer + 56 tests`).
|
||||
- One feature per iteration. Commit. Log. Next.
|
||||
|
||||
Go. Read the plan; find first `[ ]`; implement.
|
||||
120
plans/smalltalk-on-sx.md
Normal file
120
plans/smalltalk-on-sx.md
Normal file
@@ -0,0 +1,120 @@
|
||||
# Smalltalk-on-SX: blocks with non-local return on delimited continuations
|
||||
|
||||
The headline showcase is **blocks** — Smalltalk's closures with non-local return (`^expr` aborts the enclosing *method*, not the block). Every other Smalltalk on top of a host VM (RSqueak on PyPy, GemStone on C, Maxine on Java) reinvents non-local return on whatever stack discipline the host gives them. On SX it's a one-liner: a block holds a captured continuation; `^` just invokes it. Message-passing OO falls out cheaply on top of the existing component / dispatch machinery.
|
||||
|
||||
End-state goal: ANSI-ish Smalltalk-80 subset, SUnit working, ~200 hand-written tests + a vendored slice of the Pharo kernel tests, classic corpus (eight queens, quicksort, mandelbrot, Conway's Life).
|
||||
|
||||
## Scope decisions (defaults — override by editing before we spawn)
|
||||
|
||||
- **Syntax:** Pharo / Squeak chunk format (`!` separators, `Object subclass: #Foo …`). No fileIn/fileOut images — text source only.
|
||||
- **Conformance:** ANSI X3J20 *as a target*, not bug-for-bug Squeak. "Reads like Smalltalk, runs like Smalltalk."
|
||||
- **Test corpus:** SUnit ported to SX-Smalltalk + custom programs + a curated slice of Pharo `Kernel-Tests` / `Collections-Tests`.
|
||||
- **Image:** out of scope. Source-only. No `become:` between sessions, no snapshotting.
|
||||
- **Reflection:** `class`, `respondsTo:`, `perform:`, `doesNotUnderstand:` in. `become:` (object-identity swap) **in** — it's a good CEK exercise. Method modification at runtime in.
|
||||
- **GUI / Morphic / threads:** out entirely.
|
||||
|
||||
## Ground rules
|
||||
|
||||
- **Scope:** only touch `lib/smalltalk/**` and `plans/smalltalk-on-sx.md`. Don't edit `spec/`, `hosts/`, `shared/`, or any other `lib/<lang>/**`. Smalltalk primitives go in `lib/smalltalk/runtime.sx`.
|
||||
- **SX files:** use `sx-tree` MCP tools only.
|
||||
- **Commits:** one feature per commit. Keep `## Progress log` updated and tick roadmap boxes.
|
||||
|
||||
## Architecture sketch
|
||||
|
||||
```
|
||||
Smalltalk source
|
||||
│
|
||||
▼
|
||||
lib/smalltalk/tokenizer.sx — selectors, keywords, literals, $c, #sym, #(…), $'…'
|
||||
│
|
||||
▼
|
||||
lib/smalltalk/parser.sx — AST: classes, methods, blocks, cascades, sends
|
||||
│
|
||||
▼
|
||||
lib/smalltalk/transpile.sx — AST → SX AST (entry: smalltalk-eval-ast)
|
||||
│
|
||||
▼
|
||||
lib/smalltalk/runtime.sx — class table, MOP, dispatch, primitives
|
||||
```
|
||||
|
||||
Core mapping:
|
||||
- **Class** = SX dict `{:name :superclass :ivars :methods :class-methods :metaclass}`. Class table is a flat dict keyed by class name.
|
||||
- **Object** = SX dict `{:class :ivars}` — `ivars` keyed by symbol. Tagged ints / floats / strings / symbols are not boxed; their class is looked up by SX type.
|
||||
- **Method** = SX lambda closing over a `self` binding + temps. Body wrapped in a delimited continuation so `^` can escape.
|
||||
- **Message send** = `(st-send receiver selector args)` — does class-table lookup, walks superclass chain, falls back to `doesNotUnderstand:` with a `Message` object.
|
||||
- **Block** `[:x | … ^v … ]` = lambda + captured `^k` (the method-return continuation). Invoking `^` calls `k`; outer block invocation past method return raises `BlockContext>>cannotReturn:`.
|
||||
- **Cascade** `r m1; m2; m3` = `(let ((tmp r)) (st-send tmp 'm1 ()) (st-send tmp 'm2 ()) (st-send tmp 'm3 ()))`.
|
||||
- **`ifTrue:ifFalse:` / `whileTrue:`** = ordinary block sends; the runtime intrinsifies them in the JIT path so they compile to native branches (Tier 1 of bytecode expansion already covers this pattern).
|
||||
- **`become:`** = swap two object identities everywhere — in SX this is a heap walk, but we restrict to `oneWayBecome:` (cheap: rewrite class field) by default.
|
||||
|
||||
## Roadmap
|
||||
|
||||
### Phase 1 — tokenizer + parser
|
||||
- [x] Tokenizer: identifiers, keywords (`foo:`), binary selectors (`+`, `==`, `,`, `->`, `~=` etc.), numbers (radix `16r1F`; **scaled `1.5s2` deferred**), strings `'…''…'`, characters `$c`, symbols `#foo` `#'foo bar'` `#+`, byte arrays `#[1 2 3]` (open token), literal arrays `#(1 #foo 'x')` (open token), comments `"…"`
|
||||
- [x] Parser (expression level): blocks `[:a :b | | t1 t2 | …]`, cascades, message precedence (unary > binary > keyword), assignment, return, statement sequences, literal arrays, byte arrays, paren grouping, method headers (`+ other`, `at:put:`, unary, with temps and body). Class-definition keyword messages parse as ordinary keyword sends — no special-case needed.
|
||||
- [x] Parser (chunk-stream level): `st-read-chunks` splits source on `!` (with `!!` doubling) and `st-parse-chunks` runs the Pharo file-in state machine — `methodsFor:` / `class methodsFor:` opens a method batch, an empty chunk closes it. Pragmas `<primitive: …>` (incl. multiple keyword pairs, before or after temps, multiple per method) parsed into the method AST.
|
||||
- [x] Unit tests in `lib/smalltalk/tests/parse.sx`
|
||||
|
||||
### Phase 2 — object model + sequential eval
|
||||
- [x] Class table + bootstrap (`lib/smalltalk/runtime.sx`): canonical hierarchy installed (`Object`, `Behavior`, `ClassDescription`, `Class`, `Metaclass`, `UndefinedObject`, `Boolean`/`True`/`False`, `Magnitude`/`Number`/`Integer`/`SmallInteger`/`Float`/`Character`, `Collection`/`SequenceableCollection`/`ArrayedCollection`/`Array`/`String`/`Symbol`/`OrderedCollection`/`Dictionary`, `BlockClosure`). User class definition via `st-class-define!`, methods via `st-class-add-method!` (stamps `:defining-class` for super), method lookup walks chain, ivars accumulated through superclass chain, native SX value types map to Smalltalk classes via `st-class-of`.
|
||||
- [ ] `smalltalk-eval-ast`: literals, variable reference, assignment, message send, cascade, sequence, return
|
||||
- [ ] Method lookup: walk class → superclass; cache hit-class on `(class, selector)`
|
||||
- [ ] `doesNotUnderstand:` fallback constructing `Message` object
|
||||
- [ ] `super` send (lookup starts at superclass of *defining* class, not receiver class)
|
||||
- [ ] 30+ tests in `lib/smalltalk/tests/eval.sx`
|
||||
|
||||
### Phase 3 — blocks + non-local return (THE SHOWCASE)
|
||||
- [ ] Method invocation captures a `^k` (the return continuation) and binds it as the block's escape
|
||||
- [ ] `^expr` from inside a block invokes that captured `^k`
|
||||
- [ ] `BlockContext>>value`, `value:`, `value:value:`, …, `valueWithArguments:`
|
||||
- [ ] `whileTrue:` / `whileTrue` / `whileFalse:` / `whileFalse` as ordinary block sends — runtime intrinsifies the loop in the bytecode JIT
|
||||
- [ ] `ifTrue:` / `ifFalse:` / `ifTrue:ifFalse:` as block sends, similarly intrinsified
|
||||
- [ ] Escape past returned-from method raises `BlockContext>>cannotReturn:`
|
||||
- [ ] Classic programs in `lib/smalltalk/tests/programs/`:
|
||||
- [ ] `eight-queens.st`
|
||||
- [ ] `quicksort.st`
|
||||
- [ ] `mandelbrot.st`
|
||||
- [ ] `life.st` (Conway's Life, glider gun)
|
||||
- [ ] `fibonacci.st` (recursive + memoised)
|
||||
- [ ] `lib/smalltalk/conformance.sh` + runner, `scoreboard.json` + `scoreboard.md`
|
||||
|
||||
### Phase 4 — reflection + MOP
|
||||
- [ ] `Object>>class`, `class>>name`, `class>>superclass`, `class>>methodDict`, `class>>selectors`
|
||||
- [ ] `Object>>perform:` / `perform:with:` / `perform:withArguments:`
|
||||
- [ ] `Object>>respondsTo:`, `Object>>isKindOf:`, `Object>>isMemberOf:`
|
||||
- [ ] `Behavior>>compile:` — runtime method addition
|
||||
- [ ] `Object>>becomeForward:` (one-way become; rewrites the class field of `aReceiver`)
|
||||
- [ ] Exceptions: `Exception`, `Error`, `signal`, `signal:`, `on:do:`, `ensure:`, `ifCurtailed:` — built on top of SX `handler-bind`/`raise`
|
||||
|
||||
### Phase 5 — collections + numeric tower
|
||||
- [ ] `SequenceableCollection`/`OrderedCollection`/`Array`/`String`/`Symbol`
|
||||
- [ ] `HashedCollection`/`Set`/`Dictionary`/`IdentityDictionary`
|
||||
- [ ] `Stream` hierarchy: `ReadStream`/`WriteStream`/`ReadWriteStream`
|
||||
- [ ] `Number` tower: `SmallInteger`/`LargePositiveInteger`/`Float`/`Fraction`
|
||||
- [ ] `String>>format:`, `printOn:` for everything
|
||||
|
||||
### Phase 6 — SUnit + corpus to 200+
|
||||
- [ ] Port SUnit (TestCase, TestSuite, TestResult) — written in SX-Smalltalk, runs in itself
|
||||
- [ ] Vendor a slice of Pharo `Kernel-Tests` and `Collections-Tests`
|
||||
- [ ] Drive the scoreboard up: aim for 200+ green tests
|
||||
- [ ] Stretch: ANSI Smalltalk validator subset
|
||||
|
||||
### Phase 7 — speed (optional)
|
||||
- [ ] Method-dictionary inline caching (already in CEK as a primitive; just wire selector cache)
|
||||
- [ ] Block intrinsification beyond `whileTrue:` / `ifTrue:`
|
||||
- [ ] Compare against GNU Smalltalk on the corpus
|
||||
|
||||
## Progress log
|
||||
|
||||
_Newest first. Agent appends on every commit._
|
||||
|
||||
- 2026-04-25: class table + bootstrap (`lib/smalltalk/runtime.sx`, `lib/smalltalk/tests/runtime.sx`). Canonical hierarchy, type→class mapping for native SX values, instance construction, ivar inheritance, method install with `:defining-class` stamp, instance- and class-side method lookup walking the superclass chain. 54 new tests, 185/185 total.
|
||||
- 2026-04-25: chunk-stream parser + pragmas + 21 chunk/pragma tests (`lib/smalltalk/tests/parse_chunks.sx`). `st-read-chunks` (with `!!` doubling), `st-parse-chunks` state machine for `methodsFor:` batches incl. class-side. Pragmas with multiple keyword pairs, signed numeric / string / symbol args, in either pragma-then-temps or temps-then-pragma order. 131/131 tests pass.
|
||||
- 2026-04-25: expression-level parser + 47 parse tests (`lib/smalltalk/parser.sx`, `lib/smalltalk/tests/parse.sx`). Full message precedence (unary > binary > keyword), cascades, blocks with params/temps, literal/byte arrays, assignment chain, method headers (unary/binary/keyword). Chunk-format `! !` driver deferred to a follow-up box. 110/110 tests pass.
|
||||
- 2026-04-25: tokenizer + 63 tests (`lib/smalltalk/tokenizer.sx`, `lib/smalltalk/tests/tokenize.sx`, `lib/smalltalk/test.sh`). All token types covered except scaled decimals `1.5s2` (deferred). `#(` and `#[` emit open tokens; literal-array contents lexed as ordinary tokens for the parser to interpret.
|
||||
|
||||
## Blockers
|
||||
|
||||
_Shared-file issues that need someone else to fix. Minimal repro only._
|
||||
|
||||
- _(none yet)_
|
||||
@@ -30,7 +30,7 @@ fi
|
||||
|
||||
if [ "$CLEAN" = "1" ]; then
|
||||
cd "$(dirname "$0")/.."
|
||||
for lang in lua prolog forth erlang haskell js hs; do
|
||||
for lang in lua prolog forth erlang haskell js hs smalltalk; do
|
||||
wt="$WORKTREE_BASE/$lang"
|
||||
if [ -d "$wt" ]; then
|
||||
git worktree remove --force "$wt" 2>/dev/null || rm -rf "$wt"
|
||||
@@ -39,5 +39,5 @@ if [ "$CLEAN" = "1" ]; then
|
||||
done
|
||||
git worktree prune
|
||||
echo "Worktree branches (loops/<lang>) are preserved. Delete manually if desired:"
|
||||
echo " git branch -D loops/lua loops/prolog loops/forth loops/erlang loops/haskell loops/js loops/hs"
|
||||
echo " git branch -D loops/lua loops/prolog loops/forth loops/erlang loops/haskell loops/js loops/hs loops/smalltalk"
|
||||
fi
|
||||
|
||||
@@ -1,5 +1,5 @@
|
||||
#!/usr/bin/env bash
|
||||
# Spawn 7 claude sessions in tmux, one per language loop.
|
||||
# Spawn 8 claude sessions in tmux, one per language loop.
|
||||
# Each runs in its own git worktree rooted at /root/rose-ash-loops/<lang>,
|
||||
# on branch loops/<lang>. No two loops share a working tree, so there's
|
||||
# zero risk of file collisions between languages.
|
||||
@@ -9,7 +9,7 @@
|
||||
#
|
||||
# After the script prints done:
|
||||
# tmux a -t sx-loops
|
||||
# Ctrl-B + <window-number> to switch (0=lua ... 6=hs)
|
||||
# Ctrl-B + <window-number> to switch (0=lua ... 7=smalltalk)
|
||||
# Ctrl-B + d to detach (loops keep running, SSH-safe)
|
||||
#
|
||||
# Stop: ./scripts/sx-loops-down.sh
|
||||
@@ -38,8 +38,9 @@ declare -A BRIEFING=(
|
||||
[haskell]=haskell-loop.md
|
||||
[js]=loop.md
|
||||
[hs]=hs-loop.md
|
||||
[smalltalk]=smalltalk-loop.md
|
||||
)
|
||||
ORDER=(lua prolog forth erlang haskell js hs)
|
||||
ORDER=(lua prolog forth erlang haskell js hs smalltalk)
|
||||
|
||||
mkdir -p "$WORKTREE_BASE"
|
||||
|
||||
@@ -66,7 +67,7 @@ for lang in "${ORDER[@]:1}"; do
|
||||
tmux new-window -t "$SESSION" -n "$lang" -c "$WORKTREE_BASE/$lang"
|
||||
done
|
||||
|
||||
echo "Starting 7 claude sessions..."
|
||||
echo "Starting 8 claude sessions..."
|
||||
for lang in "${ORDER[@]}"; do
|
||||
tmux send-keys -t "$SESSION:$lang" "claude" C-m
|
||||
done
|
||||
@@ -89,10 +90,10 @@ for lang in "${ORDER[@]}"; do
|
||||
done
|
||||
|
||||
echo ""
|
||||
echo "Done. 7 loops started in tmux session '$SESSION', each in its own worktree."
|
||||
echo "Done. 8 loops started in tmux session '$SESSION', each in its own worktree."
|
||||
echo ""
|
||||
echo " Attach: tmux a -t $SESSION"
|
||||
echo " Switch: Ctrl-B <0..6> (0=lua 1=prolog 2=forth 3=erlang 4=haskell 5=js 6=hs)"
|
||||
echo " Switch: Ctrl-B <0..7> (0=lua 1=prolog 2=forth 3=erlang 4=haskell 5=js 6=hs 7=smalltalk)"
|
||||
echo " List: Ctrl-B w"
|
||||
echo " Detach: Ctrl-B d"
|
||||
echo " Stop: ./scripts/sx-loops-down.sh"
|
||||
|
||||
Reference in New Issue
Block a user