giles
fa600442d6
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
758 lines
28 KiB
Plaintext
758 lines
28 KiB
Plaintext
;; 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 {})
|
|
|
|
;; ── Method-lookup cache ────────────────────────────────────────────────
|
|
;; Cache keys are "class|selector|side"; side is "i" (instance) or "c" (class).
|
|
;; Misses are stored as the sentinel :not-found so we don't re-walk for
|
|
;; every doesNotUnderstand call.
|
|
(define st-method-cache {})
|
|
(define st-method-cache-hits 0)
|
|
(define st-method-cache-misses 0)
|
|
|
|
(define
|
|
st-method-cache-clear!
|
|
(fn () (set! st-method-cache {})))
|
|
|
|
(define
|
|
st-method-cache-key
|
|
(fn (cls sel class-side?) (str cls "|" sel "|" (if class-side? "c" "i"))))
|
|
|
|
(define
|
|
st-method-cache-stats
|
|
(fn
|
|
()
|
|
{:hits st-method-cache-hits
|
|
:misses st-method-cache-misses
|
|
:size (len (keys st-method-cache))}))
|
|
|
|
(define
|
|
st-method-cache-reset-stats!
|
|
(fn ()
|
|
(begin
|
|
(set! st-method-cache-hits 0)
|
|
(set! st-method-cache-misses 0))))
|
|
|
|
(define
|
|
st-class-table-clear!
|
|
(fn ()
|
|
(begin
|
|
(set! st-class-table {})
|
|
(st-method-cache-clear!))))
|
|
|
|
(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 {}}))
|
|
;; A redefined class can invalidate any cache entries that walked
|
|
;; through its old position in the chain. Cheap + correct: drop all.
|
|
(st-method-cache-clear!)
|
|
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))))
|
|
(st-method-cache-clear!)
|
|
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))))
|
|
(st-method-cache-clear!)
|
|
selector)))))))
|
|
|
|
;; Remove a method from a class (instance side). Mostly for tests; runtime
|
|
;; reflection in Phase 4 will use the same primitive.
|
|
(define
|
|
st-class-remove-method!
|
|
(fn
|
|
(cls-name selector)
|
|
(let ((cls (st-class-get cls-name)))
|
|
(cond
|
|
((= cls nil) (error (str "st-class-remove-method!: unknown class " cls-name)))
|
|
(else
|
|
(let ((md (get cls :methods)))
|
|
(cond
|
|
((not (has-key? md selector)) false)
|
|
(else
|
|
(let ((new-md {}))
|
|
(begin
|
|
(for-each
|
|
(fn (k)
|
|
(when (not (= k selector))
|
|
(dict-set! new-md k (get md k))))
|
|
(keys md))
|
|
(set!
|
|
st-class-table
|
|
(assoc
|
|
st-class-table
|
|
cls-name
|
|
(assoc cls :methods new-md)))
|
|
(st-method-cache-clear!)
|
|
true))))))))))
|
|
|
|
;; Walk-only lookup. Returns the method record (with :defining-class) or nil.
|
|
;; class-side? = true searches :class-methods, false searches :methods.
|
|
(define
|
|
st-method-lookup-walk
|
|
(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))))
|
|
|
|
;; Cached lookup. Misses are stored as :not-found so doesNotUnderstand paths
|
|
;; don't re-walk on every send.
|
|
(define
|
|
st-method-lookup
|
|
(fn
|
|
(cls-name selector class-side?)
|
|
(let ((key (st-method-cache-key cls-name selector class-side?)))
|
|
(cond
|
|
((has-key? st-method-cache key)
|
|
(begin
|
|
(set! st-method-cache-hits (+ st-method-cache-hits 1))
|
|
(let ((v (get st-method-cache key)))
|
|
(cond ((= v :not-found) nil) (else v)))))
|
|
(else
|
|
(begin
|
|
(set! st-method-cache-misses (+ st-method-cache-misses 1))
|
|
(let ((found (st-method-lookup-walk cls-name selector class-side?)))
|
|
(begin
|
|
(set!
|
|
st-method-cache
|
|
(assoc
|
|
st-method-cache
|
|
key
|
|
(cond ((= found nil) :not-found) (else found))))
|
|
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! "Fraction" "Number" (list "numerator" "denominator"))
|
|
(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"))
|
|
;; Hashed collection family
|
|
(st-class-define! "HashedCollection" "Collection" (list "array"))
|
|
(st-class-define! "Set" "HashedCollection" (list))
|
|
;; Blocks / contexts
|
|
(st-class-define! "BlockClosure" "Object" (list))
|
|
;; Reflection support — Message holds the selector/args for a DNU send.
|
|
(st-class-define! "Message" "Object" (list "selector" "arguments"))
|
|
(st-class-add-method! "Message" "selector"
|
|
(st-parse-method "selector ^ selector"))
|
|
(st-class-add-method! "Message" "arguments"
|
|
(st-parse-method "arguments ^ arguments"))
|
|
(st-class-add-method! "Message" "selector:"
|
|
(st-parse-method "selector: aSym selector := aSym"))
|
|
(st-class-add-method! "Message" "arguments:"
|
|
(st-parse-method "arguments: anArray arguments := anArray"))
|
|
;; Exception hierarchy — Smalltalk's standard error system on top of
|
|
;; SX's `guard`/`raise`. Subclassing Exception gives you on:do:,
|
|
;; ensure:, ifCurtailed: catching out of the box.
|
|
(st-class-define! "Exception" "Object" (list "messageText"))
|
|
(st-class-add-method! "Exception" "messageText"
|
|
(st-parse-method "messageText ^ messageText"))
|
|
(st-class-add-method! "Exception" "messageText:"
|
|
(st-parse-method "messageText: aString messageText := aString. ^ self"))
|
|
(st-class-define! "Error" "Exception" (list))
|
|
(st-class-define! "ZeroDivide" "Error" (list))
|
|
(st-class-define! "MessageNotUnderstood" "Error" (list))
|
|
;; SequenceableCollection — shared iteration / inspection methods.
|
|
;; Defined on the parent class so Array, String, Symbol, and
|
|
;; OrderedCollection all inherit. Each method calls `self do:`,
|
|
;; which dispatches to the receiver's primitive do: implementation.
|
|
(st-class-add-method! "SequenceableCollection" "inject:into:"
|
|
(st-parse-method
|
|
"inject: initial into: aBlock
|
|
| acc |
|
|
acc := initial.
|
|
self do: [:e | acc := aBlock value: acc value: e].
|
|
^ acc"))
|
|
(st-class-add-method! "SequenceableCollection" "detect:"
|
|
(st-parse-method
|
|
"detect: aBlock
|
|
self do: [:e | (aBlock value: e) ifTrue: [^ e]].
|
|
^ nil"))
|
|
(st-class-add-method! "SequenceableCollection" "detect:ifNone:"
|
|
(st-parse-method
|
|
"detect: aBlock ifNone: noneBlock
|
|
self do: [:e | (aBlock value: e) ifTrue: [^ e]].
|
|
^ noneBlock value"))
|
|
(st-class-add-method! "SequenceableCollection" "count:"
|
|
(st-parse-method
|
|
"count: aBlock
|
|
| n |
|
|
n := 0.
|
|
self do: [:e | (aBlock value: e) ifTrue: [n := n + 1]].
|
|
^ n"))
|
|
(st-class-add-method! "SequenceableCollection" "allSatisfy:"
|
|
(st-parse-method
|
|
"allSatisfy: aBlock
|
|
self do: [:e | (aBlock value: e) ifFalse: [^ false]].
|
|
^ true"))
|
|
(st-class-add-method! "SequenceableCollection" "anySatisfy:"
|
|
(st-parse-method
|
|
"anySatisfy: aBlock
|
|
self do: [:e | (aBlock value: e) ifTrue: [^ true]].
|
|
^ false"))
|
|
(st-class-add-method! "SequenceableCollection" "includes:"
|
|
(st-parse-method
|
|
"includes: target
|
|
self do: [:e | e = target ifTrue: [^ true]].
|
|
^ false"))
|
|
(st-class-add-method! "SequenceableCollection" "do:separatedBy:"
|
|
(st-parse-method
|
|
"do: aBlock separatedBy: sepBlock
|
|
| first |
|
|
first := true.
|
|
self do: [:e |
|
|
first ifFalse: [sepBlock value].
|
|
first := false.
|
|
aBlock value: e].
|
|
^ self"))
|
|
(st-class-add-method! "SequenceableCollection" "indexOf:"
|
|
(st-parse-method
|
|
"indexOf: target
|
|
| idx |
|
|
idx := 1.
|
|
self do: [:e | e = target ifTrue: [^ idx]. idx := idx + 1].
|
|
^ 0"))
|
|
(st-class-add-method! "SequenceableCollection" "indexOf:ifAbsent:"
|
|
(st-parse-method
|
|
"indexOf: target ifAbsent: noneBlock
|
|
| idx |
|
|
idx := 1.
|
|
self do: [:e | e = target ifTrue: [^ idx]. idx := idx + 1].
|
|
^ noneBlock value"))
|
|
(st-class-add-method! "SequenceableCollection" "reject:"
|
|
(st-parse-method
|
|
"reject: aBlock ^ self select: [:e | (aBlock value: e) not]"))
|
|
(st-class-add-method! "SequenceableCollection" "isEmpty"
|
|
(st-parse-method "isEmpty ^ self size = 0"))
|
|
(st-class-add-method! "SequenceableCollection" "notEmpty"
|
|
(st-parse-method "notEmpty ^ self size > 0"))
|
|
;; (no asString here — Symbol/String have their own primitive
|
|
;; impls; SequenceableCollection-level fallback would overwrite
|
|
;; the bare-name-for-Symbol behaviour.)
|
|
;; ── HashedCollection / Set / Dictionary ──
|
|
;; Implemented as user instances with array-backed storage. Sets
|
|
;; use a single `array` ivar; Dictionaries use parallel `keys`/
|
|
;; `values` arrays. New is class-side and routes through `init`.
|
|
(st-class-add-method! "HashedCollection" "init"
|
|
(st-parse-method "init array := Array new: 0. ^ self"))
|
|
(st-class-add-method! "HashedCollection" "size"
|
|
(st-parse-method "size ^ array size"))
|
|
(st-class-add-method! "HashedCollection" "isEmpty"
|
|
(st-parse-method "isEmpty ^ array isEmpty"))
|
|
(st-class-add-method! "HashedCollection" "notEmpty"
|
|
(st-parse-method "notEmpty ^ array notEmpty"))
|
|
(st-class-add-method! "HashedCollection" "do:"
|
|
(st-parse-method "do: aBlock array do: aBlock. ^ self"))
|
|
(st-class-add-method! "HashedCollection" "asArray"
|
|
(st-parse-method "asArray ^ array"))
|
|
(st-class-add-class-method! "Set" "new"
|
|
(st-parse-method "new ^ super new init"))
|
|
(st-class-add-method! "Set" "add:"
|
|
(st-parse-method
|
|
"add: anObject
|
|
(self includes: anObject) ifFalse: [array add: anObject].
|
|
^ anObject"))
|
|
(st-class-add-method! "Set" "addAll:"
|
|
(st-parse-method
|
|
"addAll: aCollection
|
|
aCollection do: [:e | self add: e].
|
|
^ aCollection"))
|
|
(st-class-add-method! "Set" "remove:"
|
|
(st-parse-method
|
|
"remove: anObject
|
|
array := array reject: [:e | e = anObject].
|
|
^ anObject"))
|
|
(st-class-add-method! "Set" "includes:"
|
|
(st-parse-method "includes: anObject ^ array includes: anObject"))
|
|
(st-class-define! "Dictionary" "HashedCollection" (list "keys" "values"))
|
|
(st-class-add-class-method! "Dictionary" "new"
|
|
(st-parse-method "new ^ super new init"))
|
|
(st-class-add-method! "Dictionary" "init"
|
|
(st-parse-method
|
|
"init keys := Array new: 0. values := Array new: 0. ^ self"))
|
|
(st-class-add-method! "Dictionary" "size"
|
|
(st-parse-method "size ^ keys size"))
|
|
(st-class-add-method! "Dictionary" "isEmpty"
|
|
(st-parse-method "isEmpty ^ keys isEmpty"))
|
|
(st-class-add-method! "Dictionary" "notEmpty"
|
|
(st-parse-method "notEmpty ^ keys notEmpty"))
|
|
(st-class-add-method! "Dictionary" "keys"
|
|
(st-parse-method "keys ^ keys"))
|
|
(st-class-add-method! "Dictionary" "values"
|
|
(st-parse-method "values ^ values"))
|
|
(st-class-add-method! "Dictionary" "at:"
|
|
(st-parse-method
|
|
"at: aKey
|
|
| i |
|
|
i := keys indexOf: aKey.
|
|
i = 0 ifTrue: [^ nil].
|
|
^ values at: i"))
|
|
(st-class-add-method! "Dictionary" "at:ifAbsent:"
|
|
(st-parse-method
|
|
"at: aKey ifAbsent: aBlock
|
|
| i |
|
|
i := keys indexOf: aKey.
|
|
i = 0 ifTrue: [^ aBlock value].
|
|
^ values at: i"))
|
|
(st-class-add-method! "Dictionary" "at:put:"
|
|
(st-parse-method
|
|
"at: aKey put: aValue
|
|
| i |
|
|
i := keys indexOf: aKey.
|
|
i = 0
|
|
ifTrue: [keys add: aKey. values add: aValue]
|
|
ifFalse: [values at: i put: aValue].
|
|
^ aValue"))
|
|
(st-class-add-method! "Dictionary" "includesKey:"
|
|
(st-parse-method "includesKey: aKey ^ (keys indexOf: aKey) > 0"))
|
|
(st-class-add-method! "Dictionary" "removeKey:"
|
|
(st-parse-method
|
|
"removeKey: aKey
|
|
| i nk nv j |
|
|
i := keys indexOf: aKey.
|
|
i = 0 ifTrue: [^ nil].
|
|
nk := Array new: 0. nv := Array new: 0.
|
|
j := 1.
|
|
[j <= keys size] whileTrue: [
|
|
j = i ifFalse: [
|
|
nk add: (keys at: j).
|
|
nv add: (values at: j)].
|
|
j := j + 1].
|
|
keys := nk. values := nv.
|
|
^ aKey"))
|
|
(st-class-add-method! "Dictionary" "do:"
|
|
(st-parse-method "do: aBlock values do: aBlock. ^ self"))
|
|
(st-class-add-method! "Dictionary" "keysDo:"
|
|
(st-parse-method "keysDo: aBlock keys do: aBlock. ^ self"))
|
|
(st-class-add-method! "Dictionary" "valuesDo:"
|
|
(st-parse-method "valuesDo: aBlock values do: aBlock. ^ self"))
|
|
(st-class-add-method! "Dictionary" "keysAndValuesDo:"
|
|
(st-parse-method
|
|
"keysAndValuesDo: aBlock
|
|
| i |
|
|
i := 1.
|
|
[i <= keys size] whileTrue: [
|
|
aBlock value: (keys at: i) value: (values at: i).
|
|
i := i + 1].
|
|
^ self"))
|
|
(st-class-define! "IdentityDictionary" "Dictionary" (list))
|
|
;; ── Stream hierarchy ──
|
|
;; Streams wrap a collection with a 0-based `position`. Read/peek
|
|
;; advance via `at:` (1-indexed Smalltalk-style) on the collection.
|
|
;; Write streams require a mutable collection (Array works; String
|
|
;; doesn't, see Phase 5 follow-up).
|
|
(st-class-define! "Stream" "Object" (list))
|
|
(st-class-define! "PositionableStream" "Stream" (list "collection" "position"))
|
|
(st-class-define! "ReadStream" "PositionableStream" (list))
|
|
(st-class-define! "WriteStream" "PositionableStream" (list))
|
|
(st-class-define! "ReadWriteStream" "WriteStream" (list))
|
|
(st-class-add-class-method! "ReadStream" "on:"
|
|
(st-parse-method "on: aColl ^ super new on: aColl"))
|
|
(st-class-add-class-method! "WriteStream" "on:"
|
|
(st-parse-method "on: aColl ^ super new on: aColl"))
|
|
(st-class-add-class-method! "WriteStream" "with:"
|
|
(st-parse-method
|
|
"with: aColl
|
|
| s |
|
|
s := super new on: aColl.
|
|
s setToEnd.
|
|
^ s"))
|
|
(st-class-add-class-method! "ReadWriteStream" "on:"
|
|
(st-parse-method "on: aColl ^ super new on: aColl"))
|
|
(st-class-add-method! "PositionableStream" "on:"
|
|
(st-parse-method
|
|
"on: aColl collection := aColl. position := 0. ^ self"))
|
|
(st-class-add-method! "PositionableStream" "atEnd"
|
|
(st-parse-method "atEnd ^ position >= collection size"))
|
|
(st-class-add-method! "PositionableStream" "position"
|
|
(st-parse-method "position ^ position"))
|
|
(st-class-add-method! "PositionableStream" "position:"
|
|
(st-parse-method "position: n position := n. ^ self"))
|
|
(st-class-add-method! "PositionableStream" "reset"
|
|
(st-parse-method "reset position := 0. ^ self"))
|
|
(st-class-add-method! "PositionableStream" "setToEnd"
|
|
(st-parse-method "setToEnd position := collection size. ^ self"))
|
|
(st-class-add-method! "PositionableStream" "contents"
|
|
(st-parse-method "contents ^ collection"))
|
|
(st-class-add-method! "PositionableStream" "skip:"
|
|
(st-parse-method "skip: n position := position + n. ^ self"))
|
|
(st-class-add-method! "ReadStream" "next"
|
|
(st-parse-method
|
|
"next
|
|
self atEnd ifTrue: [^ nil].
|
|
position := position + 1.
|
|
^ collection at: position"))
|
|
(st-class-add-method! "ReadStream" "peek"
|
|
(st-parse-method
|
|
"peek
|
|
self atEnd ifTrue: [^ nil].
|
|
^ collection at: position + 1"))
|
|
(st-class-add-method! "ReadStream" "upToEnd"
|
|
(st-parse-method
|
|
"upToEnd
|
|
| result |
|
|
result := Array new: 0.
|
|
[self atEnd] whileFalse: [result add: self next].
|
|
^ result"))
|
|
(st-class-add-method! "ReadStream" "next:"
|
|
(st-parse-method
|
|
"next: n
|
|
| result i |
|
|
result := Array new: 0.
|
|
i := 0.
|
|
[(i < n) and: [self atEnd not]] whileTrue: [
|
|
result add: self next.
|
|
i := i + 1].
|
|
^ result"))
|
|
(st-class-add-method! "WriteStream" "nextPut:"
|
|
(st-parse-method
|
|
"nextPut: anObject
|
|
collection add: anObject.
|
|
position := position + 1.
|
|
^ anObject"))
|
|
(st-class-add-method! "WriteStream" "nextPutAll:"
|
|
(st-parse-method
|
|
"nextPutAll: aCollection
|
|
aCollection do: [:e | self nextPut: e].
|
|
^ aCollection"))
|
|
;; ReadWriteStream inherits from WriteStream + ReadStream behaviour;
|
|
;; for the simple linear-position model, both nextPut: and next work.
|
|
(st-class-add-method! "ReadWriteStream" "next"
|
|
(st-parse-method
|
|
"next
|
|
self atEnd ifTrue: [^ nil].
|
|
position := position + 1.
|
|
^ collection at: position"))
|
|
(st-class-add-method! "ReadWriteStream" "peek"
|
|
(st-parse-method
|
|
"peek
|
|
self atEnd ifTrue: [^ nil].
|
|
^ collection at: position + 1"))
|
|
;; ── Fraction ──
|
|
;; Rational numbers stored as numerator/denominator, normalized
|
|
;; (sign on numerator, denominator > 0, reduced via gcd).
|
|
(st-class-add-class-method! "Fraction" "numerator:denominator:"
|
|
(st-parse-method
|
|
"numerator: n denominator: d
|
|
| f |
|
|
f := super new.
|
|
^ f setNumerator: n denominator: d"))
|
|
(st-class-add-method! "Fraction" "setNumerator:denominator:"
|
|
(st-parse-method
|
|
"setNumerator: n denominator: d
|
|
| g s nn dd |
|
|
d = 0 ifTrue: [Error signal: 'Fraction denominator cannot be zero'].
|
|
s := (d < 0) ifTrue: [-1] ifFalse: [1].
|
|
nn := n * s. dd := d * s.
|
|
g := nn abs gcd: dd.
|
|
g = 0 ifTrue: [g := 1].
|
|
numerator := nn / g.
|
|
denominator := dd / g.
|
|
^ self"))
|
|
(st-class-add-method! "Fraction" "numerator"
|
|
(st-parse-method "numerator ^ numerator"))
|
|
(st-class-add-method! "Fraction" "denominator"
|
|
(st-parse-method "denominator ^ denominator"))
|
|
(st-class-add-method! "Fraction" "+"
|
|
(st-parse-method
|
|
"+ other
|
|
^ Fraction
|
|
numerator: numerator * other denominator + (other numerator * denominator)
|
|
denominator: denominator * other denominator"))
|
|
(st-class-add-method! "Fraction" "-"
|
|
(st-parse-method
|
|
"- other
|
|
^ Fraction
|
|
numerator: numerator * other denominator - (other numerator * denominator)
|
|
denominator: denominator * other denominator"))
|
|
(st-class-add-method! "Fraction" "*"
|
|
(st-parse-method
|
|
"* other
|
|
^ Fraction
|
|
numerator: numerator * other numerator
|
|
denominator: denominator * other denominator"))
|
|
(st-class-add-method! "Fraction" "/"
|
|
(st-parse-method
|
|
"/ other
|
|
^ Fraction
|
|
numerator: numerator * other denominator
|
|
denominator: denominator * other numerator"))
|
|
(st-class-add-method! "Fraction" "negated"
|
|
(st-parse-method
|
|
"negated ^ Fraction numerator: numerator negated denominator: denominator"))
|
|
(st-class-add-method! "Fraction" "reciprocal"
|
|
(st-parse-method
|
|
"reciprocal ^ Fraction numerator: denominator denominator: numerator"))
|
|
(st-class-add-method! "Fraction" "="
|
|
(st-parse-method
|
|
"= other
|
|
^ numerator = other numerator and: [denominator = other denominator]"))
|
|
(st-class-add-method! "Fraction" "<"
|
|
(st-parse-method
|
|
"< other
|
|
^ numerator * other denominator < (other numerator * denominator)"))
|
|
(st-class-add-method! "Fraction" "asFloat"
|
|
(st-parse-method "asFloat ^ numerator / denominator"))
|
|
(st-class-add-method! "Fraction" "printString"
|
|
(st-parse-method
|
|
"printString ^ numerator printString , '/' , denominator printString"))
|
|
(st-class-add-method! "Fraction" "isFraction"
|
|
(st-parse-method "isFraction ^ true"))
|
|
"ok")))
|
|
|
|
;; Initialise on load. Tests can re-bootstrap to reset state.
|
|
(st-bootstrap-classes!)
|