load-st.fn

;; Use ./fn -S examples/load-st.fn

(load-file "examples/grammar-utils.fn")
(def smalltalk-grammar (load-grammar! "examples/smalltalk.g"))

(defmacro st-body (varnames &rest body)
  `(let ,(map (lambda (varname) `(,varname nil))
              varnames)
     ,@body))

; TODO: Solve non-local returns!
(defmacro st-return (e) e)
(defmacro st-comment (ignored) 'true)

(defm CompiledProcedure 'value () (self))
(defm CompiledProcedure 'value: (a) (self a))
(defm CompiledProcedure 'value:value: (a b) (self a b))
(defm CompiledProcedure 'value:value:value: (a b c) (self a b c))
(defm CompiledProcedure 'onError: (aHandler)
  (catch self aHandler))

(defmacro st-defm (type sel vars body)
  `(defm ,type (quote ,sel) ,vars
     ,body))

(defm Smallint '+ (other) (+ self other))
(defm Smallint '* (other) (* self other))
(defm Smallint '/ (other) (/ self other))
(defm Smallint '- (other) (- self other))
(defm Smallint '< (other) (< self other))
(defm Smallint '> (other) (< other self))
(defm Smallint '= (other) (= self other))
(defm Smallint '% (other) (mod self other))

(defm Dict 'keyValuePairs ()      (dict-key-value-pairs self))
(defm Dict 'put:at: (value key)   (dict-put! self key value))
(defm Dict 'at: (key)             (dict-get self key))

(defm Object 'println ()          (println self))
(defm Object 'class ()            (type-of self))
(defm Object 'send: (message)     (send self message))

(defm Object 'send:withArguments: (message args)
  (%send self message (type-of self) args))

(defm String 'length ()           (string-size self))
(defm String '= (other)           (string=? self other))
(defm String '++ (other)          (string-append self other))
(defm String 'startsWith: (other) (string-prefix? other self))

(defm Symbol 'asString ()         (symbol->string self))

(def expressions
 ((read-and-check-empty-remainder (@@ smalltalk-grammar file))
  (file->string "examples/st.st")))

(def Smalltalk
  (progn
    (deftype Smalltalk)

    (defm Smalltalk 'object:at: (obj pos)          ($mem-get obj pos))
    (defm Smalltalk 'object:put:at: (obj val pos)  ($mem-set! obj pos val))
    (defm Smalltalk 'prettyprint: (obj)            (pprint obj))
    (defm Smalltalk 'raise: (exception)            (raise exception))
    (defm Smalltalk 'eval: (str)
      (eval ((read-and-check-empty-remainder (@@ smalltalk-grammar statement)) str)))
    (defm Smalltalk 'makeObject:slot: (class slot1)
      ($make class slot1))
    (defm Smalltalk 'loadLisp: (filename)
      (load-file filename))
    (defm Smalltalk 'gc ()
      (run-gc))

    ($make Smalltalk)))

(defm Type 'subclass: (name)
  (make-type name self))

(defm (type-of Cons) 'car:cdr: (car cdr)
  (cons car cdr))

;; -- arrays
(defm (type-of Array) 'newWithCapacity: (capacity) (make-array capacity))
(defm Array 'size ()                               (array-size self))
(defm Array 'asList ()                             (array->list self))
(defm Array 'at: (pos)                             (array-ref self pos))
(defm Array 'set:at: (value pos)                   (array-set! self pos value))


(load-file "repl/c-loader.fn")
(load-c-module "repl/readline.so" "init_readline")

(deftype Readline)
(defm Readline 'addToHistory: (str)
  (add-history str))  ; from readline module
(defm Readline 'readline: (prompt)
  (readline prompt))

(def RL ($make Readline nil))

(defn readline-completion-entry (text state global-env)
  (send RL 'complete:state:globalEnv: text state global-env))

(deftype Main)
(def *main* ($make Main *args*))

(map (lambda (ex)
       ;(println ex)
       (eval ex))
     expressions)

;(println "Result: " res)

(send *main* 'main)