;;;
;;; bootstrap.lisp
;;;
;;; Initial smalltalk image bootstrap machinery.
;;;

(cl:in-package :speakeasy)

;;;
;;; Compiled methods.
;;;

;; Compiled methods are the weirdest objects in Smalltalk.  They
;; combine an indexed pointer data area with an indexed byte data area
;; (the only class to do so), and have two "special" locations within
;; the literal area that have special uses.  The last literal slot is
;; used, in methods which use a super-send bytecode, to hold the
;; Association from the system dictionary between the class name and
;; the class.  The next-to-last literal slot holds a header extension
;; word in those methods which require it (those with associated
;; primitive routines or requiring more than four arguments).

;; As laying out methods by hand would be tedious at best, the current
;; thought is to write a compiler in Lisp for bootstrap purposes (if
;; not production use).

;; This is a low-level pure object-creation function.  It doesn't do
;; any hand-holding like setting the method class for methods using
;; super sends, setting header extensions, declarative header
;; creation, setting the method up in a method dictionary, or anything
;; like that.
(defun create-method (header literals bytecode)
  (let ((oop (allocate-oop))
	(length (1+ (+ (length literals)
		       (ash (1+ (length bytecode)) -1))))
	(bytecode-start (ash (1+ (length literals)) 1)))

    (make-object oop :pointers length +compiled-method-class-oop+)

    (setf (obj-oop oop 0) header)

    (loop for literal in literals
	  for index from 1
	  do (setf (obj-oop oop index) literal))

    (loop for byte across bytecode
	  for index from bytecode-start
	  do (setf (obj-byte oop index) byte))

    oop))

(defun set-class-method (class selector method)
  (add-method-to-dictionary (obj-oop class +method-dictionary-ofs+)
			    selector method))

(defun define-method (classname code)
  (let* ((method-class (dictionary-association-at +smalltalk-oop+
						  (intern-symbol classname)))
	 (class (association-value method-class))
	 (parsed-code (parse-method-definition code))
	 (selector (intern-symbol (parsed-code-selector parsed-code))))
    (multiple-value-bind (header literals bytecode)
	(compile-method class parsed-code method-class)
      (set-class-method class selector
			(create-method header literals bytecode)))))

(defun define-class-method (classname code)
  (let* ((class (dictionary-at +smalltalk-oop+
			       (intern-symbol classname)))
	 (parsed-code (parse-method-definition code))
	 (selector (intern-symbol (parsed-code-selector parsed-code))))
    (multiple-value-bind (header literals bytecode)
	(compile-method class parsed-code nil)
      (set-class-method (obj-class class) selector
			(create-method header literals bytecode)))))

;;;
;;; Bootstrap compile-from-source.
;;;

