smalltalk: fibonacci classic program + smalltalk-load + 13 tests

lib/smalltalk/eval.sx

@@ -698,17 +698,98 @@
       ((= 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") (st-make-instance name))
+        ((= 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)))))
+        ;; 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)
         ((= selector "printString") name)
         ((= selector "class") (st-class-ref "Metaclass"))
         ((= selector "==") (and (st-class-ref? (nth args 0))
@@ -719,6 +800,45 @@
         ((= 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