(declaim (optimize (speed 3) (safety 1))) (defvar *slate-debug* nil "Defines whether errors should involve the interpreter or use Slate-level `handlers'.") (defvar *slate-compile* nil "Defines whether `fileIn' invokes the compiler or the interpreter on the contents.") (defvar *gensym-counter* 0) (defun %gensym () (intern (format nil "~~~A" (incf *gensym-counter*)))) (defvar *literal-objects* (make-hash-table)) (defmacro traits-for-prim (object) (let ((sym (%gensym))) `(let ((,sym ,object)) (typecase ,sym (integer *traits-integer*) (wm-float *traits-float*) (character *traits-character*) (symbol *traits-symbol*) (array (typecase ,sym (string *traits-string*) ((array (unsigned-byte 8)) *traits-byte-array*) (t *traits-array*))) (stream *traits-file*) (function *traits-lisp*) #+clx ,@`((xlib:display *traits-display*) (xlib:screen *traits-screen*) (xlib:window *traits-window*) (xlib:pixmap *traits-pixmap*) (xlib:drawable *traits-drawable*) (xlib:cursor *traits-cursor*) (xlib:color *traits-color*) (xlib:gcontext *traits-context*)) (t (cond #+clisp ((eq (type-of ,sym) 'socket:socket-server) *traits-socket-server*) #+clisp ((eq (type-of ,sym) 'socket::socket-client) *traits-socket-client*) (t (error "Unhandled object type: ~A" ,sym)))))))) (defstruct wm-float (bytes 0 :type integer) (value 0.0 :type float)) (defstruct wm-slot (name nil :type symbol) (index -1 :type fixnum) #-cormanlisp (delegates nil :type boolean) #+cormanlisp (delegates nil) #-cormanlisp (accessors nil :type (or boolean (eql :immutable))) #+cormanlisp (accessors nil) (roles '() :type list)) (defstruct wm-map (slot-names '() :type list) (slots (make-hash-table) :type hash-table)) (defstruct (wm-object #-ecl (:print-function (lambda (object stream level) (format stream "~&<@~A: ~{~A~^, ~}>" (wm-object-name object) (wm-map-slot-names (wm-object-map object)))))) (name "" :type string) (map (make-wm-map) :type wm-map) (slots #() :type simple-vector)) #-ecl (defmethod make-load-form ((s wm-object) &optional env) (unless (eq (get-slot s '|traits|) *traits-method*) (error "make-load-form only supports Method objects.")) `(make-slate-method ,(get-slot s '|fileName|) ,(get-slot s '|lineNumber|) ,(if (eq (get-slot s '|selector|) *primitive-nil*) '*primitive-nil* `(quote ,(get-slot s '|selector|))) ',(get-slot s '|arguments|) ,(get-slot s '|sourceCode|) *primitive-nil*)) (defstruct wm-role (positions 0 :type fixnum) (arguments 0 :type fixnum) (method nil :type wm-object)) (defun clone-slot (slot) (make-wm-slot :name (wm-slot-name slot) :index (wm-slot-index slot) :delegates (wm-slot-delegates slot) :accessors (wm-slot-accessors slot) :roles (loop for role in (wm-slot-roles slot) collect (make-wm-role :positions (wm-role-positions role) :arguments (wm-role-arguments role) :method (wm-role-method role))))) (defun clone-map (map) (let ((new-map (make-wm-map))) (setf (wm-map-slot-names new-map) (copy-seq (wm-map-slot-names map))) (maphash #'(lambda (slot-name slot) (setf (gethash slot-name (wm-map-slots new-map)) slot)) (wm-map-slots map)) new-map)) (defmacro with-object ((name &rest slots) &body body) `(let ((,name (make-wm-object))) (prog () (setf (wm-object-name ,name) ,(string name)) ,@(loop for (slot-name slot-value slot-delegates slot-accessors) in slots collect `(add-slot ,name ',(if (stringp slot-name) (%intern slot-name) (%intern (string-downcase (string slot-name)))) ,slot-value ,slot-delegates ,slot-accessors))) ,@body)) (defmacro define-object (name &rest slots) `(progn ;(format t "DEFINING: ~A~%" name) (defvar ,name) (setf ,name (with-object (,name ,@slots) ,name)))) (defmacro clone-object (object) (let ((object-symbol (%gensym))) `(let ((,object-symbol ,object)) (make-wm-object :name (wm-object-name ,object-symbol) :map (wm-object-map ,object-symbol) :slots (copy-seq (wm-object-slots ,object-symbol)))))) (defmacro activate-method (code file line selector arguments source) (let* ((act-symbol (%gensym)) #-ecl (method (make-slate-method file line (or selector *primitive-nil*) arguments source *primitive-nil*)) #+ecl (method `(%load-form ,(%gensym) (make-slate-method ,file ,line ,(if selector `(quote ,selector) '*primitive-nil*) ',arguments ,source *primitive-nil*))) (index (wm-slot-index (gethash '|code| (wm-map-slots (wm-object-map *primitive-method*)))))) `(let ((,act-symbol (clone-object ,method))) (setf (svref (wm-object-slots ,act-symbol) ,index) ,code) ,act-symbol))) #+jit (defmacro jit-activate-method (code file line selector arguments source) (let* ((act-symbol (%gensym)) #-ecl (method (make-slate-method file line (or selector *primitive-nil*) arguments source *primitive-nil*)) #+ecl (method `(%load-form ,(%gensym) (make-slate-method ,file ,line ,(if selector `(quote ,selector) '*primitive-nil*) ',arguments ,source *primitive-nil*))) (index (wm-slot-index (gethash '|code| (wm-map-slots (wm-object-map *primitive-method*)))))) `(let ((,act-symbol (clone-object ,method))) (setf (svref (wm-object-slots ,act-symbol) ,index) (lambda (&rest arguments) ,(cond ((stringp file) `(format t "JIT: ~A@~A:~A~%" ,(if selector `',selector "[]") ,file ,line)) ((null selector) `(format t "JIT: []~%")) (t `(format t "JIT: ~A~%" ',selector))) (apply (setf (svref (wm-object-slots ,act-symbol) ,index) (compile nil ',code)) arguments))) ,act-symbol))) (defun make-slate-method (file line selector arguments source code &optional (accessor *primitive-nil*)) (let ((method (clone-object *primitive-method*))) (set-slot method '|fileName| file) (set-slot method '|lineNumber| line) (set-slot method '|selector| (or selector *primitive-nil*)) (set-slot method '|accessor| accessor) (set-slot method '|arguments| arguments) (set-slot method '|sourceCode| source) (set-slot method '|code| code) method)) (defun add-accessors (object name &optional immutable) (%intern (symbol-name name)) (let ((mutator (%intern (concatenate 'string (string name) ":")))) (%add-roles name nil (make-slate-method "" 0 name '(object) *primitive-nil* (lambda (currentBlock object) (declare (ignore currentBlock)) (get-slot object name)) name) object) (unless immutable (%add-roles mutator nil (make-slate-method "" 0 mutator '(object value) *primitive-nil* (lambda (currentBlock object value) (declare (ignore currentBlock)) (set-slot object name value)) name) object)) object)) (defvar *slots* '()) (defun add-slot (object name value &optional delegates accessors) (pushnew name *slots*) (unless (wm-object-p object) (setf object (or (gethash object *literal-objects*) (let ((representation (make-wm-object))) (add-slot representation '|traits| (traits-for-prim object) t t) (setf (gethash object *literal-objects*) representation))))) (let* ((map (clone-map (wm-object-map object))) (slot (or (multiple-value-bind (slot exists) (gethash name (wm-map-slots map)) (when exists (setf (gethash name (wm-map-slots map)) (clone-slot slot)))) (progn (setf (wm-map-slot-names map) (nconc (wm-map-slot-names map) (list name))) (setf (gethash name (wm-map-slots map)) (make-wm-slot :name name)))))) (setf (wm-object-map object) map) (setf (wm-slot-delegates slot) (or (wm-slot-delegates slot) delegates)) (unless (or (wm-slot-accessors slot) (not accessors) (eq (wm-slot-accessors slot) accessors)) (add-accessors object name (eq accessors :immutable))) (setf (wm-slot-accessors slot) (or (wm-slot-accessors slot) accessors)) (if (= (wm-slot-index slot) -1) (let ((index 0)) (maphash (lambda (slot-name slot) (setf index (max index (1+ (wm-slot-index slot))))) (wm-map-slots map)) (setf (wm-slot-index slot) index) (setf (wm-object-slots object) (concatenate 'simple-vector (wm-object-slots object) (list value)))) (set-slot object name value)) object)) (defun remove-slot (object slot-name) (unless (wm-object-p object) (setf object (gethash object *literal-objects*)) (unless object (return-from remove-slot (values nil nil)))) (let* ((slots (wm-object-slots object)) (map (clone-map (wm-object-map object))) (map-slots (wm-map-slots map)) (slot (gethash slot-name map-slots)) (index (wm-slot-index slot)) (slot-value (svref slots (wm-slot-index slot))) (mutator-name (%intern (concatenate 'string (string slot-name) ":"))) (mutator-slot (gethash mutator-name map-slots))) (setf (wm-object-map object) map) (setf (wm-object-slots object) (concatenate 'simple-vector (subseq (wm-object-slots object) 0 index) (subseq (wm-object-slots object) (1+ index)))) (maphash (lambda (slot-name slot) (when (> (wm-slot-index slot) index) (decf (wm-slot-index slot)))) map-slots) (setf (wm-map-slot-names map) (delete (wm-slot-name slot) (wm-map-slot-names map))) (remhash slot-name map-slots) (when (and mutator-slot (eq (wm-slot-accessors slot) t)) (let* ((new-slot (clone-slot mutator-slot)) (mutator (loop for role in (wm-slot-roles new-slot) when (eq (get-slot (wm-role-method role) '|accessor|) slot-name) return role))) (setf (gethash mutator-name map-slots) new-slot) (setf (wm-slot-roles new-slot) (delete mutator (wm-slot-roles new-slot))) (unless (wm-slot-roles new-slot) (remhash mutator-name map-slots)))) (values slot-value t))) (defun add-role (object name do-clone position arguments method) (unless (wm-object-p object) (setf object (or (gethash object *literal-objects*) (let ((representation (clone-object (if (symbolp object) *primitive-symbol* *primitive-literal*)))) (if (symbolp object) (set-slot representation '|name| (symbol-name object)) (set-slot representation '|traits| (traits-for-prim object))) (setf (gethash object *literal-objects*) representation))))) (let* ((map (clone-map (wm-object-map object))) (slot (or (multiple-value-bind (slot exists) (gethash name (wm-map-slots map)) (when exists (if do-clone (setf (gethash name (wm-map-slots map)) (clone-slot slot)) slot))) (setf (gethash name (wm-map-slots map)) (make-wm-slot :name name))))) (setf (wm-object-map object) map) (dolist (role (wm-slot-roles slot)) (when (eq (wm-role-method role) method) (setf (wm-role-positions role) (logior (wm-role-positions role) position)) (return-from add-role object))) (push (make-wm-role :positions position :arguments arguments :method method) (wm-slot-roles slot))) object) (defun find-methods (object name &optional position) (unless (wm-object-p object) (setf object (gethash object *literal-objects*)) (unless object (return-from find-methods *primitive-nil*))) (let ((map (wm-object-map object))) (coerce (loop for slot being the hash-values of (wm-map-slots map) when (eq (wm-slot-name slot) name) nconc (loop for role in (wm-slot-roles slot) unless (and position (not (logbitp position (wm-role-positions role)))) collect (wm-role-method role))) 'vector))) (defun replace-method (name objects method) (let ((arguments 0) (methods '())) (loop for object in objects for index from 0 unless (eq object *no-role*) do (setf arguments (logior arguments (ash 1 index)))) (loop for object in objects for index from 0 unless (wm-object-p object) do (setf object (gethash object *literal-objects*)) unless object do (return-from replace-method nil) unless (eq object *no-role*) do (let* ((map (wm-object-map object)) (slot (gethash name (wm-map-slots map)))) (unless (and slot (wm-slot-roles slot)) (return-from replace-method nil)) (let ((new-methods (loop for role in (wm-slot-roles slot) when (and (logbitp (wm-role-positions role) index) (= (wm-role-arguments role) arguments)) collect (wm-role-method role)))) (if methods (setf methods (intersection methods new-methods)) (setf methods new-methods))) (when (null methods) (return-from replace-method nil)))) (loop for object in objects unless (wm-object-p object) do (setf object (gethash object *literal-objects*)) unless (eq object *no-role*) do (let* ((map (wm-object-map object)) (slot (clone-slot (gethash name (wm-map-slots map))))) (setf (gethash name (wm-map-slots map)) slot) (loop for role in (wm-slot-roles slot) when (eq (wm-role-method role) (first methods)) do (setf (wm-role-method role) method)))) (first methods))) (defun get-slot (object slot-name) (unless (wm-object-p object) (setf object (gethash object *literal-objects*)) (unless object (return-from get-slot (values nil nil)))) (multiple-value-bind (slot exists) (gethash slot-name (wm-map-slots (wm-object-map object))) (when exists (setf exists (>= (wm-slot-index slot) 0))) (values (when exists (svref (wm-object-slots object) (wm-slot-index slot))) exists))) (defun set-slot (object slot-name slot-value) ;(format t "(set-slot ~A ~A ~A)~%" object slot-name slot-value) (unless (wm-object-p object) (setf object (gethash object *literal-objects*))) (let ((slot (gethash slot-name (wm-map-slots (wm-object-map object))))) (when (wm-slot-delegates slot) (setf (wm-object-map object) (clone-map (wm-object-map object)))) (setf (svref (wm-object-slots object) (wm-slot-index slot)) slot-value) slot-value)) (defsetf get-slot set-slot) (define-condition method-not-found (error #+nil slate-condition) ((method-name :initarg :method-name :initform "" :reader method-name) (args :initarg :args :initform '() :reader method-args)) (:report (lambda (condition stream) (format stream "Error: A method named '~A' was not found for the arguments: ~A" (method-name condition) (method-args condition)))) #-ecl (:documentation "Notify the user that a method wasn't found, and report the method name and arguments, then resume the REPL.")) ;(defvar *debug-dispatch* nil) #+method-profiling (progn (defvar *early-dispatches* 0) (defvar *late-dispatches* 0) (defvar *selector-profile* (make-hash-table)) (defvar *method-profile* (make-hash-table)) (defun clear-profile () (setf *selector-cache-invocations* 0) (setf *selector-cache-misses* 0) (setf *early-dispatches* 0) (setf *late-dispatches* 0) (clrhash *selector-profile*) (clrhash *method-profile*)) (defun method-profile () (let ((profile '())) (loop for method being each hash-key in *method-profile* using (hash-value count) do (push (cons method count) profile)) (setf profile (sort profile #'< :key #'cdr)) (loop for (method . count) in profile do (format t "~A:~A:~A... ~A~%" (get-slot method '|fileName|) (get-slot method '|lineNumber|) (get-slot method '|selector|) count)))) (defun selector-profile () (let ((profile '())) (loop for name being each hash-key in *selector-profile* using (hash-value count) do (push (cons name count) profile)) (setf profile (sort profile #'< :key #'cdr)) (loop for (name . count) in profile do (format t "~A: ~A~%" name count))))) (defun dispatch-method (name ignore error arguments) ; (when *debug-dispatch* (format t "DISPATCHING: ~A~%" name)) #+method-profiling (incf (gethash name *selector-profile* 0)) (loop for argument in #+(and :subjective-slate :layered-slate) (cons *layer* (append arguments (list *subject*))) #+(and :subjective-slate (not :layered-slate)) (append arguments (list *subject*)) #+(and :layered-slate (not :subjective-slate)) (cons *layer* arguments) #-(or :subjective-slate :layered-slate) arguments and index from 0 and delegations = '() with methods = (make-hash-table) and visited = (make-hash-table) and order = (make-hash-table) and dispatch = nil and accessor = nil and least-method = nil and least-rank = 0 do ; (when *debug-dispatch* (format t "ARGUMENT: ~A @ ~A~%" argument index)) (loop for depth from 0 to #x1F while argument do (unless (wm-object-p argument) (setf argument (or (gethash argument *literal-objects*) (traits-for-prim argument)))) (multiple-value-bind (slot exists) (gethash name (wm-map-slots (wm-object-map argument))) (when exists (dolist (role (wm-slot-roles slot)) ; (when *debug-dispatch* (format t "ROLE: ~A/~A/~A~%" (wm-role-positions role) (wm-role-arguments role) ignore)) (when (logbitp index (wm-role-positions role)) (let ((method (wm-role-method role)) (rank 0)) (setf (gethash method order) (setf rank (logior (gethash method order 0) (ash (- #x1F depth) (* 5 (- 5 index)))))) (multiple-value-bind (positions exists) (gethash method methods) (when (= (setf (gethash method methods) (logior (or positions 0) (ash 1 index))) (wm-role-arguments role)) ; (when *debug-dispatch* (format t "ORDER: ~A~%" (gethash method order))) (when (and (or (null ignore) (< rank (gethash ignore order 0))) (or (null dispatch) (> rank (gethash dispatch order)))) (if (eq (get-slot method '|accessor|) *primitive-nil*) (setf accessor nil) (when (= index #-layered-slate 0 #+layered-slate 1) (setf accessor argument))) (when (> rank least-rank) (setf least-rank rank) (setf least-method method)) (setf dispatch method)))) (unless (eq least-method method) (when (>= rank least-rank) (setf least-rank rank) (setf least-method nil)))))) (when (and least-method (eq least-method dispatch)) (when accessor (setf (first arguments) accessor)) #+method-profiling (progn (incf *early-dispatches*) (incf (gethash least-method *method-profile* 0))) (return-from dispatch-method least-method)))) (loop for slot-name in (wm-map-slot-names (wm-object-map argument)) for slot = (gethash slot-name (wm-map-slots (wm-object-map argument))) for contents = (svref (wm-object-slots argument) (wm-slot-index slot)) when (and (wm-slot-delegates slot) contents (not (eq contents *primitive-nil*)) (not (logbitp index (gethash contents visited 0)))) do ; (when *debug-dispatch* (format t "DELEGATE: ~A@~A -> ~A~%" slot-name index (svref (wm-object-slots argument) (wm-slot-index slot)))) (setf (gethash contents visited) (logior (gethash contents visited 0) (ash 1 index))) (push contents delegations) finally (setf argument (pop delegations)))) (when argument (format t "Depth overflow while dispatching: ~A~%" name)) finally (when dispatch (when accessor (setf (first arguments) accessor)) ; (when *debug-dispatch* (format t "FIN: ~A~%" (gethash dispatch order))) #+method-profiling (progn (incf *late-dispatches*) (incf (gethash dispatch *method-profile* 0))) (return-from dispatch-method dispatch))) (if error (if (or *slate-debug* (eq (dispatch-method '|notFoundOn:| nil nil (list name (coerce arguments 'simple-vector))) *primitive-nil*)) (handler-bind ((method-not-found #'(lambda (c) (when (y-or-n-p "~&~A~&Return to the Slate top level? " c) (throw 'top-level *primitive-nil*))))) (signal 'method-not-found :method-name name :args (loop for argument in arguments collect argument))) (invoke-method '|notFoundOn:| nil name (coerce arguments 'simple-vector))) *primitive-nil*)) (defvar *slate-debuggable* nil) (defvar *slate-backtrace* '()) (defmacro apply-method (method &rest arguments) (let ((meth-sym (%gensym))) `(let ((,meth-sym ,method)) (funcall (the function (get-slot ,meth-sym '|code|)) ,meth-sym ,@arguments)))) (defvar *lobby* nil) (defvar *traits-string* nil) (defvar *primitive-nil* nil) (defvar *slate-symbols* (make-array 4096 :initial-element nil :fill-pointer 0 :adjustable t)) (defun %intern (name) (let ((new-sym (intern name))) (unless (loop for sym across *slate-symbols* when (eq sym new-sym) return t) (vector-push-extend new-sym *slate-symbols*)) new-sym)) (defstruct sce (selector nil :type symbol) (method nil :type (or wm-object null)) (args 0 :type fixnum) (a nil :type (or wm-map wm-object null)) (b nil :type (or wm-map wm-object null)) (c nil :type (or wm-map wm-object null))) (defconstant *selector-cache-size* 1024) (defvar *selector-cache* (coerce (loop repeat *selector-cache-size* collect (make-sce)) 'simple-vector)) (defvar *selector-cache-misses* 0) (defvar *selector-cache-invocations* 0) (defvar *selector-cache-masks* (make-hash-table)) (defun sc-invoke-method (selector &rest arguments) (let ((sce (svref *selector-cache* (logand (sxhash selector) (1- *selector-cache-size*))))) (macrolet ((map-of (arg) (let ((arg-sym (gensym))) `(let ((,arg-sym ,arg)) (if (wm-object-p ,arg-sym) (wm-object-map ,arg-sym) (or (gethash ,arg-sym *literal-objects*) (traits-for-prim ,arg-sym))))))) (incf *selector-cache-invocations*) (if (and (eq (sce-selector sce) selector) (case (the fixnum (sce-args sce)) (1 (eq (sce-a sce) (map-of (first arguments)))) (2 (eq (sce-b sce) (map-of (second arguments)))) (3 (and (eq (sce-a sce) (map-of (first arguments))) (eq (sce-b sce) (map-of (second arguments))))) (4 (eq (sce-c sce) (map-of (third arguments)))) (5 (and (eq (sce-a sce) (map-of (first arguments))) (eq (sce-c sce) (map-of (third arguments))))) (6 (and (eq (sce-b sce) (map-of (second arguments))) (eq (sce-c sce) (map-of (third arguments))))) (7 (and (eq (sce-a sce) (map-of (first arguments))) (eq (sce-b sce) (map-of (second arguments))) (eq (sce-c sce) (map-of (third arguments))))))) (apply (the function (get-slot (sce-method sce) '|code|)) (sce-method sce) arguments) (let ((method (dispatch-method selector nil t arguments)) (roles (gethash selector *selector-cache-masks* #xF))) (incf *selector-cache-misses*) (when (<= roles 7) (setf (sce-selector sce) selector) (setf (sce-method sce) method) (setf (sce-args sce) roles) (unless (zerop (logand roles 1)) (setf (sce-a sce) (map-of (first arguments)))) (unless (zerop (logand roles 2)) (setf (sce-b sce) (map-of (second arguments)))) (unless (zerop (logand roles 4)) (setf (sce-c sce) (map-of (third arguments))))) (apply (the function (get-slot method '|code|)) method arguments)))))) (defun sc-flush () (loop for sce across *selector-cache* do (setf (sce-selector sce) nil))) (defun invoke-method (selector ignore &rest arguments) (let ((method (dispatch-method selector ignore t arguments))) (cond (*slate-debuggable* (prog2 (push (list method selector arguments) *slate-backtrace*) (apply (the function (get-slot method '|code|)) method arguments) (pop *slate-backtrace*))) (t (apply (the function (get-slot method '|code|)) method arguments))))) (defun invoke-method-with-optionals (selector ignore optionals &rest arguments) (let ((method (dispatch-method selector ignore t arguments))) (cond (*slate-debuggable* (prog2 (push (list method selector arguments optionals) *slate-backtrace*) (apply (the function (get-slot method '|code|)) method (append arguments (list optionals))) (pop *slate-backtrace*))) (t (nconc arguments (list optionals)) (apply (the function (get-slot method '|code|)) method arguments))))) (defun %add-roles (name do-clone method &rest objects) (sc-flush) #+subjective-slate (when (and (boundp '*subject*) *subject*) (nconc objects (list (get-slot *subject* '|focus|)))) #+layered-slate (push (when (and (boundp '*layer*) *layer*) (get-slot *layer* '|focus|)) objects) (let ((arguments (loop for object in objects and index from 0 when object sum (ash 1 index)))) (setf (gethash name *selector-cache-masks*) (logior (gethash name *selector-cache-masks* 0) arguments)) (loop for object in objects and index from 0 when object do (add-role object name do-clone (ash 1 index) arguments method)) method)) (defun add-roles (name method &rest objects) (when (eq name '|intern:|) (defun %intern (name) (invoke-method '|intern:| nil *lobby* name))) (sc-flush) #+subjective-slate (when (and (boundp '*subject*) *subject*) (nconc objects (list (get-slot *subject* '|focus|)))) #+layered-slate (push (if (and (boundp '*layer*) *layer*) (get-slot *layer* '|focus|) *no-role*) objects) (when (replace-method name objects method) (return-from add-roles method)) (let ((arguments (loop for object in objects and index from 0 when (and object (not (eq object *no-role*))) sum (ash 1 index)))) (setf (gethash name *selector-cache-masks*) (logior (gethash name *selector-cache-masks* 0) arguments)) (loop for object in objects and index from 0 if (and object (not (eq object *no-role*))) do (add-role object name nil (ash 1 index) arguments method)) method)) (defmacro define-method (name arguments &body body) (let ((optionals (when (member '&optionals arguments) (prog1 (first (last arguments)) (setf arguments (nbutlast arguments 2))))) (argument-names (loop for argument in arguments if (consp argument) collect (first argument) else collect argument)) (selector (if (stringp name) (%intern name) (%intern (string-downcase (string name)))))) `(%add-roles ',selector t (make-slate-method "" 0 ',selector ',argument-names *primitive-nil* (lambda (currentBlock ,@argument-names ,@(when optionals `(&optional ,optionals))) (block ,(when (symbolp name) name) (let ((currentMethod currentBlock)) (declare (ignore currentMethod)) ,@body)))) ,@(loop for argument in arguments collect (when (consp argument) (second argument)))))) (defmacro %slate (&rest exps) (labels ((gen-exp (exp) (cond ((not (consp exp)) exp) ((eq (first exp) 'quote) (second exp)) (t `(invoke-method ',(first exp) nil ,@(mapcar #'gen-exp (rest exp))))))) `(progn ,@(mapcar #'gen-exp exps))))