(defun compile-system-methods ()
  "Build the smalltalk method definitions in the image-source
   directory.  This function is also the hook to use if/when
   we switch to a traditional Smalltalk sources file in
   interchange format."
  (dolist (file (directory #p"image-source/*.lst"))
    (load file)))

;;;
;;; Building the virtual image.
;;;

(defun bootstrap-image ()
  ;; Reset the object memory and known pointers.
  (clear-object-memory)
  (reset-known-oops)
  (setf *symbol-mapping* (make-hash-table :test 'equal))

  ;; Preset +nil-oop+ so we can run create-dictionary.
  (setf +nil-oop+ 2)

  ;; Smalltalk
  (setf +smalltalk-oop+ (create-dictionary))
  (with-ote (ob +smalltalk-oop+)
    ;; Special case dictionary.
    (setf (ote-class ob) 'system-dictionary))

  ;; nil
  (assert (= +nil-oop+ (allocate-oop)))
  (make-object +nil-oop+ :pointers 0 'undefined-object)

  ;; False
  (setf +false-oop+ (allocate-oop))
  (make-object +false-oop+ :pointers 0 'false)
  
  ;; True
  (setf +true-oop+ (allocate-oop))
  (make-object +true-oop+ :pointers 0 'true)

  ;; Known method selectors.
  (setf +does-not-understand-oop+ (intern-symbol "doesNotUnderstand:"))
  (setf +cannot-return-oop+ (intern-symbol "cannotReturn:"))
  (setf +must-be-boolean-oop+ (intern-symbol "mustBeBoolean"))

  ;; Globals thus far allocated.
  (dictionary-at-put +smalltalk-oop+ (intern-symbol "Smalltalk") +smalltalk-oop+)
  (dictionary-at-put +smalltalk-oop+ (intern-symbol "nil") +nil-oop+)
  (dictionary-at-put +smalltalk-oop+ (intern-symbol "false") +false-oop+)
  (dictionary-at-put +smalltalk-oop+ (intern-symbol "true") +true-oop+)

  ;; Initial class/metaclass hierarchy setup.
  (define-class nil "Object")
  (define-class "Object" "Behavior" :inst-vars '("superclass" "methodDictionary" "instanceSpec"))
  (define-class "Behavior" "ClassDescription" :inst-vars '("name" "comment" "instVars" "methodCategories"))
  (define-class "ClassDescription" "Class" :inst-vars '("classPool"))
  (define-class "ClassDescription" "Metaclass")

  ;; Fix Object class superclass (is nil during creation).
  (with-ote (obj (dictionary-at +smalltalk-oop+ (intern-symbol "Object")))
    (setf (obj-oop (ote-class obj) +superclass-ofs+)
	  (dictionary-at +smalltalk-oop+ (intern-symbol "Class"))))

  ;; Control flow classes.
  (define-class "Object" "Boolean")
  (define-class "Boolean" "False")
  (define-class "Boolean" "True")
  (define-class "Object" "UndefinedObject")

  ;; Numberish things.
  (define-class "Object" "Magnitude")
  (define-class "Magnitude" "Character" :encoding :variable-byte)
  (define-class "Magnitude" "Number")
  (define-class "Number" "Integer")
  (define-class "Integer" "SmallInteger")
  ;; FIXME: Float, Fraction, Date, Time, LargeNegativeInteger and
  ;; LargePositiveInteger go here.
  (define-class "Magnitude" "LookupKey")
  (define-class "LookupKey" "Association" :inst-vars '("key" "value"))

  ;; Collection classes.
  (define-class "Object" "Collection")
  (define-class "Collection" "SequencableCollection")
  (define-class "SequencableCollection" "ArrayedCollection")
  (define-class "ArrayedCollection" "Array" :encoding :variable)
  (define-class "ArrayedCollection" "String" :encoding :variable-byte)
  (define-class "String" "Symbol" :encoding :variable-byte)
  (define-class "Collection" "Set" :encoding :variable :inst-vars '("tally"))
  (define-class "Set" "Dictionary" :encoding :variable)
  (define-class "Dictionary" "IdentityDictionary" :encoding :variable
		:inst-vars '("values"))
  (define-class "Dictionary" "SystemDictionary" :encoding :variable)

  ;; CharacterTable and the Characters.
  (setf +character-table-oop+ (allocate-oop))
  (make-object +character-table-oop+ :pointers 256 +array-class-oop+)
  (dictionary-at-put +smalltalk-oop+ (intern-symbol "CharacterTable")
		     +character-table-oop+)

  (dotimes (i #x100)
    (let ((oop (allocate-oop)))
      (make-object oop :bytes 1 +character-class-oop+)
      (setf (obj-byte oop 0) i)
      (setf (obj-oop +character-table-oop+ i) oop)))

  ;; Methods.
  (define-class "Object" "CompiledMethod" :inst-vars '("header") :encoding :variable)

  ;; Snap all placeholder class links.
  (class-fixup 'undefined-object "UndefinedObject")
  (class-fixup 'false "False")
  (class-fixup 'true "True")
  (class-fixup 'system-dictionary "SystemDictionary")

  (setf +array-class-oop+ (class-fixup 'array "Array"))
  (setf +symbol-class-oop+ (class-fixup 'symbol "Symbol"))
  (setf +string-class-oop+ (class-fixup 'string "String"))
  (setf +association-class-oop+ (class-fixup 'association "Association"))
  (setf +identity-dictionary-class-oop+ (class-fixup 'identity-dictionary "IdentityDictionary"))
  (setf +dictionary-class-oop+ (class-fixup 'dictionary "Dictionary"))
  (setf +character-class-oop+ (class-fixup 'character "Character"))
  (setf +metaclass-class-oop+ (class-fixup 'metaclass "Metaclass"))
  (setf +compiled-method-class-oop+ (class-fixup 'compiled-method "CompiledMethod"))

  ;; Initial method load.
  (compile-system-methods)

  ;; Scheduler setup and initial task.
)

;;; EOF
