(declaim (optimize (speed 3) (safety 1)))

(define-object *primitive-nil*
  (traits nil t))

(define-object *traits-method*
  (name "PrimitiveMethod" nil)
  (traits nil t)
  ("parent0" *primitive-nil* t))
(define-object *primitive-method*
  (traits *traits-method* t)
  ("lineNumber" 0 nil)
  ("fileName" "" nil)
  (selector nil nil)
  (accessor nil nil)
  (arguments '())
  ("sourceCode" nil nil)
  (code nil))
;Implemented using *primitive-nil* and *primitive-method*
(add-accessors *traits-method* '|parent0| t)
(add-accessors *traits-method* '|traits| t)
(add-accessors *traits-method* '|name| t)
(add-accessors *primitive-method* '|traits| t)
(add-accessors *primitive-method* '|sourceCode| t)
(add-accessors *primitive-method* '|selector| t)
(add-accessors *primitive-method* '|accessor| t)
(add-accessors *primitive-method* '|lineNumber| t)
(add-accessors *primitive-method* '|fileName| t)
(add-accessors *primitive-nil* '|traits| t)

(defmacro define-named-object (name string-name &rest rest)
  `(define-object ,name (name ,string-name nil :immutable) ,@rest))

(define-method "argumentNames" ((method *traits-method*))
  (coerce (get-slot method '|arguments|) 'vector))

(define-named-object *traits-root* "Root"
  (traits nil t :immutable))
(define-object *primitive-root*
  (traits *traits-root* t :immutable))

(define-named-object *traits-traits* "Traits"
  (parent0 *traits-root* t :immutable))
(define-named-object *primitive-traits* "_"
  (traits *traits-traits* t :immutable))
(set-slot *traits-method* '|traits| *traits-traits*)
(set-slot *traits-root* '|traits| *traits-traits*)

(defmacro define-traits (name string-name &rest slots)
  `(progn
     (define-named-object ,name ,string-name
       (traits *traits-traits* t :immutable) 
       ,@(loop for slot in slots
               and index downfrom (1- (length slots))
           collect (cons (intern (format nil "parent~A" index)) slot)))
     (define-method traits ((obj ,name))
       (if (eq obj ,name)
           *traits-traits*
           ,name))))

(define-traits *traits-oddball* "Oddball"
  (*traits-root* t :immutable))
(define-object *primitive-oddball*
  (traits *traits-oddball* t :immutable))
(set-slot *primitive-nil* '|traits| *traits-oddball*)

(defmacro define-named-oddball (name string-name &rest slots)
  `(define-named-object ,name ,string-name
     (traits *traits-oddball* t :immutable) ,@slots))

(define-named-oddball *no-role* "NoRole")

(define-traits *traits-derivable* "Derivable"
  (*traits-root* t :immutable))
(define-object *primitive-derivable*
  (traits *traits-derivable* t :immutable))

(define-traits *traits-cloneable* "Cloneable"
  (*traits-derivable* t :immutable))
(define-object *primitive-cloneable*
  (traits *traits-cloneable* t :immutable))
(set-slot *traits-method* '|parent0| *traits-cloneable*)

(defmacro bool-of (&body body)
  `(if (progn ,@body) *primitive-true* *primitive-false*))

(defmacro define-resource-method (name arguments &body body)
  (let ((socket-sym (first (first arguments))))
    `(define-method ,name ,arguments
       (let ((,socket-sym (if (wm-object-p ,socket-sym)
			      (get-slot ,socket-sym '|handle|)
			    ,socket-sym)))
	 ,@body))))

(define-traits *traits-lisp* "Lisp"
  (*traits-oddball* t :immutable))

(define-traits *traits-boolean* "Boolean"
  (*traits-oddball* t :immutable))
(define-object *primitive-true*
  (traits *traits-boolean* t :immutable))
(define-object *primitive-false*
  (traits *traits-boolean* t :immutable))

(define-traits *traits-integer* "SmallInteger"
  (*traits-oddball* t :immutable))

(define-traits *traits-character* "Character"
  (*traits-oddball* t :immutable))

(define-traits *traits-array* "Array"
  (*traits-cloneable* t :immutable))

(define-traits *traits-byte-array* "ByteArray"
  (*traits-cloneable* t :immutable))

(define-traits *traits-string* "String"
  (*traits-byte-array* t :immutable))

(define-traits *traits-symbol* "Symbol"
  (*traits-string* t :immutable))

(define-object *primitive-symbol*
  (traits *traits-symbol* t :immutable)
  (name "" nil t))

(define-traits *traits-float* "Float"
  (*traits-byte-array* t :immutable)
  (*traits-cloneable* t :immutable))

(define-traits *traits-file* "FileHandle"
  (*traits-oddball* t t))
(define-object *primitive-file*
  (traits *traits-file* t :immutable))

#+clisp
(progn					; CLISP sockets.
(define-traits *traits-socket-client* "SocketClientHandle"
  (*traits-oddball* t :immutable))
(define-object *primitive-socket-client*
  (traits *traits-socket-client* t :immutable))
(define-traits *traits-socket-server* "SocketServerHandle"
  (*traits-oddball* t :immutable))
(define-object *primitive-socket-server*
  (traits *traits-socket-server* t :immutable))
)

(define-traits *traits-namespace* "Namespace"
  (*traits-cloneable* t :immutable))
(define-object *primitive-namespace*
  (traits *traits-namespace* t :immutable))

#+subjective-slate
(progn
  (define-traits *traits-subject* "Subject"
    (*traits-cloneable* t t))

  (define-object *primitive-subject*
    (traits *traits-subject* t :immutable)
    ("parentSubject" *primitive-nil* t t)
    (focus *primitive-nil* t t)))

#+layered-slate
(progn
  (define-traits *traits-layer* "Layer"
    (*traits-cloneable* t))

  (define-object *primitive-layer*
    (traits *traits-layer* t :immutable)
    ("parentLayer" *primitive-nil* t t)
    (focus *primitive-nil* t t)))

(define-object *primitive-literal* 
  (traits *traits-oddball* t :immutable))

(define-traits *traits-backtrace-frame* "BacktraceFrame"
  (*traits-cloneable* t))

(define-object *primitive-backtrace-frame*
  (traits *traits-backtrace-frame* t :immutable)
  (method *primitive-nil* nil t)
  (selector *primitive-nil* nil t)
  (arguments *primitive-nil* nil t)
  (optionals *primitive-nil* nil t))

(define-object *prototypes*
  (traits *traits-namespace* t :immutable)
  ("Traits" *primitive-traits* nil :immutable)
  ("Root" *primitive-root* nil :immutable)
  ("Cloneable" *primitive-cloneable* nil :immutable)
  ("Oddball" *primitive-oddball* nil :immutable)
  ("Derivable" *primitive-derivable* nil :immutable)
  ("Namespace" *primitive-namespace* nil :immutable)
  ("Nil" *primitive-nil* nil :immutable)
  ("Boolean" *primitive-true* nil :immutable)
  ("True" *primitive-true* nil :immutable)
  ("False" *primitive-false* nil :immutable)
  ("SmallInteger" 0 nil :immutable)
  ("SingleFloat" (make-wm-float) nil :immutable)
  ("DoubleFloat" (make-wm-float) nil :immutable)
  ("ASCIICharacter" #\Nul nil :immutable)
  ("Symbol" '|symbol| nil :immutable)
  ("Array" (make-array 0 :initial-element *primitive-nil*) nil :immutable)
  ("ByteArray" (make-array 0 :element-type '(unsigned-byte 8)) nil :immutable)
  ("String" "" nil :immutable)
  ("FileHandle" *primitive-file* nil :immutable)
  #+clisp ("SocketClientHandle" *primitive-socket-client* nil :immutable)
  #+clisp ("SocketServerHandle" *primitive-socket-server* nil :immutable)
  ("Lisp" (lambda () *primitive-nil*) nil :immutable)
  ("BacktraceFrame" *primitive-backtrace-frame* nil :immutable)
  #+subjective-slate ("Subject" *primitive-subject* nil :immutable)
  #+layered-slate ("Layer" *primitive-layer* nil :immutable)
  ("CompiledMethod" *primitive-method* nil :immutable)
  ("PrimitiveMethod" *primitive-method* nil :immutable))

(define-named-oddball *console* "Console")
(define-named-oddball *platform* "Platform")

; Later replaced by an ExtensibleSequence.
(defvar *slate-modules*
  (make-array 12 :initial-element *primitive-nil* :fill-pointer 0 :adjustable t))

; Later replaced by an ExtensibleSequence.
(defvar *slate-features*
  (make-array 12 :initial-element *primitive-nil* :fill-pointer 0 :adjustable t))

(defvar *slate-characters*
  (coerce
    (loop for i from 0 to 255
      collect (code-char i))
    'simple-vector))

#+clisp
(progn
(define-named-oddball *shell* "Shell")
(define-named-oddball *environment* "Environment")
)

(define-object *globals*
  (traits *traits-namespace* t :immutable)
  ("NoRole" *no-role* nil :immutable)
  #+clisp ("Shell" *shell* nil :immutable)
  #+clisp ("Environment" *environment* nil :immutable)
  ("Console" *console* nil :immutable)
  ("modules" *slate-modules* nil t)
  ("features" *slate-features* nil t)
  ("currentModule" *primitive-nil* nil t)
  ("bootstrapSymbols" *slate-symbols* nil :immutable)
  ("bootstrapCharacters" *slate-characters* nil :immutable)
  ("platform" *platform* nil :immutable))

(define-object *lobby*
  (traits *traits-namespace* t :immutable)
  (lobby *primitive-nil* nil :immutable)
  (prototypes *prototypes* t :immutable)
  (globals *globals* t :immutable))

(set-slot *lobby* '|lobby| *lobby*)

#+subjective-slate
(progn
  (defvar *subject* nil)

  (define-method "withoutSubject" ((method *traits-method*))
    (let ((old-subject *subject*))
      (prog2
        (setf *subject* nil)
        (apply-method method)
        (setf *subject* old-subject))))
        
  (define-method "seenFrom:" ((method *traits-method*) focus)
    (let ((new-subject (clone-object *primitive-subject*))
          (old-subject *subject*))
      (set-slot new-subject '|focus| focus)
      (set-slot new-subject '|parentSubject| old-subject)
      (prog2
        (setf *subject* new-subject)
        (apply-method method)
        (setf *subject* old-subject)))))

#+layered-slate
(progn
  (defvar *layer* nil)

  (define-method "withoutLayers" ((method *traits-method*))
    (let ((old-layer *layer*))
      (prog2
        (setf *layer* nil)
        (apply-method method)
        (setf *layer* old-layer))))

  (define-method "layering:" ((method *traits-method*) focus)
    (let ((new-layer (clone-object *primitive-layer*))
          (old-layer *layer*))
      (set-slot new-layer '|focus| focus)
      (set-slot new-layer '|parentLayer| old-layer)
      (prog2
        (setf *layer* new-layer)
        (apply-method method)
        (setf *layer* old-layer)))))

(unless (fboundp 'exit)
  (setf (fdefinition 'exit) #'quit))
(define-method "exit" ((lobby *lobby*))
  (exit))
(define-method "quit" ((lobby *lobby*))
  (exit))

(define-method "littleEndian" ((platform *platform*))
  *primitive-true*)

(define-method "saveImageNamed:" ((lobby *lobby*) filename)
  (bool-of
      #+clisp
      (ext:saveinitmem filename :quiet t :init-function #'repl)
      #+ecl
      (progn
	(setf compiler::*cc-flags* "-g -I.")
	(c:build-program
	 filename :lisp-files +files+ :ld-flags '()
	 :epilogue-code "funcall(1,_intern(\"REPL\",user_package));"))
      #+openmcl
      (progn
	(setf ccl::*restore-lisp-functions* '(repl))
	(ccl::save-application (format nil "~A.image" filename)))
      #+cormanlisp
      (save-application filename :console t :start-function #'repl :static t)
      #+cmu
      (save-lisp (format nil "~A.core" filename) :init-function #'repl
		 :print-herald nil :site-init nil :load-init-file nil)
      #+sbcl
      (save-lisp-and-die (format nil "~A.core" filename) :toplevel #'repl)
      ))

#+clisp
(progn					; Shell-related methods.
(define-method "runProgram:withArgs:" ((shell *shell*) prog-name args)
  (apply 'ext:execute `(,prog-name ,@(coerce args 'list))))
(define-method "execute:" ((shell *shell*) command-string)
  (ext:shell command-string))
(define-method "enter" ((shell *shell*))
  (ext:shell))
(define-method "run:withArgs:inputFrom:outputTo:"
  ((shell *shell*) command-string args in out)
  (apply 'ext:run-shell-command
	 `(,command-string ,@(coerce args 'list) :input ,in :output ,out)))
(define-method "at:" ((environment *environment*) env-string)
  (or (ext:getenv env-string) *primitive-nil*))
(define-method "at:put:" ((environment *environment*) env-string value-string)
  (or (setf (ext:getenv env-string) value-string) *primitive-nil*))
(define-method "keys" ((environment *environment*))
  (coerce
   (loop for pair in (ext:getenv)
     collect (car pair))
   'vector))
(define-method "values" ((environment *environment*))
  (coerce
   (loop for pair in (ext:getenv)
     collect (cdr pair))
   'vector))
(define-traits *traits-pipe* "Pipe"
  (*traits-oddball* t t))
(define-object *pipe-primitive*
  (traits *traits-pipe* t :immutable)
  (command "" nil))
(define-method "newForCommand:" ((pipe *traits-pipe*) command-string)
  ())
)

; Only here for bootstrapping the libraries.
(define-method "requires:" ((lobby *lobby*) (features *traits-array*))
  (loop for required across features
    when (notany (lambda (present) (eq required present)) *slate-features*)
    do (format t "Feature ~A missing for module ~A.~%"
	       required (get-slot *globals* '|currentModule|)))
  *primitive-nil*)

; Only here for bootstrapping the libraries.
(define-method "provides:" ((lobby *lobby*) (features *traits-array*))
  (loop for provided across features
    unless (some (lambda (present) (eq provided present)) *slate-features*)
    do (vector-push-extend provided *slate-features*))
  *slate-features*)

(define-method "debug" ((lobby *lobby*))
  (bool-of *slate-debug*))

(define-method "debug:" ((lobby *lobby*) (flag *traits-boolean*))
  (bool-of (setf *slate-debug* flag)))

(define-method "byteAt:" ((float *traits-float*) index)
  (ldb (byte 8 (* index 8)) (wm-float-bytes float)))

(define-method "byteAt:put:" ((float *traits-float*) index byte)
  (setf (ldb (byte 8 (* index 8)) (wm-float-bytes float)) (logand byte #xFF))
  (when (= index 3)
    (let* ((bytes (wm-float-bytes float)) 
           (significand (logior (ash 1 23) (ldb (byte 23 0) bytes)))
           (exponent (ldb (byte 8 23) bytes))
           (signed (logbitp 31 bytes)))
      (when signed
        (setf significand (- significand)))
      (setf (wm-float-value float)
            (scale-float (coerce significand 'float) (- exponent 150)))))
  byte)             

(defun %float (float)
  (if (zerop float)
      (make-wm-float)
      (multiple-value-bind (significand exponent sign) (integer-decode-float float)
        (loop until (logbitp 0 significand)
          do (setf significand (ash significand -1))
             (incf exponent))
        (let ((top (1- (integer-length significand))))
          (setf significand (ash significand (- 23 top)))
          (incf exponent top))
        (cond
          ((< exponent -126)
            (setf significand (ash significand (+ exponent 126)))
            (setf exponent 0))
          (t
            (setf significand (ldb (byte 23 0) significand))
            (setf exponent (+ exponent 127))))
        (make-wm-float 
          :bytes 
          (logior (if (< sign 0) (ash 1 31) 0)
                  (ash exponent 23)
                  significand)
          :value float))))         

(define-method "forwardTo:" ((old *traits-root*) (new *traits-root*))
; No-op, just for bootstrapping
  new)

(define-method clone ((float *traits-float*))
  (copy-structure float))

(define-method "code" ((character *traits-character*))
  (char-code character))

(define-method "name" ((selector *traits-symbol*))
  (symbol-name selector))

(define-method "intern:" ((lobby *lobby*) (string *traits-string*))
  (let ((new-sym (intern string)))
    (unless (loop for sym across *slate-symbols*
              when (eq sym new-sym)
                return t)
      (vector-push-extend new-sym *slate-symbols*))
    new-sym))

(define-method "intern:" ((lobby *lobby*) (selector *traits-symbol*))
  (invoke-method '|intern:| nil *lobby* (%symbol-name selector)))

(define-method clone ((selector *traits-symbol*))
  (let ((new-sym (%gensym)))
    (setf (gethash new-sym *literal-objects*) (clone-object *primitive-symbol*))
    new-sym))

(define-method "newSize:" ((selector *traits-symbol*) size)
  (let ((new-sym (%gensym)))
    (setf (gethash new-sym *literal-objects*) (clone-object *primitive-symbol*))
    (set-slot (gethash new-sym *literal-objects*) '|name|  
      (make-array size :element-type 'character :initial-element #\Nul))
    new-sym))
 
(define-method "size" ((selector *traits-symbol*))
  (multiple-value-bind (obj exists) (gethash selector *literal-objects*)
    (length (if exists (get-slot obj '|name|) (symbol-name selector)))))

(define-method "byteAt:" ((selector *traits-symbol*) index)
  (multiple-value-bind (obj exists) (gethash selector *literal-objects*)
    (char-code (char (if exists (get-slot obj '|name|) (symbol-name selector)) index))))

(define-method "byteAt:put:" ((selector *traits-symbol*) index val)
  (setf (char (get-slot (gethash selector *literal-objects*) '|name|) index) (code-char val))
  val)

; The following methods are intended to write to Sequences of some kind, so
; that Arrays, Strings, and ByteArrays may be used equally.
(define-method "read:from:startingAt:into:" ((console *console*)
					     n handle start s)
  (read-sequence s *standard-input* :start start :end (+ start n)))

(define-method "write:to:startingAt:from:" ((console *console*)
					    n handle start s)
  (write-sequence s #-mcl *standard-output* #+mcl *terminal-io* :start start :end (+ start n)))

(define-method "flushOutput" ((console *console*))
  (finish-output #-mcl *standard-output* #+mcl *terminal-io*)
  *primitive-nil*)

(define-method clone ((oddball *traits-oddball*))
  (if (eq oddball *primitive-oddball*)
      (clone-object *primitive-oddball*)
      (invoke-method '|clone| currentMethod oddball)))

(define-method "==" ((x *traits-root*) (y *traits-root*))
  (bool-of (eq x y)))

(define-method "asMethod:on:" ((method *traits-method*) selector array)
  (let ((method (clone-object method)))
    (set-slot method '|selector| selector)
    (apply #'add-roles selector method (coerce array 'list))))

(define-method "asAccessor:for:on:" ((method *traits-method*) accessor slot-name array)
  (let ((method (clone-object method)))
    (set-slot method '|selector| accessor)
    (set-slot method '|accessor| slot-name)
    (apply #'add-roles accessor method (coerce array 'list))))

(define-method "addRolesFrom:" ((x *traits-root*) (y *traits-root*))
  (let ((map 
          (if (wm-object-p y) 
              (wm-object-map y)
              (wm-object-map (gethash y *literal-objects*)))))
    (maphash
      #'(lambda (name slot)
          (loop for role in (wm-slot-roles slot)
                for method = (wm-role-method role)
            when (eq (get-slot method '|accessor|) *primitive-nil*)
              do (add-role x name (wm-role-positions role) (wm-role-arguments role) method)))
     (wm-map-slots map))
    x))

(define-method "addSlotNamed:valued:" ((object *traits-root*) name value)
  (add-slot object (if (symbolp name) name (intern name)) value)
  object)

(define-method "addDelegateNamed:valued:" ((object *traits-root*) name value)
  (add-slot object (if (symbolp name) name (intern name)) value t)
  object)

(define-method "removeSlotNamed:" ((object *traits-root*) name)
  (remove-slot object (if (symbolp name) name (intern name)))
  object)

(define-method "slotNames" ((object *traits-root*))
  (unless (wm-object-p object)
    (setf object (gethash object *literal-objects*))
    (unless object (return #(|traits|))))
  (coerce (wm-map-slot-names (wm-object-map object)) 'vector))

(define-method "delegateNames" ((object *traits-root*))
  (unless (wm-object-p object)
    (setf object (gethash object *literal-objects*))
    (unless object (return #(|traits|))))
  (coerce 
   (loop for slot-name in (wm-map-slot-names (wm-object-map object))
     for slot = (gethash slot-name (wm-map-slots (wm-object-map object)))
     when (wm-slot-delegates slot)
     collect slot-name)
   'vector))

(define-method clone ((object *traits-root*))
  (if (wm-object-p object)
      (clone-object object)
      (invoke-method '|clone| currentMethod object)))
;      (clone-object
;        (or (gethash object *literal-objects*)
;            (let ((representation (make-wm-object)))
;              (add-slot representation '|traits| (traits-for-prim object)
;			t :immutable)
;              representation)))))

(define-method clone ((array *traits-byte-array*))
  (let ((new-array (copy-seq array))
        (representation (gethash array *literal-objects*)))
    (setf (gethash new-array *literal-objects*)
      (if representation
          (clone-object representation)
          (let ((representation (make-wm-object)))
            (add-slot representation '|traits| *traits-byte-array*
		      t :immutable)
            representation)))
    new-array))

(define-method clone ((array *traits-array*))
  (let ((new-array (copy-seq array))
        (representation (gethash array *literal-objects*)))
    (setf (gethash new-array *literal-objects*)
      (if representation
          (clone-object representation)
          (let ((representation (make-wm-object)))
            (add-slot representation '|traits| *traits-array* t :immutable)
            representation)))
    new-array))

(define-method clone ((array *traits-string*))
  (let ((new-array (copy-seq array))
        (representation (gethash array *literal-objects*)))
    (setf (gethash new-array *literal-objects*)
      (if representation
          (clone-object representation)
          (let ((representation (make-wm-object)))
            (add-slot representation '|traits| *traits-string* t :immutable)
            representation)))
    new-array))

(define-method "newSize:" ((array *traits-byte-array*) (size *traits-integer*))
  (let ((representation (if (wm-object-p array) array (gethash array *literal-objects*)))
        (new-array (make-array size :element-type '(unsigned-byte 8) :initial-element 0)))
    (when representation
      (setf (gethash new-array *literal-objects*) (clone-object representation)))
    new-array))

(define-method "newSize:" ((array *traits-array*) (size *traits-integer*))
  (let ((representation (gethash array *literal-objects*))
        (new-array (make-array size :initial-element *primitive-nil*)))
    (when representation
      (setf (gethash new-array *literal-objects*) (clone-object representation)))
    new-array))

(define-method "newSize:" ((array *traits-string*) (size *traits-integer*))
  (let ((representation (gethash array *literal-objects*))
        (new-array (make-array size :element-type 'character :initial-element #\Nul)))
    (when representation
      (setf (gethash new-array *literal-objects*) (clone-object representation)))
    new-array))

(define-method "atSlotNamed:" ((object *traits-root*) (slot *traits-symbol*))
  (if (and (not (wm-object-p object))
           (eq slot '|traits|))
      (invoke-method '|traits| nil object)
      (get-slot object slot)))

(define-method "atSlotNamed:put:" ((object *traits-root*) (slot *traits-symbol*) value)
  (set-slot object slot value))

(define-method "byteAt:" ((array *traits-byte-array*) index)
  (aref array index))

(define-method "byteAt:put:" ((array *traits-byte-array*) index value)
  (setf (aref array index) (logand value #xFF)))

(define-method size ((array *traits-byte-array*))
  (length array))

(define-method size ((float *traits-float*))
  4)

(define-method "at:" ((array *traits-array*) index)
  (aref array index))

(define-method "at:put:" ((array *traits-array*) index value)
  (setf (aref array index) value))

(define-method size ((array *traits-array*))
  (length array))

(define-method "byteAt:" ((string *traits-string*) index)
  (char-code (char string index)))

(define-method "byteAt:put:" ((string *traits-string*) index value)
  (setf (char string index) (code-char value)))

(define-method print ((file *traits-file*))
  (if (wm-object-p file)
      (invoke-method '|print| currentMethod file)
    (format nil "<File named:~A>" (namestring file))))

#+clisp
(define-method print ((socket *traits-socket-server*))
  (if (wm-object-p socket)
      (invoke-method '|print| currentMethod socket)
    (format nil "<SocketServer port:~A>" (socket:socket-server-port socket))))

#+clisp
(define-method print ((socket *traits-socket-client*))
  (if (wm-object-p socket)
      (invoke-method '|print| currentMethod socket)
    (format nil "<SocketClient port:~A>"
	    (second (multiple-value-list
		     (socket::socket-client-peer socket))))))

(define-method print ((object *traits-lisp*))
  (when (wm-object-p object)
    (return-from print
      (invoke-method '|print| currentMethod object)))
  (format nil "<Lambda ~A>" (function-lambda-expression object)))

(define-method loop ((method *traits-method*))
  (loop (apply-method method)) *primitive-nil*)

(define-method time ((method *traits-method*))
  (time (apply-method method)))

(define-method "applyTo:" ((method *traits-method*) arguments &optionals optionals)
  (apply (get-slot method '|code|) method
    (if optionals
        (nconc (coerce arguments 'list) (list (coerce (second optionals) 'list)))
        (coerce arguments 'list))))

(define-method "type" ((platform *platform*))
  (machine-type))

(define-method "version" ((platform *platform*))
  (machine-version))

(define-method "OS" ((platform *platform*))
  (software-type))

(define-method "OSversion" ((platform *platform*))
  (software-version))

(define-resource-method "newNamed:" ((file *traits-file*) (filename *traits-string*))
  (or (open (parse-namestring filename) :direction :io
	    :element-type '(unsigned-byte 8)
	    :if-exists :overwrite :if-does-not-exist nil) *primitive-nil*))

(define-resource-method "newForInputNamed:" ((file *traits-file*) (filename *traits-string*))
  (or (open (parse-namestring filename) :direction :input
	    :element-type '(unsigned-byte 8)
	    :if-does-not-exist nil) *primitive-nil*))

(define-resource-method "newForOutputNamed:" ((file *traits-file*) (filename *traits-string*))
  (or (open (parse-namestring filename) :direction :output
	    :element-type '(unsigned-byte 8)
	    :if-exists :overwrite :if-does-not-exist nil) *primitive-nil*))

(define-resource-method "newForNewNamed:" ((file *traits-file*) (filename *traits-string*))
  (open (parse-namestring filename)
	:element-type '(unsigned-byte 8)
	:direction :io :if-exists :overwrite :if-does-not-exist :create))

(define-resource-method "close" ((file *traits-file*))
  (bool-of (close file)))

(define-resource-method "fullName" ((file *traits-file*))
  (namestring (truename file)))

(define-resource-method "renameTo:" ((file *traits-file*) (newname *traits-string*))
  (multiple-value-bind (new-name old-path new-path) (rename-file file newname)
    (namestring new-path)))

(define-resource-method "delete" ((file *traits-file*))
  (bool-of (delete-file file)))

(define-resource-method "size" ((file *traits-file*))
  (file-length file))

; The following methods are intended to write to Sequences of some kind, so
; that Arrays, Strings, and ByteArrays may be used equally.
(define-resource-method "read:from:startingAt:into:" ((file *traits-file*)
						      n handle start s)
  (read-sequence s file :start start))

(define-resource-method "write:to:startingAt:from:" ((file *traits-file*)
						     n handle start s)
  (write-sequence s file :start start))

(define-resource-method "position" ((file *traits-file*))
  (file-position file))

#-cormanlisp
(define-resource-method "position:" ((file *traits-file*) pos)
  (bool-of (file-position file pos)))

(define-resource-method "size" ((file *traits-file*))
  (file-length file))

(define-resource-method "filename" ((file *traits-file*))
  (namestring file))

(define-method "debugMode" ((lobby *lobby*))
  (bool-of *slate-debuggable*))

(define-method "debugMode:" ((lobby *lobby*) (flag *traits-boolean*))
  (setf *slate-debuggable* (eq flag *primitive-true*))
  flag)

(define-method "backtrace" ((lobby *lobby*))
  (coerce
    (loop for (method selector arguments optionals) in (last *slate-backtrace* 75)
          for backtrace = (clone-object *primitive-backtrace-frame*)
      do (set-slot backtrace '|method| method)
         (set-slot backtrace '|selector| selector)
         (set-slot backtrace '|arguments| arguments)
         (set-slot backtrace '|optionals| (or optionals *primitive-nil*))
      collect backtrace)
      'simple-vector))

(define-method "ensure:" ((method *traits-method*) (final *traits-method*))
  (unwind-protect (apply-method method)
    (apply-method final)))

(define-method "initHook" ((lobby *lobby*))
  *primitive-nil*)

(define-method "interpretHook:" ((lobby *lobby*) method)
  (or (apply-method method) *primitive-nil*))

(define-method "compileMode" ((lobby *lobby*))
  (bool-of *slate-compile*))

(define-method "compileMode:" ((lobby *lobby*) (flag *traits-boolean*))
  (setf *slate-compile* (eq flag *primitive-true*))
  flag)

(define-method "compileFileNamed:" ((lobby *lobby*) (filename *traits-string*))
  (let ((out-name
	 (concatenate 'string
		      (subseq filename 0 (search ".slate" filename)) ".lisp")))
    (compile-slate-to-lisp filename out-name)
    (compile-file out-name :verbose nil :print nil)
    (delete-file out-name))
  *primitive-true*)

(define-resource-method "fileIn:" ((file *traits-file*)
				   (string *traits-string*))
  (when (not (probe-file string))
    (format t "File '~A' not found. Nothing loaded." string)
    (return *primitive-nil*))
  (let ((fasl-name
	 (compile-file-pathname (subseq string 0 (search ".slate" string)))))
    (when (and (probe-file fasl-name) (not (search ".test" string)))
      (format t "~&Loading '~A'.~%" fasl-name)
      (load fasl-name :verbose nil :print nil)
      (return *primitive-nil*)))
  ;(invoke-method '|enterModule:| nil *lobby* string)
  (with-open-file (file string)
    (with-file-name (file-name string)
      (with-line-number (line-number 0)
	(let ((token-stream (make-token-stream :stream file)))
#-ecl
	  (loop for code = (parse-statement token-stream :eof)
	    with result = *primitive-nil*
	    do (setf result (compile-slate code))
	    if (eq (peek-token token-stream) :end-statement)
	      do (get-token token-stream)
	    else
	      if (eq (peek-token token-stream) :eof)
	      do (return result))
#+ecl
	  (funcall
	   (if *slate-compile* #'compile-slate #'interpret-slate)
	   (loop for code = (parse-statement token-stream :eof)
	     collect code into result
	     if (eq (peek-token token-stream) :end-statement)
	       do (get-token token-stream)
	     else
	       if (eq (peek-token token-stream) :eof)
	       do (return `(progn ,@(or result '(*primitive-nil*)))))))))))

; Only here for bootstrapping the libraries.
(define-method "fileIn" ((file *traits-file*))
  (invoke-method '|fileIn:| nil *primitive-file* (namestring file)))

; Only here for bootstrapping the libraries.
(define-method "fileIn" ((string *traits-string*))
  (format t "~&Filing in '~A'.~%" string)
  (invoke-method '|fileIn:| nil *primitive-file* string))

; Only here for bootstrapping the libraries.
(define-method "parseFile" ((string *traits-string*))
  (when (not (probe-file string))
    (format t "File '~A' not found. Nothing loaded." string)
    (return *primitive-nil*))
  (setf *syntax* (invoke-method '|Syntax| nil *lobby*))
  (setf *current-scope* (invoke-method '|Lobby| nil *syntax*))
  (with-open-file (file string)
    (with-file-name (file-name string)
      (with-line-number (line-number 0)
    (let ((token-stream (make-token-stream :stream file)))
      (loop for code = (%parse-statement token-stream :eof)
        collect code into statements
        if (eq (peek-token token-stream) :end-statement)
          do (get-token token-stream)
        else
          if (eq (peek-token token-stream) :eof)
            do (return (coerce statements 'simple-vector))))))))

#+clisp
(progn
(define-resource-method "newOnPort:" ((socket *traits-socket-server*) (port *traits-integer*))
  (socket:socket-server port))
(define-resource-method "newForPeerOf:" ((socket *traits-socket-server*) (stream *traits-socket-client*))
  (socket:socket-server stream))
(define-resource-method "shutdown" ((socket *traits-socket-server*))
  (socket::socket-stream-shutdown socket))
(define-resource-method "close" ((socket *traits-socket-server*))
  (socket:socket-server-close socket))
(define-resource-method "wait" ((socket *traits-socket-server*))
  (socket:socket-wait socket))
(define-resource-method "wait:" ((socket *traits-socket-server*) (delay *traits-integer*))
  (socket:socket-wait socket delay))
(define-resource-method "port" ((socket *traits-socket-server*))
  (socket:socket-server-port socket))
(define-resource-method "serverStream" ((socket *traits-socket-server*))
  (socket:socket-accept socket))
(define-resource-method "status" ((socket *traits-socket-server*))
  (socket:socket-status socket))
(define-resource-method "status" ((socket *traits-socket-client*))
  (socket:socket-status socket))
(define-resource-method "host" ((socket *traits-socket-client*))
  (socket::socket-client-peer host))
(define-resource-method "port" ((socket *traits-socket-client*))
  (second (multiple-value-list (socket::socket-client-peer socket))))
(define-resource-method "peerHost" ((socket *traits-socket-client*))
  (socket::socket-client-peer socket))
(define-resource-method "peerPort" ((socket *traits-socket-client*))
  (second (multiple-value-list (socket::socket-client-peer socket))))
(define-resource-method "peerIP" ((socket *traits-socket-client*))
  (socket::socket-client-peer socket t))
(define-resource-method "newOnPort:" ((socket *traits-socket-client*) port)
  (socket:socket-connect port))
(define-resource-method "shutdown" ((socket *traits-socket-client*))
  (socket::socket-client-shutdown socket))
(define-resource-method "close" ((socket *traits-socket-client*))
  (socket::socket-client-shutdown socket)
  (close socket))
; The following methods are intended to write to Sequences of some kind, so
; that Arrays, Strings, and ByteArrays may be used equally.
(define-resource-method "read:from:startingAt:into:" ((socket *traits-socket-client*)
					     n handle start s)
  (read-sequence s socket :start start))

(define-resource-method "write:to:startingAt:from:" ((socket *traits-socket-client*)
					    n handle start s)
  (write-sequence s socket :start start))
(define-resource-method "read:from:startingAt:into:" ((socket *traits-socket-server*)
					     n handle start s)
  (read-sequence s socket :start start))

(define-resource-method "write:to:startingAt:from:" ((socket *traits-socket-server*)
					    n handle start s)
  (write-sequence s socket :start start))
)

(define-method "findOn:" ((selector *traits-symbol*) arguments)
  (let ((arglist (coerce arguments 'list)))
    (prog1
      (dispatch-method selector nil nil arglist)
      (setf (svref arguments 0) (first arglist)))))

(define-method "findOn:after:" ((selector *traits-symbol*) arguments method)
  (let ((arglist (coerce arguments 'list)))
    (prog1
      (dispatch-method selector method nil arglist)
      (setf (svref arguments 0) (first arglist)))))

(define-method "sendTo:" ((selector *traits-symbol*) arguments &optionals optionals)
  (if optionals
      (apply #'invoke-method-with-optionals selector nil (coerce (second optionals) 'list) (coerce arguments 'list))
      (apply #'invoke-method selector nil (coerce arguments 'list))))

(define-method "sendTo:through:" ((selector *traits-symbol*) arguments dispatchers &optionals optionals)
  (let ((method (dispatch-method selector nil t (coerce dispatchers 'list))))
    (when optionals
      (nconc arguments (coerce (second optionals) 'list)))
    (apply (the function (get-slot method '|code|)) method (coerce arguments 'list))))

(define-method "roles" ((object *traits-root*))
  (unless (wm-object-p object)
    (setf object (gethash object *literal-objects*))
    (unless object (return #())))
  (let ((map (wm-object-map object)))
    (coerce
     (loop for slot being the hash-values of (wm-map-slots map)
       nconc (loop for role in (wm-slot-roles slot)
           collect (vector (wm-slot-name slot) 
                           (wm-role-positions role)
                           (wm-role-method role))))
     'simple-vector)))

(define-method "removeFrom:" ((method *traits-method*)
			      (objects *traits-array*))
  (let ((name (get-slot method '|selector|)))
    (loop for each across objects
      for index = 0 then (1+ index)
      for obj = (if (wm-object-p each) each (or (gethash each *literal-objects*) *no-role*))
      for map = (wm-object-map obj)
      for slot = (gethash name (wm-map-slots map))
      when (and slot (not (eq obj *no-role*)))
      do (setf (gethash name (wm-map-slots (setf (wm-object-map obj) (clone-map map))))
               (setf slot (clone-slot slot)))
         (setf (wm-slot-roles slot)
	       (loop for role in (wm-slot-roles slot)
		 unless (and (logbitp index (wm-role-positions role))
			     (eq method (wm-role-method role)))
		 collect role))))
  method)

(define-method "identityHash" ((object *traits-root*))
  (sxhash object))

(define-method "ln" ((x *traits-float*))
  (%float (log (wm-float-value x) (exp 1))))

(define-method "exp" ((x *traits-float*))
  (%float (exp (wm-float-value x))))

(define-method "raisedTo:" ((x *traits-float*) (y *traits-float*))
  (%float (expt (wm-float-value x) (wm-float-value y))))

(defmacro integer-op (fail (op x y))
  (let ((result (%gensym)))
;        (big (%gensym)))
    `(let ((,result (,op ,x ,y)))
       (if (<= ,(- (ash 1 30)) ,result ,(1- (ash 1 30)))
           ,result
           ,fail))))
;           (let ((,big (invoke-method '|BigInteger| nil *lobby*))) 
;             (invoke-method ',selector nil
;               (invoke-method '|as:| nil ,x ,big)
;               (invoke-method '|as:| nil ,y ,big)))))))
           
(define-method "bitOr:" ((x *traits-integer*) (y *traits-integer*))
  (logior x y))

(define-method "bitXor:" ((x *traits-integer*) (y *traits-integer*))
  (logxor x y))

(define-method "bitAnd:" ((x *traits-integer*) (y *traits-integer*))
  (logand x y))

(define-method "bitShift:" ((x *traits-integer*) (y *traits-integer*))
  (if (zerop x)
      0
      (integer-op (invoke-method '|bitShiftOverflow:| nil x y) (ash x y))))
    ;(t
      ;(ldb (byte (1- (integer-length x)) (- y)) x))))

(define-method "bitNot" ((x *traits-integer*))
  (lognot x))

(define-method "+" ((x *traits-integer*) (y *traits-integer*))
  (integer-op (invoke-method '|addOverflow:| nil x y) (+ x y)))

(define-method "-" ((x *traits-integer*) (y *traits-integer*))
  (integer-op (invoke-method '|subtractOverflow:| nil x y) (- x y)))

(define-method "quo:" ((x *traits-integer*) (y *traits-integer*))
  (truncate x y))
  
(define-method "*" ((x *traits-integer*) (y *traits-integer*))
  (integer-op (invoke-method '|multiplyOverflow:| nil x y) (* x y)))

(define-method "+" ((x *traits-float*) (y *traits-float*))
  (%float (+ (wm-float-value x) (wm-float-value y))))

(define-method "-" ((x *traits-float*) (y *traits-float*))
  (%float (- (wm-float-value x) (wm-float-value y))))
  
(define-method "/" ((x *traits-float*) (y *traits-float*))
  (%float (/ (wm-float-value x) (wm-float-value y))))
  
(define-method "*" ((x *traits-float*) (y *traits-float*))
  (%float (* (wm-float-value x) (wm-float-value y))))
  
(define-method "<" ((x *traits-integer*) (y *traits-integer*))
  (bool-of (< x y)))

(define-method "<" ((x *traits-float*) (y *traits-float*))
  (bool-of (< (wm-float-value x) (wm-float-value y))))

(define-method "sin" ((x *traits-float*))
  (%float (sin (wm-float-value x))))

(define-method "cos" ((x *traits-float*))
  (%float (cos (wm-float-value x))))
  
(define-method "tan" ((x *traits-float*))
  (%float (tan (wm-float-value x))))
  
(define-method "arcsin" ((x *traits-float*))
  (%float (asin (wm-float-value x))))
  
(define-method "arccos" ((x *traits-float*))
  (%float (acos (wm-float-value x))))
  
(define-method "arctan" ((x *traits-float*))
  (%float (atan (wm-float-value x))))
  
(define-method "arctan:" ((y *traits-float*) (x *traits-float*))
  (%float (atan (wm-float-value y) (wm-float-value x))))
  
#+clx (load "x11")