Permalink
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
263 lines (231 sloc) 11.3 KB
(in-package :cl-js)
(defstruct lib
name
prototypes
toplevel)
(defmethod print-object ((obj lib) stream)
(print-unreadable-object (obj stream :type t)
(princ (or (lib-name obj) "unnamed") stream)))
(defstruct objspec
(prototype :object)
props)
(defstruct (funcspec (:include objspec))
call
proto-spec
make-new)
(defvar *lib*)
(defvar *objspec*)
(defparameter *default-slot-flags* +slot-dflt+)
(defun slot-flags (&rest flags)
(let ((val *default-slot-flags*))
(macrolet ((add (flag) `(setf val (logior val ,flag)))
(rm (flag) `(setf val (logand val (lognot ,flag)))))
(dolist (flag flags)
(case flag
(:enum (rm +slot-noenum+)) (:noenum (add +slot-noenum+))
(:ro (add +slot-ro+)) (:rw (rm +slot-ro+))
(:del (rm +slot-nodel+)) (:nodel (add +slot-nodel+))
(active (add +slot-active+)))))
val))
(defun check-spec (spec &rest allowed)
(loop :for elt :in spec :do
(if (and (consp elt) (keywordp (car elt)))
(unless (member (car elt) allowed)
(error "No ~a specs allowed in this form." (car elt)))
(unless (member t allowed)
(error "No body (non-keyword-list element) allowed in this form.")))))
(defmacro with-default-slot-flags ((&rest flags) &body body)
`(let ((*default-slot-flags* (slot-flags ,@flags))) ,@body))
(defun spec-val (spec type &optional default)
(let ((found (find type spec :test #'eq :key (lambda (sp) (and (consp sp) (car sp))))))
(if found (second found) default)))
(defun spec-list (spec type &optional default)
(let ((any nil))
(loop :for part :in spec
:when (and (consp part) (eq (car part) type))
:do (setf any t) :and :append (cdr part)
:finally (unless any (return default)))))
(defun spec-body (spec)
(loop :for part :in spec
:unless (and (consp part) (keywordp (car part))) :collect part))
(defun add-prop (name val &optional (flags +slot-dflt+))
(let* ((props (objspec-props *objspec*))
(found (assoc name props :test #'string=)))
(cond (found (setf (cdr found) (cons val flags)))
(props (setf (cdr (last props)) (list (list* name val flags))))
(t (setf (objspec-props *objspec*) (list (list* name val flags)))))))
(defun add-prototype (tag spec)
(let* ((protos (lib-prototypes *lib*))
(found (assoc tag protos :test #'eq)))
(cond (found (setf (cdr found) spec))
(protos (setf (cdr (last protos)) (list (cons tag spec))))
(t (setf (lib-prototypes *lib*) (list (cons tag spec)))))))
(defun empty-lib (&optional name)
(make-lib :name name :toplevel (make-objspec :prototype :object)))
(defmacro add-to-lib (lib &body body)
`(let* ((*lib* ,lib)
(*objspec* (lib-toplevel *lib*)))
,@body
*lib*))
(defun default-constructor-name (structname)
(intern (format nil "%make-new-~a-~a" (symbol-name structname) (package-name (symbol-package structname))) :cl-js))
(defmacro define-js-obj (name &body slots)
(multiple-value-bind (name opts)
(if (consp name) (values (car name) (cdr name)) (values name ()))
`(defstruct (,name (:include obj) (:constructor ,(default-constructor-name name) (cls)) ,@opts) ,@slots)))
(defparameter *stdlib* (empty-lib "standard-library"))
(defmacro .prototype (tag &body spec)
(check-spec spec :parent :slot-default t)
`(let ((*objspec* (make-objspec :prototype ,(spec-val spec :parent :object)))
(*default-slot-flags* (slot-flags ,@(let ((list (spec-list spec :slot-default)))
(if (member :enum list) list (cons :noenum list))))))
,@(spec-body spec)
(add-prototype ,tag *objspec*)))
(defun arg-count (list)
(or (position '&rest list) (length list)))
(defmacro .constructor (name (&rest args) &body spec)
(check-spec spec :prototype :slot-default t :properties :slot :make-new :type)
(let* ((proto (spec-list spec :prototype))
(proto (if (keywordp (car proto))
(car proto)
(progn
(check-spec proto :slot-default t)
`(let ((*objspec* (make-objspec))
(*default-slot-flags* (slot-flags ,@(let ((list (spec-list proto :slot-default)))
(if (member :enum list) list (cons :noenum list))))))
,@(spec-body proto)
*objspec*)))))
`(add-prop
,name
(let ((*objspec* (make-funcspec :call ,(wrap-js-lambda args (spec-body spec))
:prototype :function
:proto-spec ,proto
:make-new ,(let ((type (spec-val spec :type)))
(if type
`',(default-constructor-name type)
(spec-val spec :make-new)))))
(*default-slot-flags* (slot-flags ,@(spec-list spec :slot-default '(:enum)))))
(.value "length" (:slot :ro :noenum) ,(arg-count args))
,@(spec-list spec :properties)
*objspec*)
(slot-flags ,@(spec-list spec :slot)))))
(defmacro .object (name &body spec)
(check-spec spec :parent :slot-default t :slot)
`(add-prop
,name
(let ((*objspec* (make-objspec :prototype ,(spec-val spec :parent :object)))
(*default-slot-flags* (slot-flags ,@(spec-list spec :slot-default '(:enum)))))
,@(spec-body spec)
*objspec*)
(slot-flags ,@(spec-list spec :slot))))
(defmacro .value (name &body spec)
(check-spec spec :slot t)
`(add-prop ,name (lambda () ,@(spec-body spec)) (slot-flags ,@(spec-list spec :slot))))
(defmacro .func (name (&rest args) &body spec)
(check-spec spec :slot :slot-default :properties t)
`(add-prop
,name
(let ((*objspec* (make-funcspec :call ,(wrap-js-lambda args (spec-body spec))
:prototype :function))
(*default-slot-flags* (slot-flags ,@(spec-list spec :slot-default '(:enum)))))
,@(spec-list spec :properties)
(.value "length" (:slot :ro :noenum) ,(arg-count args))
*objspec*)
(slot-flags ,@(spec-list spec :slot))))
(defmacro .active (name &body spec)
(check-spec spec :read :write :slot)
`(add-prop
,name
(cons ,(let ((read (spec-list spec :read)))
(and read (wrap-js-lambda (car read) (cdr read))))
,(let ((write (spec-list spec :write)))
(and write (wrap-js-lambda (car write) (cdr write)))))
(slot-flags 'active ,@(spec-list spec :slot))))
(defmacro .active-r (name &body spec)
(check-spec spec :slot t)
`(add-prop
,name
(cons ,(wrap-js-lambda () (spec-body spec)) nil)
(slot-flags 'active ,@(spec-list spec :slot))))
;; Building environments.
(defun init-val (value)
(typecase value
(function (funcall value))
(objspec (init-obj value))
(t value)))
(defun init-obj (spec &optional fill)
(when (keywordp spec)
(return-from init-obj (find-proto spec)))
(let* ((props (objspec-props spec))
(is-func (funcspec-p spec))
(new-proto (when (and is-func (funcspec-proto-spec spec))
(let ((proto-obj (init-obj (funcspec-proto-spec spec))))
(push (list* "prototype" proto-obj +slot-noenum+) props)
proto-obj)))
(new-cls (make-scls () new-proto))
(vals (make-array (max 2 (length props))))
(cls (make-scls (loop :for off :from 0 :for (name value . flags) :in props
:do (setf (svref vals off) (init-val value))
:collect (list* (intern-prop name) off flags))
(and (objspec-prototype spec) (init-obj (objspec-prototype spec))))))
(cond (fill (setf (obj-vals fill) vals (obj-cls fill) cls))
((funcspec-p spec)
(let ((built (if (funcspec-make-new spec)
(make-cfobj cls (funcspec-call spec) new-cls (funcspec-make-new spec) vals)
(make-fobj cls (funcspec-call spec) new-cls vals))))
(when new-proto
(ensure-slot new-proto "constructor" built +slot-noenum+))
built))
(t (make-obj cls vals)))))
(defun create-env (&rest libs)
(let* ((bootstrap (make-array (length *std-types*) :initial-contents
(loop :repeat (length *std-types*) :collect (make-obj nil nil))))
(objproto (svref bootstrap (type-offset :object)))
(clss (make-array (length *std-types*) :initial-contents
(loop :for id :across *std-types* :for i :from 0 :collect
(make-scls () (svref bootstrap i)))))
(*env* (make-gobj (make-hcls objproto) (make-hash-table :test 'eq) bootstrap clss)))
(loop :for (id . obj) :in (lib-prototypes *stdlib*) :do
(let ((pos (position id *std-types*)))
(when pos
(init-obj obj (aref bootstrap pos)))))
(loop :for shell :across bootstrap :for i :from 0 :do
(unless (obj-cls shell) (error "Missing definition for standard class ~a" (aref *std-types* i))))
(apply 'add-to-env *env* *stdlib* libs)
*env*))
(defun add-to-env (*env* &rest libs)
(dolist (lib libs)
(loop :for (id . obj) :in (lib-prototypes lib) :do
(unless (find id *std-types*)
(let ((proto (init-obj obj)))
(push (list* id proto (make-scls () proto)) (gobj-proto-list *env*)))))
(loop :for (name val . flags) :in (objspec-props (lib-toplevel lib)) :do
(ensure-slot *env* name (init-val val) flags)))
*env*)
(defmacro with-js-env ((&rest libs) &body body)
`(let ((*env* (create-env ,@libs))) ,@body))
(defmacro integrate-type (specializer &body spec)
(check-spec spec :string :boolean :number :typeof :proto-id)
(flet ((arg/body (list)
(if (and (consp (car list)) (cdr list))
(values (caar list) (cdr list))
(values (gensym) list))))
`(progn
,@(let ((proto-id (spec-list spec :proto-id)))
(when proto-id
(multiple-value-bind (arg body) (arg/body proto-id)
`((defmethod static-js-prop ((,arg ,specializer) cache)
(funcall (the function (cache-op cache)) ,arg (find-proto (progn ,@body)) cache))
(defmethod js-prop ((,arg ,specializer) prop)
(do-lookup ,arg (find-proto (progn ,@body)) prop))
(defmethod (setf static-js-prop) (val (obj ,specializer) wcache)
(declare (ignore wcache)) val)
(defmethod (setf js-prop) (val (obj ,specializer) prop)
(declare (ignore prop)) val)
(defmethod js-for-in ((,arg ,specializer) func &optional shallow)
(js-for-in (find-proto (progn ,@body)) func shallow))))))
,@(loop :for (tag method default) :in '((:string js-to-string "[object Object]") (:number js-to-number (nan))
(:boolean js-to-boolean t) (:typeof js-type-of "foreign")) :collect
(let ((found (spec-list spec tag)))
(multiple-value-bind (arg body) (if found (arg/body found) (values (gensym) (list default)))
`(defmethod ,method ((,arg ,specializer)) ,@body)))))))