objects.fn

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Types                                                          ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; A type is an object with the layout
;;
;;   +------+--------------+------+-----------+
;;   | type | method-table | name | supertype |
;;   +------+--------------+------+-----------+
;;      ^                               ^
;;    is-a                        is-subclass-of
;;
;; Note:
;;
;;  * Any object has a type, so type objects do too.
;;    A type object's type is Type.
;;  * A type will usually have a supertype.
;;  * The name is given as a string and reads often as "Foo class".
;;
;; In the following code we need to resolve a roundtrip:
;;
;;  * Object is-a Type
;;  * Type is-subclass-of Object
;;
;; Only one of the two objects can be "complete" from scratch,
;; the other one can't and needs to be patched afterwards.

;; TODO: There is too much patching happening here.

(def Object ($make 1 2 3 4))
; Type is set below, Object and Type refer to each other.
($mem-set! Object 1 (make-dict))
($mem-set! Object 2 "Object")
($mem-set! Object 3 nil) ; supertype

;; The type Type links to itself: Type = ($make Type (make-dict) "Type")
(def Type ($make 1 2 3 4))
($mem-set! Type 0 Type)
($mem-set! Type 1 (make-dict))
($mem-set! Type 2 "Object class")
($mem-set! Type 3 Object)

(defn type-name (type) ($mem-get type 2))
(defn type-superclass (type) ($mem-get type 3))
(defn subtype? (subtype supertype)
  (or (eq? subtype supertype)
      (and (not (eq? subtype Object))
           (subtype? (type-superclass subtype) supertype))))

(defn type? (x)
  (subtype? (type-of x) Type))

(defn is-a? (obj type)
  (subtype? (type-of obj) type))

; Close the loop.
($mem-set! Object 0 Type)


(defn $bolt-on-metaclass! (type)
  (let ((metaclass
         ($make Type (make-dict)
                (string-append (type-name type) " class")
                ($mem-get (type-superclass type) 0))))
    ($mem-set! type 0 metaclass)))

; Cons and others must be created early for object creation from C,
; so we need some retroactive patching.  Idea is still this:
;  (def Cons ($make Type (make-dict)))
(defn $patch-type! (type name)
  ($mem-set! type 0 Type)  ; not needed?
  ($mem-set! type 1 (make-dict))
  ($mem-set! type 2 name)
  ($mem-set! type 3 Object)
  ($bolt-on-metaclass! type))

;; TODO: Refactor duplication in strings and symbols.
($patch-type! Array "Array")
($patch-type! Cons "Cons")
($patch-type! Dict "Dict")
($patch-type! Frame "Frame")
($patch-type! Stack "Stack")
($patch-type! String "String")
($patch-type! Symbol "Symbol")
($patch-type! DefinedVar "DefinedVar")
($patch-type! UndefinedVar "UndefinedVar")
;; TODO: Bool and false should share a common supertype.
($patch-type! True "True")
($patch-type! False "False")

; Same procedure for Procedure.
($patch-type! NativeProcedure "NativeProcedure")
($patch-type! CompiledProcedure "CompiledProcedure")

(defn make-type (name supertype)
  (let ((result ($make Type (make-dict) name supertype)))
    ($bolt-on-metaclass! result)
    result))

(defmacro deftype (name)
  `(def ,name (make-type ,(symbol->string name) Object)))

(deftype Smallint)
(deftype Character)
(deftype Nil)
(deftype MemBlock)

;; Hardcoded for half-primitive values like integers,
;; characters, nil and so forth.  For higher-level,
;; memory-allocated values, the value at position 0
;; is used as type.
(defn type-of (x)
  (cond ((mem? x)       ($mem-get x 0))
        ((number? x)    Smallint)
        ((char? x)      Character)
        ((nil? x)       Nil)
        ((mem-block? x) MemBlock)))

;;; Method definition
(defn install-method! (type selector method)
  (assert (type? type))
  (dict-put! ($mem-get type 1) selector method))

(defmacro defm (type selector args &rest body)
  `(install-method! ,type ,selector
                    (lambda (self ,@args) ,@body)))


;;; Message sending

(defm Object 'unknownMessage:arguments: (selector args)
  (println "*** Crashing.")
  (println self " does not understand the message")
  (println "  with selector: " selector)
  (println "  and arguments: " args)
  (raise 'unknown-message))

(defn %send (receiver message type arguments)
  (cond ((nil? type)  ; at top of inheritance chain.
         (%send receiver 'unknownMessage:arguments: (type-of receiver)
                (list message arguments)))
        ((dict-has-key? ($mem-get type 1) message)
         (apply (dict-get ($mem-get type 1) message)
                (cons receiver arguments)))
        (true
         (%send receiver message ($mem-get type 3) arguments))))

(defn send (receiver message &rest arguments)
  (%send receiver message (type-of receiver) arguments))

;; Shortcut for sending messages that reads a bit better :)
(defmacro ! (receiver unquoted-selector &rest args)
  `(send ,receiver (quote ,unquoted-selector) ,@args))

(defn has-method? (receiver selector)
  ;; Limitation: Only works if 'unknownMessage:arguments: is not used.
  (dict-has-key? ($mem-get (type-of receiver) 1)
                 selector))


;; Structs, fields and dynamic field hints.
(defn type-set-field-hints! (type fields)
  (install-method! (type-of type) 'fields
                   (lambda (self) fields)))

(type-set-field-hints! Object '())
(type-set-field-hints! Cons '(car cdr))


;; Example:
;; (defstruct Foo (field1 field2)
;;   (constructor new (meh)
;;     (set! field1 nil)
;;     (set! field2 meh))
;;   (method pprint () (string-append "<Foo " field1 " " field2 ">"))
;;   (method foo (x) (+ x field1)))
(defmacro defstruct (name fields &rest body)
  (with-gensyms (type)
    (defn rewrite-clause (clause)
      (match clause
	((constructor name lambda-list &rest body)
	 `(install-method! (type-of ,type) (quote ,name)
            (lambda (class ,@lambda-list)
	      ((lambda ,fields
		 ,@body
		 ($make ,type ,@fields))
	       ,@(map (lambda (_) 'nil) fields)))))
        ((method name lambda-list &rest body)
         `(install-method! ,type (quote ,name)
            (lambda (self ,@lambda-list)
              ($fields (self ,(cons nil fields))
                ,@body))))
	((classmethod name lambda-list &rest body)
         `(install-method! (type-of ,type) (quote ,name)
            (lambda (self ,@lambda-list)
	      ,@body)))))

    `(def ,name
       (let ((,type (make-type ,(symbol->string name) Object)))
	 ;; The 'fields method comes for free.
	 (type-set-field-hints! ,type (quote ,fields))

         ,@(map rewrite-clause body)
         ,type))))