giles
0b5f3c180e
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
1085 lines
40 KiB
Plaintext
1085 lines
40 KiB
Plaintext
;; Smalltalk AST evaluator — sequential semantics. Method dispatch uses the
|
|
;; class table from runtime.sx; native receivers fall back to a primitive
|
|
;; method table. Non-local return is implemented via captured continuations:
|
|
;; each method invocation wraps its body in `call/cc`, the captured k is
|
|
;; stored on the frame as `:return-k`, and `^expr` invokes that k. Blocks
|
|
;; capture their creating method's k so `^` from inside a block returns
|
|
;; from the *creating* method, not the invoking one — this is Smalltalk's
|
|
;; non-local return, the headline of Phase 3.
|
|
;;
|
|
;; Frame:
|
|
;; {:self V ; receiver
|
|
;; :method-class N ; defining class of the executing method
|
|
;; :locals (mutable dict) ; param + temp bindings
|
|
;; :parent P ; outer frame for blocks (nil for top-level)
|
|
;; :return-k K} ; the ^k that ^expr should invoke
|
|
|
|
(define
|
|
st-make-frame
|
|
(fn
|
|
(self method-class parent return-k active-cell)
|
|
{:self self
|
|
:method-class method-class
|
|
:locals {}
|
|
:parent parent
|
|
:return-k return-k
|
|
;; A small mutable dict shared between the method-frame and any
|
|
;; block created in its scope. While the method is on the stack
|
|
;; :active is true; once st-invoke finishes (normally or via the
|
|
;; captured ^k) it flips to false. ^expr from a block whose
|
|
;; active-cell is dead raises cannotReturn:.
|
|
:active-cell active-cell}))
|
|
|
|
(define
|
|
st-make-block
|
|
(fn
|
|
(ast frame)
|
|
{:type "st-block"
|
|
:params (get ast :params)
|
|
:temps (get ast :temps)
|
|
:body (get ast :body)
|
|
:env frame
|
|
;; capture the creating method's return continuation so that `^expr`
|
|
;; from inside this block always returns from that method
|
|
:return-k (if (= frame nil) nil (get frame :return-k))
|
|
;; Pair the captured ^k with the active-cell — invoking ^k after
|
|
;; the originating method has returned must raise cannotReturn:.
|
|
:active-cell (if (= frame nil) nil (get frame :active-cell))}))
|
|
|
|
(define
|
|
st-block?
|
|
(fn
|
|
(v)
|
|
(and (dict? v) (has-key? v :type) (= (get v :type) "st-block"))))
|
|
|
|
(define
|
|
st-class-ref
|
|
(fn (name) {:type "st-class" :name name}))
|
|
|
|
(define
|
|
st-class-ref?
|
|
(fn (v) (and (dict? v) (has-key? v :type) (= (get v :type) "st-class"))))
|
|
|
|
;; Walk the frame chain looking for a local binding.
|
|
(define
|
|
st-lookup-local
|
|
(fn
|
|
(frame name)
|
|
(cond
|
|
((= frame nil) {:found false :value nil :frame nil})
|
|
((has-key? (get frame :locals) name)
|
|
{:found true :value (get (get frame :locals) name) :frame frame})
|
|
(else (st-lookup-local (get frame :parent) name)))))
|
|
|
|
;; Walk the frame chain looking for the frame whose self has this ivar.
|
|
(define
|
|
st-lookup-ivar-frame
|
|
(fn
|
|
(frame name)
|
|
(cond
|
|
((= frame nil) nil)
|
|
((let ((self (get frame :self)))
|
|
(and (st-instance? self) (has-key? (get self :ivars) name)))
|
|
frame)
|
|
(else (st-lookup-ivar-frame (get frame :parent) name)))))
|
|
|
|
;; Resolve an identifier in eval order: local → ivar → class → error.
|
|
(define
|
|
st-resolve-ident
|
|
(fn
|
|
(frame name)
|
|
(let
|
|
((local-result (st-lookup-local frame name)))
|
|
(cond
|
|
((get local-result :found) (get local-result :value))
|
|
(else
|
|
(let
|
|
((iv-frame (st-lookup-ivar-frame frame name)))
|
|
(cond
|
|
((not (= iv-frame nil))
|
|
(get (get (get iv-frame :self) :ivars) name))
|
|
((st-class-exists? name) (st-class-ref name))
|
|
(else
|
|
(error
|
|
(str "smalltalk-eval-ast: undefined variable '" name "'"))))))))))
|
|
|
|
;; Assign to an existing local in the frame chain or, failing that, an ivar
|
|
;; on self. Errors if neither exists.
|
|
(define
|
|
st-assign!
|
|
(fn
|
|
(frame name value)
|
|
(let
|
|
((local-result (st-lookup-local frame name)))
|
|
(cond
|
|
((get local-result :found)
|
|
(begin
|
|
(dict-set! (get (get local-result :frame) :locals) name value)
|
|
value))
|
|
(else
|
|
(let
|
|
((iv-frame (st-lookup-ivar-frame frame name)))
|
|
(cond
|
|
((not (= iv-frame nil))
|
|
(begin
|
|
(dict-set! (get (get iv-frame :self) :ivars) name value)
|
|
value))
|
|
(else
|
|
;; Smalltalk allows new locals to be introduced; for our subset
|
|
;; we treat unknown writes as errors so test mistakes surface.
|
|
(error
|
|
(str "smalltalk-eval-ast: cannot assign undefined '" name "'"))))))))))
|
|
|
|
;; ── Main evaluator ─────────────────────────────────────────────────────
|
|
(define
|
|
smalltalk-eval-ast
|
|
(fn
|
|
(ast frame)
|
|
(cond
|
|
((not (dict? ast)) (error (str "smalltalk-eval-ast: bad ast " ast)))
|
|
(else
|
|
(let
|
|
((ty (get ast :type)))
|
|
(cond
|
|
((= ty "lit-int") (get ast :value))
|
|
((= ty "lit-float") (get ast :value))
|
|
((= ty "lit-string") (get ast :value))
|
|
((= ty "lit-char") (get ast :value))
|
|
((= ty "lit-symbol") (make-symbol (get ast :value)))
|
|
((= ty "lit-nil") nil)
|
|
((= ty "lit-true") true)
|
|
((= ty "lit-false") false)
|
|
((= ty "lit-array")
|
|
;; map returns an immutable list — Smalltalk arrays must be
|
|
;; mutable so that `at:put:` works. Build via append! so each
|
|
;; literal yields a fresh mutable list.
|
|
(let ((out (list)))
|
|
(begin
|
|
(for-each
|
|
(fn (e) (append! out (smalltalk-eval-ast e frame)))
|
|
(get ast :elements))
|
|
out)))
|
|
((= ty "dynamic-array")
|
|
;; { e1. e2. ... } — each element is a full expression
|
|
;; evaluated at runtime. Returns a fresh mutable array.
|
|
(let ((out (list)))
|
|
(begin
|
|
(for-each
|
|
(fn (e) (append! out (smalltalk-eval-ast e frame)))
|
|
(get ast :elements))
|
|
out)))
|
|
((= ty "lit-byte-array") (get ast :elements))
|
|
((= ty "self") (get frame :self))
|
|
((= ty "super") (get frame :self))
|
|
((= ty "thisContext") frame)
|
|
((= ty "ident") (st-resolve-ident frame (get ast :name)))
|
|
((= ty "assign")
|
|
(st-assign! frame (get ast :name) (smalltalk-eval-ast (get ast :expr) frame)))
|
|
((= ty "return")
|
|
(let ((v (smalltalk-eval-ast (get ast :expr) frame)))
|
|
(let
|
|
((k (get frame :return-k))
|
|
(cell (get frame :active-cell)))
|
|
(cond
|
|
((= k nil)
|
|
(error "smalltalk-eval-ast: return outside method context"))
|
|
((and (not (= cell nil))
|
|
(not (get cell :active)))
|
|
(error
|
|
(str
|
|
"BlockContext>>cannotReturn: — ^expr after the "
|
|
"creating method has already returned (value was "
|
|
v ")")))
|
|
(else (k v))))))
|
|
((= ty "block") (st-make-block ast frame))
|
|
((= ty "seq") (st-eval-seq (get ast :exprs) frame))
|
|
((= ty "send")
|
|
(st-eval-send ast frame (= (get (get ast :receiver) :type) "super")))
|
|
((= ty "cascade") (st-eval-cascade ast frame))
|
|
(else (error (str "smalltalk-eval-ast: unknown type '" ty "'")))))))))
|
|
|
|
;; Evaluate a sequence; return the last expression's value. `^expr`
|
|
;; mid-sequence transfers control via the frame's :return-k and never
|
|
;; returns to this loop, so we don't need any return-marker plumbing.
|
|
(define
|
|
st-eval-seq
|
|
(fn
|
|
(exprs frame)
|
|
(let ((result nil))
|
|
(begin
|
|
(for-each
|
|
(fn (e) (set! result (smalltalk-eval-ast e frame)))
|
|
exprs)
|
|
result))))
|
|
|
|
(define
|
|
st-eval-send
|
|
(fn
|
|
(ast frame super?)
|
|
(let
|
|
((receiver (smalltalk-eval-ast (get ast :receiver) frame))
|
|
(selector (get ast :selector))
|
|
(args (map (fn (a) (smalltalk-eval-ast a frame)) (get ast :args))))
|
|
(cond
|
|
(super?
|
|
(st-super-send (get frame :self) selector args (get frame :method-class)))
|
|
(else (st-send receiver selector args))))))
|
|
|
|
(define
|
|
st-eval-cascade
|
|
(fn
|
|
(ast frame)
|
|
(let
|
|
((receiver (smalltalk-eval-ast (get ast :receiver) frame))
|
|
(msgs (get ast :messages))
|
|
(last nil))
|
|
(begin
|
|
(for-each
|
|
(fn
|
|
(m)
|
|
(let
|
|
((sel (get m :selector))
|
|
(args (map (fn (a) (smalltalk-eval-ast a frame)) (get m :args))))
|
|
(set! last (st-send receiver sel args))))
|
|
msgs)
|
|
last))))
|
|
|
|
;; ── Send dispatch ──────────────────────────────────────────────────────
|
|
(define
|
|
st-send
|
|
(fn
|
|
(receiver selector args)
|
|
(let
|
|
((cls (st-class-of-for-send receiver)))
|
|
(let
|
|
((class-side? (st-class-ref? receiver))
|
|
(recv-class (if (st-class-ref? receiver) (get receiver :name) cls)))
|
|
(let
|
|
((method
|
|
(if class-side?
|
|
(st-method-lookup recv-class selector true)
|
|
(st-method-lookup recv-class selector false))))
|
|
(cond
|
|
((not (= method nil))
|
|
(st-invoke method receiver args))
|
|
((st-block? receiver)
|
|
(let ((bd (st-block-dispatch receiver selector args)))
|
|
(cond
|
|
((= bd :unhandled) (st-dnu receiver selector args))
|
|
(else bd))))
|
|
(else
|
|
(let ((primitive-result (st-primitive-send receiver selector args)))
|
|
(cond
|
|
((= primitive-result :unhandled)
|
|
(st-dnu receiver selector args))
|
|
(else primitive-result))))))))))
|
|
|
|
;; Construct a Message object for doesNotUnderstand:.
|
|
(define
|
|
st-make-message
|
|
(fn
|
|
(selector args)
|
|
(let ((msg (st-make-instance "Message")))
|
|
(begin
|
|
(dict-set! (get msg :ivars) "selector" (make-symbol selector))
|
|
(dict-set! (get msg :ivars) "arguments" args)
|
|
msg))))
|
|
|
|
;; Trigger doesNotUnderstand:. If the receiver's class chain defines an
|
|
;; override, invoke it with a freshly-built Message; otherwise raise.
|
|
(define
|
|
st-dnu
|
|
(fn
|
|
(receiver selector args)
|
|
(let
|
|
((cls (st-class-of-for-send receiver))
|
|
(class-side? (st-class-ref? receiver)))
|
|
(let
|
|
((recv-class (if class-side? (get receiver :name) cls)))
|
|
(let
|
|
((method (st-method-lookup recv-class "doesNotUnderstand:" class-side?)))
|
|
(cond
|
|
((not (= method nil))
|
|
(let ((msg (st-make-message selector args)))
|
|
(st-invoke method receiver (list msg))))
|
|
(else
|
|
(error
|
|
(str "doesNotUnderstand: " recv-class " >> " selector)))))))))
|
|
|
|
(define
|
|
st-class-of-for-send
|
|
(fn
|
|
(v)
|
|
(cond
|
|
((st-class-ref? v) "Class")
|
|
(else (st-class-of v)))))
|
|
|
|
;; super send: lookup starts at the *defining* class's superclass, not the
|
|
;; receiver class. This is what makes inherited methods compose correctly
|
|
;; under refinement — a method on Foo that calls `super bar` resolves to
|
|
;; Foo's superclass's `bar` regardless of the dynamic receiver class.
|
|
(define
|
|
st-super-send
|
|
(fn
|
|
(receiver selector args defining-class)
|
|
(cond
|
|
((= defining-class nil)
|
|
(error (str "super send outside method context: " selector)))
|
|
(else
|
|
(let
|
|
((super (st-class-superclass defining-class))
|
|
(class-side? (st-class-ref? receiver)))
|
|
(cond
|
|
((= super nil)
|
|
(error (str "super send past root: " selector " in " defining-class)))
|
|
(else
|
|
(let ((method (st-method-lookup super selector class-side?)))
|
|
(cond
|
|
((not (= method nil))
|
|
(st-invoke method receiver args))
|
|
(else
|
|
;; Try primitives starting from super's perspective too —
|
|
;; for native receivers the primitive table is global, so
|
|
;; super basically reaches the same primitives. The point
|
|
;; of super is to skip user overrides on the receiver's
|
|
;; class chain below `super`, which method-lookup above
|
|
;; already enforces.
|
|
(let ((p (st-primitive-send receiver selector args)))
|
|
(cond
|
|
((= p :unhandled)
|
|
(st-dnu receiver selector args))
|
|
(else p)))))))))))))
|
|
|
|
;; ── Method invocation ──────────────────────────────────────────────────
|
|
;;
|
|
;; Method body is wrapped in (call/cc (fn (k) ...)). The k is bound on the
|
|
;; method's frame as :return-k. `^expr` invokes k, which abandons the body
|
|
;; and resumes call/cc with v. Blocks that escape with `^` capture the
|
|
;; *creating* method's k, so non-local return reaches back through any
|
|
;; number of nested block.value calls.
|
|
(define
|
|
st-invoke
|
|
(fn
|
|
(method receiver args)
|
|
(let
|
|
((params (get method :params))
|
|
(temps (get method :temps))
|
|
(body (get method :body))
|
|
(defining-class (get method :defining-class)))
|
|
(cond
|
|
((not (= (len params) (len args)))
|
|
(error
|
|
(str "smalltalk-eval-ast: arity mismatch for "
|
|
(get method :selector)
|
|
" expected " (len params) " got " (len args))))
|
|
(else
|
|
(let ((cell {:active true}))
|
|
(let
|
|
((result
|
|
(call/cc
|
|
(fn (k)
|
|
(let ((frame (st-make-frame receiver defining-class nil k cell)))
|
|
(begin
|
|
;; Bind params
|
|
(let ((i 0))
|
|
(begin
|
|
(define
|
|
pb-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(< i (len params))
|
|
(begin
|
|
(dict-set!
|
|
(get frame :locals)
|
|
(nth params i)
|
|
(nth args i))
|
|
(set! i (+ i 1))
|
|
(pb-loop)))))
|
|
(pb-loop)))
|
|
;; Bind temps to nil
|
|
(for-each
|
|
(fn (t) (dict-set! (get frame :locals) t nil))
|
|
temps)
|
|
;; Execute body. If body finishes without ^, the implicit
|
|
;; return value in Smalltalk is `self` — match that.
|
|
(st-eval-seq body frame)
|
|
receiver))))))
|
|
(begin
|
|
;; Method invocation is finished — flip the cell so any block
|
|
;; that captured this method's ^k can no longer return.
|
|
(dict-set! cell :active false)
|
|
result))))))))
|
|
|
|
;; ── Block dispatch ─────────────────────────────────────────────────────
|
|
(define
|
|
st-block-value-selector?
|
|
(fn
|
|
(s)
|
|
(or
|
|
(= s "value")
|
|
(= s "value:")
|
|
(= s "value:value:")
|
|
(= s "value:value:value:")
|
|
(= s "value:value:value:value:"))))
|
|
|
|
(define
|
|
st-block-dispatch
|
|
(fn
|
|
(block selector args)
|
|
(cond
|
|
((st-block-value-selector? selector) (st-block-apply block args))
|
|
((= selector "valueWithArguments:") (st-block-apply block (nth args 0)))
|
|
((= selector "whileTrue:")
|
|
(st-block-while block (nth args 0) true))
|
|
((= selector "whileFalse:")
|
|
(st-block-while block (nth args 0) false))
|
|
((= selector "whileTrue") (st-block-while block nil true))
|
|
((= selector "whileFalse") (st-block-while block nil false))
|
|
((= selector "numArgs") (len (get block :params)))
|
|
((= selector "class") (st-class-ref "BlockClosure"))
|
|
((= selector "==") (= block (nth args 0)))
|
|
((= selector "printString") "a BlockClosure")
|
|
;; Smalltalk exception machinery on top of SX guard/raise.
|
|
((= selector "on:do:")
|
|
(st-block-on-do block (nth args 0) (nth args 1)))
|
|
((= selector "ensure:")
|
|
(st-block-ensure block (nth args 0)))
|
|
((= selector "ifCurtailed:")
|
|
(st-block-if-curtailed block (nth args 0)))
|
|
(else :unhandled))))
|
|
|
|
;; on: ExceptionClass do: aHandler — run the receiver block, catching
|
|
;; raised st-instances whose class isKindOf: the given Exception class.
|
|
;; Other raises propagate. The handler receives the caught exception.
|
|
(define
|
|
st-block-on-do
|
|
(fn
|
|
(block exc-class-ref handler)
|
|
(let
|
|
((target-name
|
|
(cond
|
|
((st-class-ref? exc-class-ref) (get exc-class-ref :name))
|
|
(else "Exception"))))
|
|
(guard
|
|
(caught
|
|
((and (st-instance? caught)
|
|
(st-class-inherits-from? (get caught :class) target-name))
|
|
(st-block-apply handler (list caught))))
|
|
(st-block-apply block (list))))))
|
|
|
|
;; ensure: cleanup — run the receiver block, then run cleanup whether the
|
|
;; receiver completed normally or raised. On raise, cleanup runs and the
|
|
;; exception propagates. The side-effect predicate pattern lets cleanup
|
|
;; run inside the guard clause without us needing to call (raise c)
|
|
;; explicitly (which has issues in nested handlers).
|
|
(define
|
|
st-block-ensure
|
|
(fn
|
|
(block cleanup)
|
|
(let ((result nil) (raised false))
|
|
(begin
|
|
(guard
|
|
(caught
|
|
((begin
|
|
(set! raised true)
|
|
(st-block-apply cleanup (list))
|
|
false)
|
|
nil))
|
|
(set! result (st-block-apply block (list))))
|
|
(when (not raised) (st-block-apply cleanup (list)))
|
|
result))))
|
|
|
|
;; ifCurtailed: cleanup — run cleanup ONLY if the receiver block raises.
|
|
(define
|
|
st-block-if-curtailed
|
|
(fn
|
|
(block cleanup)
|
|
(guard
|
|
(caught
|
|
((begin (st-block-apply cleanup (list)) false) nil))
|
|
(st-block-apply block (list)))))
|
|
|
|
(define
|
|
st-block-apply
|
|
(fn
|
|
(block args)
|
|
(let
|
|
((params (get block :params))
|
|
(temps (get block :temps))
|
|
(body (get block :body))
|
|
(env (get block :env)))
|
|
(cond
|
|
((not (= (len params) (len args)))
|
|
(error
|
|
(str "BlockClosure: arity mismatch — block expects "
|
|
(len params) " got " (len args))))
|
|
(else
|
|
(let
|
|
((frame (st-make-frame
|
|
(if (= env nil) nil (get env :self))
|
|
(if (= env nil) nil (get env :method-class))
|
|
env
|
|
;; Use the block's captured ^k so `^expr` returns from
|
|
;; the *creating* method, not whoever invoked the block.
|
|
(get block :return-k)
|
|
;; Same active-cell as the creating method's frame; if
|
|
;; the method has returned, ^expr through this frame
|
|
;; raises cannotReturn:.
|
|
(get block :active-cell))))
|
|
(begin
|
|
(let ((i 0))
|
|
(begin
|
|
(define
|
|
pb-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(< i (len params))
|
|
(begin
|
|
(dict-set!
|
|
(get frame :locals)
|
|
(nth params i)
|
|
(nth args i))
|
|
(set! i (+ i 1))
|
|
(pb-loop)))))
|
|
(pb-loop)))
|
|
(for-each
|
|
(fn (t) (dict-set! (get frame :locals) t nil))
|
|
temps)
|
|
(st-eval-seq body frame))))))))
|
|
|
|
;; whileTrue: / whileTrue / whileFalse: / whileFalse — the receiver is the
|
|
;; condition block; the optional argument is the body block. Per ANSI / Pharo
|
|
;; convention, the loop returns nil regardless of how many iterations ran.
|
|
(define
|
|
st-block-while
|
|
(fn
|
|
(cond-block body-block target)
|
|
(begin
|
|
(define
|
|
wh-loop
|
|
(fn
|
|
()
|
|
(let
|
|
((c (st-block-apply cond-block (list))))
|
|
(when
|
|
(= c target)
|
|
(begin
|
|
(cond
|
|
((not (= body-block nil))
|
|
(st-block-apply body-block (list))))
|
|
(wh-loop))))))
|
|
(wh-loop)
|
|
nil)))
|
|
|
|
;; ── Primitive method table for native receivers ────────────────────────
|
|
;; Returns the result, or the sentinel :unhandled if no primitive matches —
|
|
;; in which case st-send falls back to doesNotUnderstand:.
|
|
(define
|
|
st-primitive-send
|
|
(fn
|
|
(receiver selector args)
|
|
(let ((cls (st-class-of receiver)))
|
|
;; Universal Object messages — work on any receiver type.
|
|
(cond
|
|
((= selector "class")
|
|
(cond
|
|
((st-class-ref? receiver) (st-class-ref "Metaclass"))
|
|
(else (st-class-ref cls))))
|
|
;; perform: / perform:with: / perform:withArguments:
|
|
((= selector "perform:")
|
|
(st-send receiver (str (nth args 0)) (list)))
|
|
((= selector "perform:withArguments:")
|
|
(st-send receiver (str (nth args 0)) (nth args 1)))
|
|
((or (= selector "perform:with:")
|
|
(= selector "perform:with:with:")
|
|
(= selector "perform:with:with:with:")
|
|
(= selector "perform:with:with:with:with:"))
|
|
(st-send receiver (str (nth args 0)) (slice args 1 (len args))))
|
|
;; respondsTo: aSymbol — searches user method dicts only. Native
|
|
;; primitive selectors aren't enumerated, so e.g. `42 respondsTo:
|
|
;; #+` returns false. (The send still works because dispatch falls
|
|
;; through to st-num-send.) Documented limitation.
|
|
((= selector "respondsTo:")
|
|
(let
|
|
((sel-str (str (nth args 0)))
|
|
(target-cls (if (st-class-ref? receiver) (get receiver :name) cls))
|
|
(class-side? (st-class-ref? receiver)))
|
|
(not (= (st-method-lookup target-cls sel-str class-side?) nil))))
|
|
;; isKindOf: aClass — true iff the receiver's class chain reaches it.
|
|
((= selector "isKindOf:")
|
|
(let
|
|
((arg (nth args 0))
|
|
(target-cls (if (st-class-ref? receiver) "Metaclass" cls)))
|
|
(cond
|
|
((not (st-class-ref? arg)) false)
|
|
(else (st-class-inherits-from? target-cls (get arg :name))))))
|
|
;; isMemberOf: aClass — exact class match.
|
|
((= selector "isMemberOf:")
|
|
(let
|
|
((arg (nth args 0))
|
|
(target-cls (if (st-class-ref? receiver) "Metaclass" cls)))
|
|
(cond
|
|
((not (st-class-ref? arg)) false)
|
|
(else (= target-cls (get arg :name))))))
|
|
;; Smalltalk Exception system — `signal` raises the receiver via
|
|
;; SX raise. The argument to signal: sets messageText.
|
|
;; on:do: / ensure: / ifCurtailed: are implemented on BlockClosure
|
|
;; in `st-block-dispatch`.
|
|
((and (= selector "signal")
|
|
(st-instance? receiver)
|
|
(st-class-inherits-from? cls "Exception"))
|
|
(raise receiver))
|
|
((and (= selector "signal:")
|
|
(st-instance? receiver)
|
|
(st-class-inherits-from? cls "Exception"))
|
|
(begin
|
|
(dict-set! (get receiver :ivars) "messageText" (nth args 0))
|
|
(raise receiver)))
|
|
((and (= selector "signal")
|
|
(st-class-ref? receiver)
|
|
(st-class-inherits-from? (get receiver :name) "Exception"))
|
|
(raise (st-make-instance (get receiver :name))))
|
|
((and (= selector "signal:")
|
|
(st-class-ref? receiver)
|
|
(st-class-inherits-from? (get receiver :name) "Exception"))
|
|
(let ((inst (st-make-instance (get receiver :name))))
|
|
(begin
|
|
(dict-set! (get inst :ivars) "messageText" (nth args 0))
|
|
(raise inst))))
|
|
;; Object>>becomeForward: aReceiver — one-way become. The receiver's
|
|
;; class and ivars are mutated in place to match the target. Every
|
|
;; existing reference to the receiver dict sees the new identity.
|
|
;; Note: receiver and target remain distinct dicts (not == in the
|
|
;; SX-identity sense), but receiver behaves as though it were the
|
|
;; target — which is the practical Pharo guarantee.
|
|
((= selector "becomeForward:")
|
|
(let ((other (nth args 0)))
|
|
(cond
|
|
((not (st-instance? receiver))
|
|
(error "becomeForward: only supported on user instances"))
|
|
((not (st-instance? other))
|
|
(error "becomeForward: target must be a user instance"))
|
|
(else
|
|
(begin
|
|
(dict-set! receiver :class (get other :class))
|
|
(dict-set! receiver :ivars (get other :ivars))
|
|
receiver)))))
|
|
((or (= cls "SmallInteger") (= cls "Float"))
|
|
(st-num-send receiver selector args))
|
|
((or (= cls "String") (= cls "Symbol"))
|
|
(st-string-send receiver selector args))
|
|
((= cls "True") (st-bool-send true selector args))
|
|
((= cls "False") (st-bool-send false selector args))
|
|
((= cls "UndefinedObject") (st-nil-send selector args))
|
|
((= cls "Array") (st-array-send receiver selector args))
|
|
((st-class-ref? receiver) (st-class-side-send receiver selector args))
|
|
(else :unhandled)))))
|
|
|
|
(define
|
|
st-num-send
|
|
(fn
|
|
(n selector args)
|
|
(cond
|
|
((= selector "+") (+ n (nth args 0)))
|
|
((= selector "-") (- n (nth args 0)))
|
|
((= selector "*") (* n (nth args 0)))
|
|
((= selector "/") (/ n (nth args 0)))
|
|
((= selector "//") (/ n (nth args 0)))
|
|
((= selector "\\\\") (mod n (nth args 0)))
|
|
((= selector "<") (< n (nth args 0)))
|
|
((= selector ">") (> n (nth args 0)))
|
|
((= selector "<=") (<= n (nth args 0)))
|
|
((= selector ">=") (>= n (nth args 0)))
|
|
((= selector "=") (= n (nth args 0)))
|
|
((= selector "~=") (not (= n (nth args 0))))
|
|
((= selector "==") (= n (nth args 0)))
|
|
((= selector "~~") (not (= n (nth args 0))))
|
|
((= selector "negated") (- 0 n))
|
|
((= selector "abs") (if (< n 0) (- 0 n) n))
|
|
((= selector "max:") (if (> n (nth args 0)) n (nth args 0)))
|
|
((= selector "min:") (if (< n (nth args 0)) n (nth args 0)))
|
|
((= selector "printString") (str n))
|
|
((= selector "asString") (str n))
|
|
((= selector "class")
|
|
(st-class-ref (st-class-of n)))
|
|
((= selector "isNil") false)
|
|
((= selector "notNil") true)
|
|
((= selector "isZero") (= n 0))
|
|
((= selector "between:and:")
|
|
(and (>= n (nth args 0)) (<= n (nth args 1))))
|
|
((= selector "to:do:")
|
|
(let ((i n) (stop (nth args 0)) (block (nth args 1)))
|
|
(begin
|
|
(define
|
|
td-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(<= i stop)
|
|
(begin
|
|
(st-block-apply block (list i))
|
|
(set! i (+ i 1))
|
|
(td-loop)))))
|
|
(td-loop)
|
|
n)))
|
|
((= selector "timesRepeat:")
|
|
(let ((i 0) (block (nth args 0)))
|
|
(begin
|
|
(define
|
|
tr-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(< i n)
|
|
(begin
|
|
(st-block-apply block (list))
|
|
(set! i (+ i 1))
|
|
(tr-loop)))))
|
|
(tr-loop)
|
|
n)))
|
|
(else :unhandled))))
|
|
|
|
(define
|
|
st-string-send
|
|
(fn
|
|
(s selector args)
|
|
(cond
|
|
((= selector ",") (str s (nth args 0)))
|
|
((= selector "size") (len s))
|
|
((= selector "=") (= s (nth args 0)))
|
|
((= selector "~=") (not (= s (nth args 0))))
|
|
((= selector "==") (= s (nth args 0)))
|
|
((= selector "~~") (not (= s (nth args 0))))
|
|
((= selector "isEmpty") (= (len s) 0))
|
|
((= selector "notEmpty") (> (len s) 0))
|
|
((= selector "printString") (str "'" s "'"))
|
|
((= selector "asString") s)
|
|
((= selector "asSymbol") (make-symbol (if (symbol? s) (str s) s)))
|
|
((= selector "class") (st-class-ref (st-class-of s)))
|
|
((= selector "isNil") false)
|
|
((= selector "notNil") true)
|
|
(else :unhandled))))
|
|
|
|
(define
|
|
st-bool-send
|
|
(fn
|
|
(b selector args)
|
|
(cond
|
|
((= selector "not") (not b))
|
|
((= selector "&") (and b (nth args 0)))
|
|
((= selector "|") (or b (nth args 0)))
|
|
((= selector "and:")
|
|
(cond (b (st-block-apply (nth args 0) (list))) (else false)))
|
|
((= selector "or:")
|
|
(cond (b true) (else (st-block-apply (nth args 0) (list)))))
|
|
((= selector "ifTrue:")
|
|
(cond (b (st-block-apply (nth args 0) (list))) (else nil)))
|
|
((= selector "ifFalse:")
|
|
(cond (b nil) (else (st-block-apply (nth args 0) (list)))))
|
|
((= selector "ifTrue:ifFalse:")
|
|
(cond
|
|
(b (st-block-apply (nth args 0) (list)))
|
|
(else (st-block-apply (nth args 1) (list)))))
|
|
((= selector "ifFalse:ifTrue:")
|
|
(cond
|
|
(b (st-block-apply (nth args 1) (list)))
|
|
(else (st-block-apply (nth args 0) (list)))))
|
|
((= selector "=") (= b (nth args 0)))
|
|
((= selector "~=") (not (= b (nth args 0))))
|
|
((= selector "==") (= b (nth args 0)))
|
|
((= selector "printString") (if b "true" "false"))
|
|
((= selector "class") (st-class-ref (if b "True" "False")))
|
|
((= selector "isNil") false)
|
|
((= selector "notNil") true)
|
|
(else :unhandled))))
|
|
|
|
(define
|
|
st-nil-send
|
|
(fn
|
|
(selector args)
|
|
(cond
|
|
((= selector "isNil") true)
|
|
((= selector "notNil") false)
|
|
((= selector "ifNil:") (st-block-apply (nth args 0) (list)))
|
|
((= selector "ifNotNil:") nil)
|
|
((= selector "ifNil:ifNotNil:") (st-block-apply (nth args 0) (list)))
|
|
((= selector "ifNotNil:ifNil:") (st-block-apply (nth args 1) (list)))
|
|
((= selector "=") (= nil (nth args 0)))
|
|
((= selector "~=") (not (= nil (nth args 0))))
|
|
((= selector "==") (= nil (nth args 0)))
|
|
((= selector "printString") "nil")
|
|
((= selector "class") (st-class-ref "UndefinedObject"))
|
|
(else :unhandled))))
|
|
|
|
(define
|
|
st-array-send
|
|
(fn
|
|
(a selector args)
|
|
(cond
|
|
((= selector "size") (len a))
|
|
((= selector "at:")
|
|
;; 1-indexed
|
|
(nth a (- (nth args 0) 1)))
|
|
((= selector "at:put:")
|
|
(begin
|
|
(set-nth! a (- (nth args 0) 1) (nth args 1))
|
|
(nth args 1)))
|
|
((= selector "first") (nth a 0))
|
|
((= selector "last") (nth a (- (len a) 1)))
|
|
((= selector "isEmpty") (= (len a) 0))
|
|
((= selector "notEmpty") (> (len a) 0))
|
|
((= selector "do:")
|
|
(begin
|
|
(for-each
|
|
(fn (e) (st-block-apply (nth args 0) (list e)))
|
|
a)
|
|
a))
|
|
((= selector "collect:")
|
|
(map (fn (e) (st-block-apply (nth args 0) (list e))) a))
|
|
((= selector "select:")
|
|
(filter (fn (e) (st-block-apply (nth args 0) (list e))) a))
|
|
((= selector ",")
|
|
(let ((out (list)))
|
|
(begin
|
|
(for-each (fn (e) (append! out e)) a)
|
|
(for-each (fn (e) (append! out e)) (nth args 0))
|
|
out)))
|
|
((= selector "=") (= a (nth args 0)))
|
|
((= selector "==") (= a (nth args 0)))
|
|
((= selector "printString")
|
|
(str "#(" (join " " (map (fn (e) (str e)) a)) ")"))
|
|
((= selector "class") (st-class-ref "Array"))
|
|
((= selector "isNil") false)
|
|
((= selector "notNil") true)
|
|
(else :unhandled))))
|
|
|
|
;; Split a Smalltalk-style "x y z" instance-variable string into a list of
|
|
;; ivar names. Whitespace-delimited.
|
|
(define
|
|
st-split-ivars
|
|
(fn
|
|
(s)
|
|
(let ((out (list)) (n (len s)) (i 0) (start nil))
|
|
(begin
|
|
(define
|
|
flush!
|
|
(fn ()
|
|
(when
|
|
(not (= start nil))
|
|
(begin (append! out (slice s start i)) (set! start nil)))))
|
|
(define
|
|
si-loop
|
|
(fn ()
|
|
(when
|
|
(< i n)
|
|
(let ((c (nth s i)))
|
|
(cond
|
|
((or (= c " ") (= c "\t") (= c "\n") (= c "\r"))
|
|
(begin (flush!) (set! i (+ i 1)) (si-loop)))
|
|
(else
|
|
(begin
|
|
(when (= start nil) (set! start i))
|
|
(set! i (+ i 1))
|
|
(si-loop))))))))
|
|
(si-loop)
|
|
(flush!)
|
|
out))))
|
|
|
|
(define
|
|
st-class-side-send
|
|
(fn
|
|
(cref selector args)
|
|
(let ((name (get cref :name)))
|
|
(cond
|
|
((= selector "new")
|
|
(cond
|
|
((= name "Array") (list))
|
|
(else (st-make-instance name))))
|
|
((= selector "new:")
|
|
(cond
|
|
((= name "Array")
|
|
(let ((size (nth args 0)) (out (list)))
|
|
(begin
|
|
(let ((i 0))
|
|
(begin
|
|
(define
|
|
an-loop
|
|
(fn ()
|
|
(when
|
|
(< i size)
|
|
(begin
|
|
(append! out nil)
|
|
(set! i (+ i 1))
|
|
(an-loop)))))
|
|
(an-loop)))
|
|
out)))
|
|
(else (st-make-instance name))))
|
|
((= selector "name") name)
|
|
((= selector "superclass")
|
|
(let ((s (st-class-superclass name)))
|
|
(cond ((= s nil) nil) (else (st-class-ref s)))))
|
|
((= selector "methodDict")
|
|
;; The class's own method dictionary (instance side).
|
|
(get (st-class-get name) :methods))
|
|
((= selector "classMethodDict")
|
|
(get (st-class-get name) :class-methods))
|
|
((= selector "selectors")
|
|
;; Own instance-side selectors as an Array of symbols.
|
|
(let ((out (list)))
|
|
(begin
|
|
(for-each
|
|
(fn (k) (append! out (make-symbol k)))
|
|
(keys (get (st-class-get name) :methods)))
|
|
out)))
|
|
((= selector "classSelectors")
|
|
(let ((out (list)))
|
|
(begin
|
|
(for-each
|
|
(fn (k) (append! out (make-symbol k)))
|
|
(keys (get (st-class-get name) :class-methods)))
|
|
out)))
|
|
((= selector "instanceVariableNames")
|
|
;; Own ivars as an Array of strings (matches Pharo).
|
|
(get (st-class-get name) :ivars))
|
|
((= selector "allInstVarNames")
|
|
;; Inherited + own ivars in declaration order (root first).
|
|
(st-class-all-ivars name))
|
|
;; Class definition: `Object subclass: #Foo instanceVariableNames: 'x y'`.
|
|
;; Supports the short `subclass:` and the full
|
|
;; `subclass:instanceVariableNames:classVariableNames:package:` form.
|
|
((or (= selector "subclass:")
|
|
(= selector "subclass:instanceVariableNames:")
|
|
(= selector "subclass:instanceVariableNames:classVariableNames:")
|
|
(= selector "subclass:instanceVariableNames:classVariableNames:package:")
|
|
(= selector "subclass:instanceVariableNames:classVariableNames:poolDictionaries:category:"))
|
|
(let
|
|
((sub-sym (nth args 0))
|
|
(iv-string (if (> (len args) 1) (nth args 1) "")))
|
|
(let
|
|
((sub-name (str sub-sym)))
|
|
(begin
|
|
(st-class-define!
|
|
sub-name
|
|
name
|
|
(st-split-ivars (if (string? iv-string) iv-string (str iv-string))))
|
|
(st-class-ref sub-name)))))
|
|
;; methodsFor: / methodsFor:stamp: are Pharo file-in markers — at
|
|
;; the expression level they just return the class for further
|
|
;; cascades. Method bodies are loaded by the chunk-stream loader.
|
|
((or (= selector "methodsFor:")
|
|
(= selector "methodsFor:stamp:")
|
|
(= selector "category:")
|
|
(= selector "comment:"))
|
|
cref)
|
|
;; Behavior>>compile: parses the source string as a method and
|
|
;; installs it. Returns the selector as a symbol.
|
|
;; Sister forms: compile:classified: and compile:notifying:
|
|
;; ignore the extra arg, mirroring Pharo's tolerant behaviour.
|
|
((or (= selector "compile:")
|
|
(= selector "compile:classified:")
|
|
(= selector "compile:notifying:"))
|
|
(let ((src (nth args 0)))
|
|
(let ((method-ast (st-parse-method (str src))))
|
|
(st-class-add-method!
|
|
name (get method-ast :selector) method-ast)
|
|
(make-symbol (get method-ast :selector)))))
|
|
((or (= selector "addSelector:withMethod:")
|
|
(= selector "addSelector:method:"))
|
|
(let
|
|
((sel (str (nth args 0)))
|
|
(method-ast (nth args 1)))
|
|
(begin
|
|
(st-class-add-method! name sel method-ast)
|
|
(make-symbol sel))))
|
|
((= selector "removeSelector:")
|
|
(let ((sel (str (nth args 0))))
|
|
(st-class-remove-method! name sel)))
|
|
((= selector "printString") name)
|
|
((= selector "class") (st-class-ref "Metaclass"))
|
|
((= selector "==") (and (st-class-ref? (nth args 0))
|
|
(= name (get (nth args 0) :name))))
|
|
((= selector "=") (and (st-class-ref? (nth args 0))
|
|
(= name (get (nth args 0) :name))))
|
|
((= selector "isNil") false)
|
|
((= selector "notNil") true)
|
|
(else :unhandled)))))
|
|
|
|
;; Run a chunk-format Smalltalk program. Do-it expressions execute in a
|
|
;; fresh top-level frame (with an active-cell so ^expr works). Method
|
|
;; chunks register on the named class.
|
|
(define
|
|
smalltalk-load
|
|
(fn
|
|
(src)
|
|
(let ((entries (st-parse-chunks src)) (last-result nil))
|
|
(begin
|
|
(for-each
|
|
(fn (entry)
|
|
(let ((kind (get entry :kind)))
|
|
(cond
|
|
((= kind "expr")
|
|
(let ((cell {:active true}))
|
|
(set!
|
|
last-result
|
|
(call/cc
|
|
(fn (k)
|
|
(smalltalk-eval-ast
|
|
(get entry :ast)
|
|
(st-make-frame nil nil nil k cell)))))
|
|
(dict-set! cell :active false)))
|
|
((= kind "method")
|
|
(cond
|
|
((get entry :class-side?)
|
|
(st-class-add-class-method!
|
|
(get entry :class)
|
|
(get (get entry :ast) :selector)
|
|
(get entry :ast)))
|
|
(else
|
|
(st-class-add-method!
|
|
(get entry :class)
|
|
(get (get entry :ast) :selector)
|
|
(get entry :ast)))))
|
|
(else nil))))
|
|
entries)
|
|
last-result))))
|
|
|
|
;; Convenience: parse and evaluate a Smalltalk expression with no receiver.
|
|
(define
|
|
smalltalk-eval
|
|
(fn
|
|
(src)
|
|
(let ((cell {:active true}))
|
|
(let
|
|
((result
|
|
(call/cc
|
|
(fn (k)
|
|
(let
|
|
((ast (st-parse-expr src))
|
|
(frame (st-make-frame nil nil nil k cell)))
|
|
(smalltalk-eval-ast ast frame))))))
|
|
(begin (dict-set! cell :active false) result)))))
|
|
|
|
;; Evaluate a sequence of statements at the top level.
|
|
(define
|
|
smalltalk-eval-program
|
|
(fn
|
|
(src)
|
|
(let ((cell {:active true}))
|
|
(let
|
|
((result
|
|
(call/cc
|
|
(fn (k)
|
|
(let
|
|
((ast (st-parse src))
|
|
(frame (st-make-frame nil nil nil k cell)))
|
|
(begin
|
|
(when
|
|
(and (dict? ast) (has-key? ast :temps))
|
|
(for-each
|
|
(fn (t) (dict-set! (get frame :locals) t nil))
|
|
(get ast :temps)))
|
|
(smalltalk-eval-ast ast frame)))))))
|
|
(begin (dict-set! cell :active false) result)))))
|