(define-object *no-role*
  (traits t nil))
(define-object *primitive-nil*
  (traits t nil))
(define-object *traits-method*
  (name nil "Method")
  (traits t nil)
  (cloneable t *primitive-nil*))
(define-object *primitive-method*
  (traits t *traits-method*)
  ("lineNumber" nil 0)
  ("fileName" nil "")
  (selector nil nil)
  (accessor nil nil)
  (arguments nil '())
  ("sourceCode" nil nil)
  (code nil nil))
(add-accessors *traits-method* '|cloneable|)
(add-accessors *traits-method* '|traits|)
(add-accessors *traits-method* '|name|)
(add-accessors *primitive-method* '|traits|)
(add-accessors *primitive-method* '|sourceCode|)
(add-accessors *primitive-nil* '|traits|)

(define-object *traits-root*
  (name nil "Root" t)
  (traits t nil t))
(define-object *primitive-root*
  (traits t *traits-root* t))

(define-object *traits-oddball*
  (name nil "Oddball" t)
  (traits t nil t)
  (root t *traits-root* t))
(define-object *primitive-oddball*
  (traits t *traits-oddball* t))
(set-slot *primitive-nil* '|traits| *traits-oddball*)
(set-slot *no-role* '|traits| *traits-oddball*)

(define-object *traits-derivable*
  (name nil "Derivable" t)
  (traits t nil t)
  (root t *traits-root* t))
(define-object *primitive-derivable*
  (traits t *traits-derivable* t))

(define-object *traits-cloneable*
  (name nil "Cloneable" t)
  (traits t nil t)
  (derivable t *traits-derivable* t))
(define-object *primitive-cloneable*
  (traits t *traits-cloneable* t))
(set-slot *traits-method* '|cloneable| *traits-cloneable*)

(define-object *traits-traits*
  (name nil "Traits" t)
  (root t *traits-root* t))
(define-object *primitive-traits*
  (name nil "_" t)
  (traits t *traits-traits* t))
(set-slot *traits-method* '|traits| *traits-traits*)
(set-slot *traits-root* '|traits| *traits-traits*)
(set-slot *traits-oddball* '|traits| *traits-traits*)
(set-slot *traits-derivable* '|traits| *traits-traits*)
(set-slot *traits-cloneable* '|traits| *traits-traits*)

(defmacro define-traits (name &rest slots)
  `(progn
     (define-object ,name (traits t *traits-traits* t) ,@slots)
     (define-method traits ((obj ,name))
       (if (eq obj ,name)
           *traits-traits*
           ,name))))

(defmacro define-bool-method (name arguments &body body)
  `(define-method ,name ,arguments
     (if (progn ,@body) *primitive-true* *primitive-false*)))

(defun add-to-namespace (object prototype)
  (add-slot object (invoke-method '|name| nil prototype) nil prototype t))

(define-traits *traits-lisp*
  (name nil "Lisp" t)
  (oddball t *traits-oddball* t))

(define-traits *traits-boolean*
  (name nil "Boolean" t)
  (oddball t *traits-oddball* t))
(define-object *primitive-true*
  (traits t *traits-boolean* t))
(define-object *primitive-false*
  (traits t *traits-boolean* t))

(define-traits *traits-number*
  (name nil "Number" t)
  (derivable t *traits-derivable* t))
(define-object *primitive-number*
  (traits t *traits-number* t))

(define-traits *traits-integer*
  (name nil "Integer" t)
  (number t *traits-number* t))

(define-traits *traits-float*
  (name nil "Float" t)
  (number t *traits-number* t))

(define-traits *traits-character*
  (name nil "Character" t)
  (oddball t *traits-oddball* t))

(define-traits *traits-symbol*
  (name nil "Symbol" t)
  (oddball t *traits-oddball* t))

(define-traits *traits-collection*
  (name nil "Collection" t)
  (cloneable t *traits-cloneable* t))
(define-object *primitive-collection*
  (traits t *traits-collection* t))

(define-traits *traits-array*
  (name nil "Array" t)
  (collection t *traits-collection* t))

(define-traits *traits-byte-array*
  (name nil "ByteArray" t)
  (collection t *traits-collection* t))

(define-traits *traits-string*
  (name nil "String" t)
  (collection t *traits-collection*))

(define-traits *traits-filestream*
  (name nil "FileStream" t)
  (oddball t *traits-oddball* t))
(define-object *primitive-filestream*
  (traits t *traits-filestream*))

#+clisp
(progn					; Only use CLISP's sockets.
  (define-traits *traits-socket*
    (name nil "Socket" t)
    (oddball t *traits-oddball* t))
  (define-object *primitive-socket*
    (traits t *traits-socket*)))

(define-traits *traits-namespace*
  (name nil "Namespace" t)
  (oddball t *traits-oddball*))
(define-object *primitive-namespace*
  (traits t *traits-namespace*))

(define-object *prototypes*
  (traits t *traits-namespace*)
  ("Traits" nil *primitive-traits* t)
  ("Root" nil *primitive-root* t)
  ("Cloneable" nil *primitive-cloneable* t)
  ("Oddball" nil *primitive-oddball* t)
  ("Derivable" nil *primitive-derivable* t)
  ("Namespace" nil *primitive-namespace* t)
  ("Nil" nil *primitive-nil* t)
  ("Boolean" nil *primitive-true* t)
  ("True" nil *primitive-true* t)
  ("False" nil *primitive-false* t)
  ("Number" nil *primitive-number* t)
  ("Integer" nil 0 t)
  ("Float" nil 0.0 t)
  ("ASCIICharacter" nil #\Null t)
  ("Symbol" nil '|symbol| t)
  ("Collection" nil *primitive-collection* t)
  ("Array" nil #() t)
  ("ByteArray" nil (make-array 0 :element-type '(unsigned-byte 8)) t)
  ("String" nil "" t)
  ("FileStream" nil *primitive-filestream* t)
  #+clisp ("Socket" nil *primitive-socket* t)
  ("Lisp" nil (lambda () *primitive-nil*) t)
  ("Method" nil *primitive-method* t))

(define-object *console-input*
  (traits t *traits-oddball* t))

(define-object *console-output*
  (traits t *traits-oddball* t))

(define-object *platform*
  (traits t *traits-oddball* t))

(defconstant *slate-modules*
  (make-array 12 :initial-element nil :fill-pointer 0 :adjustable t))

(defconstant *slate-features*
  (make-array 12 :initial-element nil :fill-pointer 0 :adjustable t))

(define-object *globals*
  (traits t *traits-namespace*)
  ("NoRole" nil *no-role* t)
  ("ConsoleInput" nil *console-input* t)
  ("ConsoleOutput" nil *console-output* t)
  ("modules" nil *slate-modules* t)
  ("features" nil *slate-features* t)
  ("currentModule" nil *primitive-nil* t)
  ("platform" nil *platform* t))

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

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

(unless (fboundp 'exit)
  (defun exit () (quit)))

(define-method "quit" ((lobby *lobby*))
  (exit))

(define-method "exit" ((lobby *lobby*))
  (exit))

(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*)

(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 "enterModule:" ((lobby *lobby*) name)
  (vector-push-extend name *slate-modules*)
  (setf (get-slot *globals* '|currentModule|) name))

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

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

(define-method "messageNotUnderstood" ((lobby *lobby*))
  (format t "~%Message was not understood.")
  ;(format t "~%Selector: ~A arguments: ~{~A~^. ~}" selector arguments)
  (finish-output)
  (throw 'top-level nil))

(define-method "slotNames" ((object *traits-root*))
  (if (wm-object-p object)
      (coerce (wm-map-slot-names (wm-object-map object)) 'vector)
      #(|traits|)))

(define-method "delegateNames" ((object *traits-root*))
  (if (wm-object-p object)
      (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)
        'array)
      #(|traits|)))

(define-method "bits" ((float *traits-float*))
  (multiple-value-bind (significand exponent sign) (integer-decode-float float)
    (loop until (or (logbitp 0 significand) (= exponent 127))
      do (setf significand (ash significand -1))
         (incf exponent))
    (logior (if (< sign 0) (ash 1 31) 0)
            (ash significand 23)
            (+ exponent 127))))

(define-method "as:" ((number *traits-number*) (string *traits-string*))
  (format nil "~A" number))

(define-method "as:" ((string *traits-string*) (number *traits-number*))
  (values (read-from-string string)))

(define-method "as:" ((character *traits-character*) (integer *traits-integer*))
  (char-code character))

(define-method "as:" ((integer *traits-integer*) (character *traits-character*))
  (code-char integer))

(define-method "as:" ((selector *traits-symbol*) (string *traits-string*))
  (symbol-name selector))

(define-method "as:" ((string *traits-string*) (selector *traits-symbol*))
  (intern string))

(define-method "next" ((stream *console-input*))
  (read-char))

(define-method "atEnd" ((stream *console-input*))
  *primitive-false*)

(define-method "flush" ((stream *console-input*))
  (finish-output stream))

(define-method "nextPut:" ((stream *console-output*) (character *traits-character*))
  (write-char character))

(define-method "flush" ((stream *console-output*))
  (finish-output stream))

(define-method clone ((oddball *primitive-oddball*))
  (if (eq oddball *primitive-oddball*)
      (clone-object *primitive-oddball*)
      oddball))

(define-method clone ((namespace *primitive-namespace*))
  (if (eq namespace *primitive-namespace*)
      (clone-object *primitive-namespace*)
      namespace))

(define-method derive ((derivable *traits-derivable*))
  (let ((object (invoke-method '|clone| nil derivable))
        (traits (clone-object *primitive-traits*)))
    (add-slot traits '|parent| t (get-slot object '|traits|) t)
    (set-slot object '|traits| traits)
    object))

(define-method "deriveWith:" ((derivable *traits-derivable*) array)
  (let ((traits (clone-object *primitive-traits*)))
    (loop for parent in (nreverse (cons derivable (coerce array 'list)))
          for index from (length array) by -1
          with object
      do
        (if object
            (invoke-method '|addSlotsFrom:| nil object parent)
            (setf object (invoke-method '|clone| nil parent)))
        (add-slot traits (intern (format nil "parent~A" index)) t parent t)
      finally 
        (set-slot object '|traits| traits)
        (return object))))
    
(define-bool-method "==" ((x *traits-root*) (y *traits-root*))
  (eq x y))

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

(define-method "addSlotsFrom:" ((x *traits-root*) (y *traits-root*))
  (loop for slot-name in (wm-map-slot-names (wm-object-map y))
        for slot = (gethash slot-name (wm-map-slots (wm-object-map y)))
        for contents = (svref (wm-object-slots y) (wm-slot-index slot))
    do
      (add-slot x slot-name
        (wm-slot-delegates slot)
        contents
        (wm-slot-accessors slot)))
  x) 

(define-method "addSlot:" ((object *traits-root*) name)
  (add-slot object (if (symbolp name) name (intern name)) nil *primitive-nil* t)
  object)

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

(define-method "addDelegate:" ((object *traits-root*) name)
  (add-slot object (if (symbolp name) name (intern name)) t *primitive-nil* t)
  object)

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

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

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

(define-method clone ((object *traits-root*))
  (if (wm-object-p object)
      (clone-object object)
      (clone-object
        (or (gethash object *literal-objects*)
            (let ((representation (make-wm-object)))
              (add-slot representation '|traits| t
                (traits-for-prim object) t)
              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| t *traits-byte-array*)
            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| t *traits-array*)
            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| t *traits-string*)
            representation)))
    new-array))

(define-method "newSize:" ((array *traits-byte-array*) (size *traits-integer*))
  (let ((representation (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 #\Null)))
    (when representation
      (setf (gethash new-array *literal-objects*) (clone-object representation)))
    new-array))

(define-method "atSlot:" ((object *traits-root*) (index *traits-integer*))
  (unless (wm-object-p object)
    (setf object (gethash object *literal-objects*)))
  (svref (wm-object-slots object) index))

(define-method "atSlot:put:" ((object *traits-root*) (index *traits-integer*) value)
  (unless (wm-object-p object)
    (setf object (gethash object *literal-objects*)))
  (setf (svref (wm-object-slots object) index) value))

(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 "at:" ((array *traits-byte-array*) (index *traits-integer*))
  (aref array index))

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

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

(define-method size ((array *traits-array*))
  (length array))
 
(define-method "at:" ((string *traits-string*) (index *traits-integer*))
  (char string index))

(define-method "at:put:" ((string *traits-string*) (index *traits-integer*) value)
  (setf (char string index) value))

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

;(define-method ";" ((x *traits-array*) (y *traits-array*))
;  (concatenate 'array x y))
;  
;(define-method ";" ((x *traits-string*) (y *traits-string*))
;  (concatenate 'string x y))

; This anticipates the loading of the Streams library.
(define-method "printOn:" ((object *traits-root*) (stream *traits-root*))
  (invoke-method '|nextPutAll:| nil stream
		 (invoke-method '|print| nil object)))

(define-method "printOn:" ((object *traits-root*) (stream *console-output*))
  (format t "~A" (invoke-method '|print| nil object)))

(define-method print ((object *traits-traits*))
  (unless (and (wm-object-p object)
               (or (eq object *traits-traits*)
                   (eq (get-slot object '|traits|) *traits-traits*)))
    (return-from print (invoke-method '|print| currentMethod object)))
  (format nil "@~A" (or (get-slot object '|name|) "_")))

(define-method print ((object *traits-symbol*))
  (when (wm-object-p object)
    (return-from print
      (invoke-method '|print| currentMethod object)))
  (format nil "#~A" object))

(define-method print ((object *traits-character*))
  (when (wm-object-p object)
    (return-from print
      (invoke-method '|print| currentMethod object)))
  (format nil "$~A" 
    (case object
      (#\Newline "\\n")
      (#\Tab "\\t")
      (#\Return "\\r")
      (#\Backspace "\\b")
      (#\Space "\\s")
      #-ecl
      (#\Escape "\\e")
      (#\Null "\\0")
      (t 
        (case (char-code object)
          (7 "\\a")
          (11 "\\v")
          (12 "\\f")
          (t object))))))

(define-method print ((object *traits-root*))
  (let ((string "<"))
    (when (get-slot object '|traits|)
      (setf string
	    (format nil "~A@~A:" string
		    (or (get-slot (get-slot object '|traits|) '|name|) "_"))))
    (setf string
	  (if (< (length (wm-map-slot-names (wm-object-map object))) 20)
	      (format nil "~A ~{ ~A~}>"
		      string (wm-map-slot-names (wm-object-map object)))
	    (format nil "~A ...>" (get-slot object '|name|))))
    string))

(define-method print ((object *primitive-nil*))
  "Nil")

(define-method print ((object *primitive-true*))
  "True")

(define-method print ((object *primitive-false*))
  "False")

(define-method print ((object *no-role*))
  "NoRole")

(define-method print ((filestream *traits-filestream*))
    (format nil "<FileStream ~A>" (namestring filestream)))

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

(define-method print ((array *traits-array*))
  (when (wm-object-p array)
    (return-from print
      (invoke-method '|print| currentMethod array))) 
  (let ((string "{"))
    (setf string
      (apply #'concatenate 'string string
        (loop for index below (1- (length array))
          collect (invoke-method '|print| nil (aref array index))
          collect (format nil ". "))))
    (when (> (length array) 0)
      (setf string
        (concatenate 'string string
          (invoke-method '|print| nil (aref array (1- (length array)))))))
    (setf string (concatenate 'string string "}"))
    string))

(define-method print ((array *traits-byte-array*))
  (when (wm-object-p array)
    (return-from print
      (invoke-method '|print| currentMethod array)))
  (let ((string "{"))
    (setf string
      (apply #'concatenate 'string string
        (loop for index below (1- (length array))
          collect (format nil "~A. " (aref array index)))))
    (when (> (length array) 0)
      (setf string
        (concatenate 'string string (format nil "~A" (aref array (1- (length array)))))))
    (setf string (concatenate 'string string "}"))
    string))

(define-method print ((string *traits-string*))
  (when (wm-object-p string)
    (return-from print
      (invoke-method '|print| currentMethod string))) 
  (format nil "'~A'" string))

(define-method print ((method *traits-method*))
  (when (eq method *traits-method*)
    (return-from print
      (invoke-method '|print| currentMethod method))) 
  (format nil "[~A]" (if (eq (get-slot method '|selector|) *primitive-nil*) "" (get-slot method '|selector|))))
 
(define-method loop ((method *traits-method*))
  (loop (apply-method method)))
  
(define-method value ((method *traits-method*))
  (apply-method method))
  
(define-method "value:" ((method *traits-method*) x)
  (apply-method method x))

(define-method "value:value:" ((method *traits-method*) x y)
  (apply-method method x y))

(define-method "value:value:value:" ((method *traits-method*) x y z)
  (apply-method method x y z))

(define-method "values:" ((method *traits-method*) arguments)
  (apply (get-slot method '|code|) method (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-method "newNamed:" ((filestream *traits-filestream*) (filename *traits-string*))
  (open (parse-namestring filename) :direction :io :if-exists :overwrite))

(define-method "newForInputNamed:" ((filestream *traits-filestream*) (filename *traits-string*))
  (or (open (parse-namestring filename) :direction :input :if-does-not-exist nil) *primitive-nil*))

(define-method "newForOutputNamed:" ((filestream *traits-filestream*) (filename *traits-string*))
  (open (parse-namestring filename) :direction :output :if-exists :append))

(define-method "newForNewNamed:" ((filestream *traits-filestream*) (filename *traits-string*))
  (open (parse-namestring filename)
	:direction :append :if-exists :overwrite :if-does-not-exist :create))

(define-method "as:" ((filename *traits-string*) (filestream *traits-filestream*))
  (invoke-method '|newNamed:| nil filestream filename))

(define-method "as:" ((filestream *traits-filestream*) (filename *traits-string*))
  (invoke-method '|name| nil filestream))

(define-bool-method "close" ((filestream *traits-filestream*))
  (close filestream))

(define-method "fullName" ((filestream *traits-filestream*))
  (namestring (truename filestream)))

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

(define-bool-method "delete" ((filestream *traits-filestream*))
  (delete-file filestream))

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

(define-method "next" ((filestream *traits-filestream*))
  (or (read-char-no-hang filestream ) *primitive-nil*))

#+ecl (unless (fboundp 'read-sequence)
(defun read-sequence (seq stream &key (start 0) end)
  "Provisional ANSI compliance within the needs of the following primitives."
  (let ((eff-end (min (or end most-positive-fixnum) (1- (length seq))))
	(converter
	 (cond ((and (eq (type-of seq) 'string)
		     (not (eq (type-of stream) 'string-stream)))
		(lambda (obj) (code-char obj)))
	       ((and (not (eq (type-of seq) 'string))
		     (eq (type-of stream) 'string-stream))
		(lambda (obj) (char-code obj)))
	       (t (lambda (obj) obj)))))
    (if (eq (type-of stream) 'filestream)
	(si:read-bytes stream seq start eff-end)
      (loop for index from start to eff-end
	do (setf (elt seq index) (funcall converter (read-byte stream))))))
  seq)
(defun write-sequence (seq stream &key (start 0) end)
  "Provisional ANSI compliance within the needs of the following primitives."
  (let ((eff-end (min (or end most-positive-fixnum) (1- (length seq))))
	(converter
	 (cond ((and (eq (type-of seq) 'string)
		     (not (eq (type-of stream) 'string-stream)))
		(lambda (obj) (char-code obj)))
	       ((and (not (eq (type-of seq) 'string))
		     (eq (type-of stream) 'string-stream))
		(lambda (obj) (code-char obj)))
	       (t (lambda (obj) obj)))))
    (if (eq (type-of stream) 'filestream)
	(si:write-bytes stream seq start eff-end)
      (loop for index from start to eff-end
	do (write-byte (funcall converter (elt seq index)) stream)
	finally (finish-output stream))))
  seq))


; The following methods are intended to write to Sequences of some kind, so
; that Arrays, Strings, and ByteArrays may be used equally.
(define-method "nextPutInto:" ((filestream *traits-filestream*) s)
  (read-sequence s filestream))

(define-method "next:putInto:" ((filestream *traits-filestream*) n s)
  (read-sequence s filestream :start 0 :end (1- n)))

(define-method "next:putInto:startingAt:" ((filestream *traits-filestream*)
					n s start)
  (read-sequence s filestream :start start :end (1- (+ start n))))

(define-method "nextPut:" ((filestream *traits-filestream*) (c *traits-character*))
  (write-char c filestream))

(define-method "nextPut:" ((filestream *traits-filestream*) s)
  (write-sequence s filestream))

(define-method "nextPutAll:" ((filestream *traits-filestream*) s)
  (write-sequence s filestream))

(define-method "nextPut:from:" ((filestream *traits-filestream*) n s)
  (write-sequence s filestream :end (1- n)))

(define-method "nextPut:from:startingAt:" ((filestream *traits-filestream*)
					   n s start)
  (write-sequence s filestream :start start :end (1- (+ start n))))

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

(define-method "position:" ((filestream *traits-filestream*) pos)
  (setf (file-position filestream) pos))

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

(define-method "filename" ((filestream *traits-filestream*))
  (namestring filestream))

(define-bool-method "atEnd" ((filestream *traits-filestream*))
  (eq (file-position filestream) (file-length filestream)))

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

(define-bool-method "compileMode:" ((lobby *lobby*) (flag *traits-boolean*))
  (setf *slate-compile* 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-method "fileIn:" ((filestream *traits-filestream*)
			  (string *traits-string*))
  (when (not (probe-file string))
    (format t "File '~A' not found. Nothing loaded." string)
    (throw 'top-level nil))
  (let ((fasl-name
	 (compile-file-pathname (subseq string 0 (search ".slate" string)))))
    (when (probe-file fasl-name)
      (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*)))))))))))

(define-method "fileIn" ((filestream *traits-filestream*))
  (invoke-method '|fileIn:| nil *primitive-filestream* (namestring filestream)))

(define-method "fileIn" ((string *traits-string*))
  (invoke-method '|fileIn:| nil *primitive-filestream* string))

#+clisp
(progn
  (define-method "newOnPort:" ((socket *traits-socket*) (port *traits-integer*))
    (socket:socket-server port))
  (define-method "newFor:" ((socket *traits-socket*) (old *traits-socket*))
    (socket:socket-server old))
  (define-method "close" ((socket *traits-socket*))
    (socket:socket-server-close socket))
  (define-method "wait" ((socket *traits-socket*))
    (socket:socket-wait socket))
  (define-method "wait:" ((socket *traits-socket*) (delay *traits-number*))
    (socket:socket-wait socket delay))
  (define-method "port" ((socket *traits-socket*))
    (socket:socket-server-port socket))
  )

#+ecl
(progn
(define-method "newOnHost:port:" ((hostname *traits-string*)
				  (port *traits-integer*))
  (open-client-stream hostname port))
(define-method "newBroadCastOnHost:port:" ((hostname *traits-string*)
					   (port *traits-integer*))
  (open-server-stream hostname port))
)

(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)
  (apply #'invoke-method selector nil (coerce arguments 'list)))

(define-method "sendTo:through:" ((selector *traits-symbol*) arguments dispatchers)
  (apply #'invoke-method selector (coerce dispatchers 'list) (coerce arguments 'list)))

(define-method "sendWith:" ((selector *traits-symbol*) x)
  (invoke-method selector nil x))

(define-method "sendWith:with:" ((selector *traits-symbol*) x y)
  (invoke-method selector nil x y))

(define-method "sendWith:with:with:" ((selector *traits-symbol*) x y z)
  (invoke-method selector nil x y z))

(define-method "methodsNamed:atPosition:" ((object *traits-root*) name index)
  (let ((methods (make-array 0 :fill-pointer 0 :adjustable t)))
    (multiple-value-bind (slot exists)
	(gethash name (wm-map-slots (wm-object-map
				     (if (wm-object-p object) object
				       (or (gethash object *literal-objects*)
					   (return #()))))))
      (when exists
	(dolist (role (wm-slot-roles slot))
	  (when (logbitp index (wm-role-positions role))
	    (vector-push-extend (wm-role-method role) methods)))))
    methods))

(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 map = (wm-object-map (if (wm-object-p each) each
				  (or (gethash each *literal-objects*)
				      *no-role*)))
      for slot = (gethash name (wm-map-slots map))
      when slot
      do (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 "replaceWith:on:" ((method *traits-method*)
				  (new-method *traits-method*)
				  (objects *traits-array*))
  (let ((name (get-slot method '|selector|)))
    (loop for each across objects
      for index = 0 then (1+ index)
      for map = (wm-object-map (if (wm-object-p each) each
				  (or (gethash each *literal-objects*)
				      *no-role*)))
      do (loop for role in (wm-slot-roles (gethash name (wm-map-slots map)))
	   when (and (logbitp index (wm-role-positions role))
		     (eq method (wm-role-method role)))
	   do (setf (wm-role-method role) new-method))))
  method)

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

(define-method "raisedTo:" ((x *traits-number*) (y *traits-number*))
  (expt x y))

(define-method "as:" ((i *traits-integer*) (f *traits-float*))
  (coerce i 'float))

(define-method "as:" ((f *traits-float*) (i *traits-integer*))
  (values (floor f)))

(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 (> y 0)
      (ash x y)
      (ldb (byte (1- (integer-length x)) (- y)) x)))

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

(define-method "<<" ((x *traits-integer*) (y *traits-integer*))
  (ash x y))

(define-method ">>" ((x *traits-integer*) (y *traits-integer*))
  (ash x (- y)))

(define-method "+" ((x *traits-integer*) (y *traits-integer*))
  (+ x y))

(define-method "-" ((x *traits-integer*) (y *traits-integer*))
  (- x y))

(define-method "quo:" ((x *traits-integer*) (y *traits-integer*))
  (values (floor x y)))

(define-method "*" ((x *traits-integer*) (y *traits-integer*))
  (* x y))

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

(define-method "-" ((x *traits-float*) (y *traits-float*))
  (- x y))

(define-method "/" ((x *traits-float*) (y *traits-float*))
  (/ x y))

(define-method "*" ((x *traits-float*) (y *traits-float*))
  (* x y))

(define-bool-method "=" ((x *traits-integer*) (y *traits-integer*))
  (= x y))

(define-bool-method ">" ((x *traits-integer*) (y *traits-integer*))
  (> x y))

(define-bool-method "<" ((x *traits-integer*) (y *traits-integer*))
  (< x y))

(define-bool-method ">=" ((x *traits-integer*) (y *traits-integer*))
  (>= x y))

(define-bool-method "<=" ((x *traits-integer*) (y *traits-integer*))
  (<= x y))

(define-bool-method "=" ((x *traits-float*) (y *traits-float*))
  (= x y))

(define-bool-method ">" ((x *traits-float*) (y *traits-float*))
  (> x y))

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

(define-bool-method ">=" ((x *traits-float*) (y *traits-float*))
  (>= x y))

(define-bool-method "<=" ((x *traits-float*) (y *traits-float*))
  (<= x y))
 
#+clx (load "x11")