jsos.lisp

(in-package :cl-js)

(defvar *env*)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defparameter *std-types*
    #(:object :function :array :string :arguments :regexp #+js-dates :date :error :type-error
      :reference-error :syntax-error :uri-error :range-error :eval-error :boolean :number))
  (defun type-offset (id)
    (declare (optimize speed (safety 0)))
    (loop :for off :of-type fixnum :below (length (the simple-vector *std-types*)) :do
       (when (eq id (svref *std-types* off)) (return off)))))

(defmacro find-proto (id)
  (let ((std (and (keywordp id) (position id *std-types* :test #'eq))))
    (if std
        `(svref (gobj-proto-vec *env*) ,std)
        `(lookup-prototype ,id))))
(defmacro find-cls (id)
  (let ((std (and (keywordp id) (position id *std-types* :test #'eq))))
    (if std
        `(svref (gobj-class-vec *env*) ,std)
        `(lookup-class ,id))))
(defun lookup-prototype (id)
  (let ((std (position id *std-types* :test #'eq)))
    (or (and std (svref (gobj-proto-vec *env*) std))
        (second (assoc id (gobj-proto-list *env*) :test #'eq))
        (error "No prototype ~a defined." id))))
(defun lookup-class (id)
  (let ((std (position id *std-types* :test #'eq)))
    (or (and std (svref (gobj-class-vec *env*) std))
        (cddr (assoc id (gobj-proto-list *env*) :test #'eq))
        (error "No prototype ~a defined." id))))


;; (Some of this code is *really* unorthogonal, repeating itself a
;; lot. This is mostly due to the fact that we are using different
;; code paths, some of which can assume previously-checked conditions,
;; to optimize.)

(eval-when (:compile-toplevel)
  (declaim (optimize speed (safety 0))))

(defstruct cls prototype)
(defstruct (scls (:constructor make-scls (props prototype)) (:include cls))
  props children)
(defstruct (hcls (:constructor make-hcls (prototype)) (:include cls)))

(defstruct (obj (:constructor make-obj (cls &optional vals)))
  cls (vals (make-array 4)))
(defstruct (vobj (:constructor make-vobj (cls &optional value)) (:include obj))
  value)
(defstruct (fobj (:constructor make-fobj (cls proc new-cls &optional vals)) (:include obj))
  proc new-cls)
(defstruct (cfobj (:constructor make-cfobj (cls proc new-cls make-new &optional vals)) (:include fobj))
  make-new)
(defstruct (gobj (:constructor make-gobj (cls vals proto-vec class-vec)) (:include obj))
  proto-vec class-vec proto-list required)
(defstruct (aobj (:constructor make-aobj (cls &optional arr)) (:include obj))
  (arr (empty-fvector 0)))
(defstruct (reobj (:constructor make-reobj (cls &optional proc scanner global)) (:include fobj))
  scanner global)
#+js-dates
(defstruct (dobj (:constructor make-dobj (cls &optional time zone)) (:include obj))
  time zone)
(defstruct (argobj (:constructor make-argobj (cls list length callee)) (:include obj))
  list length callee)

(defun make-sequence-printer (stream)
  (let ((count 0))
    (lambda (x)
      (cond
        ((not count))
        ((and *print-length* (<= *print-length* count))
         (format stream " ...")
         (setf count nil))
        (t
         (unless (= count 0)
           (format stream ", "))
         (princ x stream)
         (incf count))))))

(defmethod print-object ((obj obj) stream)
  (let ((*print-circle* t))
    (format stream "#<js obj {")
    (let ((output (make-sequence-printer stream)))
      (js-for-in obj
                 (lambda (key)
                   (funcall output (format nil "~S: ~S" key (js-prop obj key))))
                 t))
    (format stream "}>")))

(defmethod print-object ((aobj aobj) stream)
  (format stream "#<js array [")
  (let ((output (make-sequence-printer stream)))
    (map nil output (aobj-arr aobj)))
  (format stream "]>"))

(defmethod print-object ((func fobj) stream)
  (format stream "#<js function ~A>" (fobj-proc func)))

(defmethod obj-class-name ((obj obj)) "Object")
(defmethod obj-class-name ((obj fobj)) "Function")
(defmethod obj-class-name ((obj cfobj)) "Object")
#+js-dates
(defmethod obj-class-name ((obj dobj)) "Date")
(defmethod obj-class-name ((obj argobj)) "Arguments")
(defmethod obj-class-name ((obj aobj)) "Array")
(defmethod obj-class-name ((obj reobj)) "RegExp")
(defmethod obj-class-name ((obj (eql :undefined))) "Undefined")
(defmethod obj-class-name ((obj (eql :null))) "Undefined")
(defmethod obj-class-name ((obj (eql t))) "Boolean")
(defmethod obj-class-name ((obj (eql nil))) "Boolean")
(defmethod obj-class-name ((obj number)) "Number")
(defmethod obj-class-name ((obj string)) "String")
(defmethod obj-class-name ((obj t)) "Object")

;; Slots are (offset . flags) conses for scls objects, (value . flags) conses for hcls
(defconstant +slot-ro+ 1)
(defconstant +slot-active+ 2)
(defconstant +slot-noenum+ 4)
(defconstant +slot-nodel+ 8)
(defconstant +slot-dflt+ 0)

(defun hash-obj (obj hcls)
  (let* ((scls (obj-cls obj))
         (hcls (or hcls (make-hcls (cls-prototype scls))))
         (vec (obj-vals obj))
         (table (make-hash-table :test 'eq :size (* (length vec) 2))))
    (loop :for (prop offset . flags) :in (scls-props scls) :do
       (setf (gethash prop table) (cons (svref vec offset) flags)))
    (setf (obj-cls obj) hcls (obj-vals obj) table))
  obj)

(defun proc (val)
  (if (fobj-p val)
      (fobj-proc val)
      (js-error :type-error "~a is not a function." (to-string val))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defvar *prop-names*
    #+allegro (make-hash-table :test 'equal :weak-keys t :values :weak)
    #+sbcl (make-hash-table :test 'equal :weakness :key-or-value)
    #-(or allegro sbcl) (make-hash-table :test 'equal))) ;; Space leak when we don't have weak hashes
(defun intern-prop (prop)
  (or (gethash prop *prop-names*)
      (setf (gethash prop *prop-names*) prop)))

(defmacro lookup-slot (scls prop)
  `(cdr (assoc ,prop (scls-props ,scls) :test #'eq)))
(defmacro dcall (proc obj &rest args)
  `(funcall (the function ,proc) ,obj ,@args))

(defstruct (cache (:constructor make-cache (prop)))
  (op #'cache-miss) prop cls a1 a2)

(defmethod static-js-prop ((obj obj) cache)
  (funcall (the function (cache-op cache)) obj obj cache))
(defmethod static-js-prop (obj cache)
  (declare (ignore cache))
  (js-error :type-error "~a has no properties." (to-string obj)))

(defun do-lookup (obj start prop)
  (simple-lookup obj start (intern-prop (if (stringp prop) prop (to-string prop)))))
(defmethod js-prop ((obj obj) prop)
  (do-lookup obj obj prop))
(defmethod js-prop (obj prop)
  (declare (ignore prop))
  (js-error :type-error "~a has no properties." (to-string obj)))

(defun index-in-range (index len)
  (if (and (typep index 'fixnum) (>= index 0) (< index len))
      index
      (let ((index (to-string index)) index-int)
        (declare (string index))
        (if (and (loop :for ch :across index :do
                    (unless (<= #.(char-code #\0) (char-code ch) #.(char-code #\9)) (return nil))
                    :finally (return t))
                 (progn (setf index-int (parse-integer index)) (>= index-int 0) (< index-int len)))
            index-int
            nil))))

(defmethod js-prop ((obj aobj) prop)
  (let* ((vec (aobj-arr obj))
         (index (index-in-range prop (length vec))))
    (if index
        (aref vec index)
        (do-lookup obj obj prop))))
(defmethod js-prop ((obj argobj) prop)
  (let ((lst (argobj-list obj))
        (index (index-in-range prop (argobj-length obj))))
    (if index
        (nth index lst)
        (do-lookup obj obj prop))))

(defvar *not-found* :undefined)
(defmacro if-not-found ((var lookup) &body then/else)
  (unless var (setf var (gensym)))
  `(let ((,var (let ((*not-found* :not-found)) ,lookup)))
     (declare (ignorable ,var))
     (if (eq ,var :not-found) ,@then/else)))

;; Used for non-cached lookups
(defun simple-lookup (this start prop)
  (loop :for obj := start :then (or (cls-prototype cls) (return *not-found*))
        :for cls := (obj-cls obj) :for vals := (obj-vals obj) :do
     (macrolet ((maybe-active (slot value)
                  `(if (logtest (cdr ,slot) +slot-active+)
                       (dcall (car ,value) this)
                       ,value)))
       (if (hash-table-p vals)
           (let ((slot (gethash prop vals)))
             (when slot
               (return (maybe-active slot (car slot)))))
           (let ((slot (lookup-slot cls prop)))
             (when slot
               (return (maybe-active slot (svref vals (car slot))))))))))

(defun cache-miss (val obj cache)
  (multiple-value-bind (fn a1 a2 result) (meta-lookup val obj (cache-prop cache))
    (setf (cache-op cache) fn (cache-a1 cache) a1 (cache-a2 cache) a2 (cache-cls cache) (obj-cls obj))
    result))

(defun %direct-lookup (val obj cache)
  (if (eq (cache-cls cache) (obj-cls obj))
      (svref (obj-vals obj) (cache-a1 cache))
      (cache-miss val obj cache)))

(defun %direct-lookup-d (val obj cache)
  (if (eq (cache-cls cache) (obj-cls obj))
      (dcall (car (svref (obj-vals obj) (cache-a1 cache))) val)
      (cache-miss val obj cache)))

(defun %direct-lookup-m (val obj cache)
  (if (eq (cache-cls cache) (obj-cls obj))
      *not-found*
      (cache-miss val obj cache)))

(defun %direct-lookup-h (val obj cache)
  (if (hash-table-p (obj-vals obj))
      (simple-lookup val obj (cache-prop cache))
      (cache-miss val obj cache)))

(defun %proto-lookup (val obj cache)
  (let* ((cls (obj-cls obj))
         (proto (cls-prototype cls)))
    (if (and (eq (cache-cls cache) cls)
             (eq (cache-a2 cache) (obj-cls proto)))
        (svref (obj-vals proto) (cache-a1 cache))
        (cache-miss val obj cache))))

(defun %proto-lookup-d (val obj cache)
  (let* ((cls (obj-cls obj))
         (proto (cls-prototype cls)))
    (if (and (eq (cache-cls cache) cls)
             (eq (cache-a2 cache) (obj-cls proto)))
        (dcall (car (svref (obj-vals proto) (cache-a1 cache))) val)
        (cache-miss val obj cache))))

(defun %proto-lookup-m (val obj cache)
  (let ((cls (obj-cls obj)))
    (if (and (eq (cache-cls cache) cls)
             (eq (cache-a2 cache) (obj-cls (cls-prototype cls))))
        *not-found*
        (cache-miss val obj cache))))

(defun %proto-lookup-h (val obj cache)
  (let ((cls (obj-cls obj)))
    (if (eq (cache-cls cache) cls)
        (simple-lookup val (cls-prototype cls) (cache-prop cache))
        (cache-miss val obj cache))))

(defun %deep-lookup (val obj cache)
  (let* ((cls (obj-cls obj))
         (proto-cls (obj-cls (cls-prototype cls))))
    (if (and (eq (cache-cls cache) cls)
             (eq (cache-a2 cache) proto-cls))
        (simple-lookup val (cls-prototype proto-cls) (cache-prop cache))
        (cache-miss val obj cache))))

(defun meta-lookup (this obj prop)
  (macrolet ((ret (&rest vals) `(return-from meta-lookup (values ,@vals))))
    (let ((cls (obj-cls obj)) (vals (obj-vals obj)))
      (when (hash-table-p vals)
        (ret #'%direct-lookup-h nil nil (simple-lookup this obj prop)))
      (let ((slot (lookup-slot cls prop)))
        (when slot
          (if (logtest (cdr slot) +slot-active+)
              (ret #'%direct-lookup-d (car slot) nil (dcall (car (svref vals (car slot))) this))
              (ret #'%direct-lookup (car slot) nil (svref vals (car slot))))))
      (let ((proto (cls-prototype cls)))
        (unless proto (ret #'%direct-lookup-m nil nil *not-found*))
        (let ((proto-cls (obj-cls proto)) (proto-vals (obj-vals proto)))
          (when (hash-table-p proto-vals)
            (ret #'%proto-lookup-h nil nil (simple-lookup this proto prop)))
          (let ((slot (lookup-slot proto-cls prop)))
            (when slot
              (if (logtest (cdr slot) +slot-active+)
                  (ret #'%proto-lookup-d (car slot) proto-cls (dcall (car (svref proto-vals (car slot))) this))
                  (ret #'%proto-lookup (car slot) proto-cls (svref proto-vals (car slot))))))
          (let ((proto2 (cls-prototype proto-cls)))
            (unless proto2 (ret #'%proto-lookup-m nil proto-cls *not-found*))
            (ret #'%deep-lookup nil proto-cls (simple-lookup this proto2 prop))))))))

(defun expand-cached-lookup (obj prop)
  `(static-js-prop ,obj (load-time-value (make-cache (intern-prop ,prop)))))
(defmacro cached-lookup (obj prop)
  (expand-cached-lookup obj prop))

;; Writing

(defun update-class-and-set (obj new-cls slot val)
  (setf (obj-cls obj) new-cls)
  (unless (< slot (length (obj-vals obj)))
    (let ((vals (make-array (max 4 (* 2 (length (obj-vals obj)))))))
      (replace vals (obj-vals obj))
      (setf (obj-vals obj) vals)))
  (setf (svref (obj-vals obj) slot) val))

(defstruct (wcache (:constructor make-wcache (prop)))
  (op #'wcache-miss) cls prop slot a1)

(defun %simple-set (obj wcache val)
  (if (eq (obj-cls obj) (wcache-cls wcache))
      (setf (svref (obj-vals obj) (wcache-slot wcache)) val)
      (wcache-miss obj wcache val)))

(defun %active-set (obj wcache val)
  (if (eq (obj-cls obj) (wcache-cls wcache))
      (progn (dcall (wcache-a1 wcache) obj val) val)
      (wcache-miss obj wcache val)))

(defun %change-class-set (obj wcache val)
  (if (eq (obj-cls obj) (wcache-cls wcache))
      (update-class-and-set obj (wcache-a1 wcache) (wcache-slot wcache) val)
      (wcache-miss obj wcache val)))

(defun %ignored-set (obj wcache val)
  (if (eq (obj-cls obj) (wcache-cls wcache))
      val
      (wcache-miss obj wcache val)))

(defun %hash-set (obj wcache val)
  (if (hash-table-p (obj-vals obj))
      (hash-set obj (wcache-prop wcache) val)
      (wcache-miss obj wcache val)))

(defun %hash-then-set (obj wcache val)
  (if (eq (obj-cls obj) (wcache-cls wcache))
      (progn (hash-obj obj (scls-children (obj-cls obj)))
             (setf (gethash (wcache-prop wcache) (obj-vals obj)) (cons val +slot-dflt+))
             val)
      (wcache-miss obj wcache val)))

(defun hash-set (obj prop val)
  (let* ((table (obj-vals obj))
         (exists (gethash prop table)))
    (if exists
        (setf (car exists) val)
        ;; Check prototypes for read-only or active slots
        (if (let (curc curv hash slot)
              (loop :for cur := (cls-prototype (obj-cls obj)) :then (cls-prototype curc) :while cur :do
                 (setf curc (obj-cls cur) curv (obj-vals cur) hash (hash-table-p curv))
                 (setf slot (if hash (gethash prop curv) (lookup-slot curc prop)))
                 (when slot
                   (when (logtest (cdr slot) +slot-ro+) (return t))
                   (when (logtest (cdr slot) +slot-active+)
                     (let ((func (cdr (if hash (car slot) (svref curv (car slot))))))
                       (when func (dcall func obj val))
                       (return t)))
                   (return nil))))
            val
            (progn (setf (gethash prop table) (cons val +slot-dflt+)) val)))))

(defun wcache-miss (obj wcache val)
  (setf (wcache-cls wcache) (obj-cls obj))
  (multiple-value-bind (fn slot a1) (meta-set obj (wcache-prop wcache) val)
    (setf (wcache-op wcache) fn (wcache-slot wcache) slot (wcache-a1 wcache) a1)
    val))

;; This makes the assumption that the read-only flag of a property is
;; final, and doesn't change at runtime. If we add code to allow
;; twiddling of this flag, we can no longer cache the check.
(defun meta-set (obj prop val)
  (macrolet ((ret (&rest vals) `(return-from meta-set (values ,@vals))))
    (let ((cls (obj-cls obj)) (vals (obj-vals obj)))
      (when (hash-table-p vals)
        (hash-set obj prop val)
        (ret #'%hash-set))
      (let ((slot (lookup-slot cls prop)))
        (when slot
          (when (logtest (cdr slot) +slot-ro+)
            (ret #'%ignored-set))
          (when (logtest (cdr slot) +slot-active+)
            (let ((func (cdr (svref vals (car slot)))))
              (when func
                (dcall func obj val)
                (ret #'%active-set (car slot) func))
              (ret #'%ignored-set)))
          (setf (svref vals (car slot)) val)
          (ret #'%simple-set (car slot))))
      ;; Look for a read-only or active slot in prototypes
      (let (curc curv hash)
        (loop :for cur := (cls-prototype cls) :then (cls-prototype curc) :while cur :do
           (setf curc (obj-cls cur) curv (obj-vals cur) hash (hash-table-p curv))
           (let ((slot (if hash (gethash prop curv) (lookup-slot curc prop))))
             (when slot
               (when (logtest (cdr slot) +slot-ro+) (ret #'%ignored-set))
               (when (logtest (cdr slot) +slot-active+)
                 (let ((func (cdr (if hash (car slot) (svref curv (car slot))))))
                   (when func
                     (dcall func obj val)
                     (ret #'%active-set (car slot) func))
                   (ret #'%ignored-set)))
               (return)))))
      ;; No direct slot found yet, but can write. Add slot.
      (scls-add-slot obj cls prop val +slot-dflt+))))
  
(defun scls-add-slot (obj cls prop val flags)
  ;; Setting scls-children to a hash class means hash, using that class, when adding slots
  (unless (listp (scls-children cls))
    (hash-obj obj (scls-children cls))
    (setf (gethash prop (obj-vals obj)) (cons val flags))
    (return-from scls-add-slot #'%hash-then-set))
  (let ((new-cls (cdr (assoc prop (scls-children cls) :test #'eq))) slot)
    ;; We switch to a hash table if this class has 8 'exits' (probably
    ;; being used as a container), and it is not one of the reused classes.
    (when (and (not new-cls) (or (nthcdr 8 (scls-children cls)) (nthcdr 40 (scls-props cls)))
               (not (find cls (gobj-class-vec *env*) :test #'eq)))
      (setf (scls-children cls) (make-hcls (cls-prototype cls)))
      (hash-obj obj (scls-children cls))
      (setf (gethash prop (obj-vals obj)) (cons val flags))
      (return-from scls-add-slot #'%hash-then-set))
    (if new-cls
        (setf slot (lookup-slot new-cls prop))
        (progn
          (setf slot (cons (length (scls-props cls)) flags)
                new-cls (make-scls (cons (cons prop slot) (scls-props cls)) (cls-prototype cls)))
          (push (cons prop new-cls) (scls-children cls))))
    (update-class-and-set obj new-cls (car slot) val)
    (values #'%change-class-set (car slot) new-cls)))

(defun ensure-slot (obj prop val &optional (flags +slot-dflt+))
  (setf prop (intern-prop prop))
  (let ((vals (obj-vals obj)))
    (if (hash-table-p vals)
        (setf (gethash prop vals) (cons val flags))
        (let* ((cls (obj-cls obj)) (slot (lookup-slot cls prop)))
          (if slot
              (setf (svref (obj-vals obj) (car slot)) val)
              (scls-add-slot obj cls prop val flags))))))

(defmethod (setf static-js-prop) (val (obj obj) wcache)
  (funcall (the function (wcache-op wcache)) obj wcache val))
(defmethod (setf static-js-prop) (val obj wcache)
  (declare (ignore wcache val))
  (js-error :type-error "~a has no properties." (to-string obj)))

(defmethod (setf js-prop) (val (obj obj) prop)
  ;; Uses meta-set since the overhead isn't big, and duplicating all
  ;; that logic is error-prone.
  (meta-set obj (intern-prop (if (stringp prop) prop (to-string prop))) val)
  val)
(defmethod (setf js-prop) (val obj prop)
  (declare (ignore prop val))
  (js-error :type-error "~a has no properties." (to-string obj)))
;; TODO sparse storage, clever resizing
(defmethod (setf js-prop) (val (obj aobj) prop)
  (let ((index (index-in-range prop most-positive-fixnum)))
    (if index
        (let ((arr (aobj-arr obj)))
          (when (>= index (length arr))
            (adjust-array arr (1+ index) :fill-pointer (1+ index) :initial-element :undefined))
          (setf (aref arr index) val))
        (call-next-method val obj prop))))
(defmethod (setf js-prop) (val (obj argobj) prop)
  (let ((lst (argobj-list obj))
        (index (index-in-range prop (argobj-length obj))))
    (if index
        (setf (nth index lst) val)
        (call-next-method val obj prop))))

(defun expand-cached-set (obj prop val)
  `(setf (static-js-prop ,obj (load-time-value (make-wcache (intern-prop ,prop)))) ,val))
(defmacro cached-set (obj prop val)
  (expand-cached-set obj prop val))

;; Optimized global-object access

(define-condition undefined-variable (js-condition) ()) ;; TODO proper contents
(defun undefined-variable (name)
  (let ((err (make-js-error :reference-error "Undefined variable: ~a" name)))
    (error 'undefined-variable :value err)))

(defun gcache-lookup (gcache obj)
  (let ((slot (car gcache))
        (cache (cdr gcache)))
    (macrolet ((read-slot ()
                 `(if (logtest (cdr slot) +slot-active+)
                      (if (eq (car slot) :deleted)
                          (progn (setf (car gcache) nil)
                                 (return-from gcache-lookup (gcache-lookup gcache obj)))
                          (dcall (car slot) obj))
                      (car slot))))
      (cond (slot (read-slot))
            ((setf slot (gethash (cache-prop cache) (obj-vals obj)))
             (setf (car gcache) slot)
             (read-slot))
            (t (if-not-found (value (static-js-prop obj cache))
                 (undefined-variable (cache-prop cache))
                 value))))))

(defun expand-global-lookup (prop)
  `(gcache-lookup (load-time-value (cons nil (make-cache (intern-prop ,prop)))) ,*env*))

(defun global-lookup (prop)
  (if-not-found (value (js-prop *env* prop))
    (undefined-variable prop)
    value))

(defun gcache-set (gcache obj val)
  (let ((slot (car gcache))
        (prop (cdr gcache)))
    (when (cond (slot t)
                ((setf slot (gethash prop (obj-vals obj))) (setf (car gcache) slot))
                (t (hash-set obj prop val) nil))
      (cond ((logtest (cdr slot) +slot-active+)
             (if (eq (car slot) :deleted)
                 (progn (setf (car gcache) nil)
                        (return-from gcache-set (gcache-set gcache obj val)))
                 (when (cdar slot) (dcall (cdar slot) obj val))))
            ((not (logtest (cdr slot) +slot-ro+))
             (setf (car slot) val))))
    val))

(defun expand-global-set (prop val)
  `(gcache-set (load-time-value (cons nil (intern-prop ,prop))) ,*env* ,val))

;; Enumerating

(defmethod js-for-in ((obj obj) func &optional shallow)
  (let ((stack ()))
    (flet ((maybe-yield (flags name)
             (unless (or (logtest flags +slot-noenum+)
                         (dolist (parent stack)
                           (when (find-slot* parent name) (return t))))
               (funcall func name))))
      (let (cls vals)
        (loop :for cur := obj :then (and shallow (cls-prototype cls)) :while cur :do
           (setf cls (obj-cls cur) vals (obj-vals cur))
           (if (hash-table-p vals)
               (with-hash-table-iterator (next vals)
                 (loop (multiple-value-bind (more name val) (next)
                         (unless more (return))
                         (maybe-yield (cdr val) name))))
               (loop :for (name nil . flags) :in (scls-props cls) :do
                  (maybe-yield flags name)))
           (push cur stack))))))

(defmethod js-for-in ((obj aobj) func &optional shallow)
  (declare (ignore shallow))
  (dotimes (i (length (aobj-arr obj))) (funcall func (princ-to-string i)))
  (call-next-method))

(defmethod js-for-in ((obj argobj) func &optional shallow)
  (declare (ignore shallow))
  (dotimes (i (argobj-length obj)) (funcall func (princ-to-string i)))
  (call-next-method))

(defmethod js-for-in (obj func &optional shallow)
  (declare (ignore obj func shallow)))

;; Registering prototypes for string, number, and boolean values

(defmacro declare-primitive-prototype (specializer proto-id)
  `(progn
     (defmethod static-js-prop ((obj ,specializer) cache)
       (funcall (the function (cache-op cache)) obj (find-proto ,proto-id) cache))
     (defmethod js-prop ((obj ,specializer) prop)
       (do-lookup obj (find-proto ,proto-id) 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 ((obj ,specializer) func &optional shallow)
       (js-for-in (find-proto ,proto-id) func shallow))))

;; Utilities

(defun expand-static-obj (proto props)
  (let ((cls (gensym)))
    `(let ((,cls (load-time-value (make-scls ',(loop :for off :from 0 :for (name . val) :in props :collect
                                                  (list* (intern-prop name) off
                                                         (if (and (consp val) (eq (car val) :active))
                                                             +slot-active+ +slot-dflt+)))
                                             ,proto))))
       (make-obj ,cls (vector ,@(loop :for (nil . val) :in props :collect
                                   (if (and (consp val) (eq (car val) :active))
                                       `(cons ,(second val) ,(third val))
                                       val)))))))

(defun js-new (func &rest args)
  (unless (fobj-p func)
    (js-error :type-error "~a is not a constructor." (to-string func)))
  (let* ((cls (ensure-fobj-cls func))
         (this (if (cfobj-p func) (funcall (cfobj-make-new func) cls) (make-obj cls)))
         (result (apply (the function (proc func)) this args)))
    (if (obj-p result) result this)))

(defun ensure-fobj-cls (fobj)
  (let ((proto (js-prop fobj "prototype"))) ;; Active property in function prototype ensures this is always bound
    (unless (obj-p proto)
      (setf proto (js-obj))
      (setf (js-prop proto "constructor") fobj))
    (unless (and (fobj-new-cls fobj) (eq (cls-prototype (fobj-new-cls fobj)) proto))
      (setf (fobj-new-cls fobj) (make-scls () proto)))
    (fobj-new-cls fobj)))

(defun find-slot (obj prop)
  (find-slot* obj (intern-prop prop)))

(defun find-slot* (obj prop)
  (let ((vals (obj-vals obj)))
    (if (hash-table-p vals)
        (gethash prop vals)
        (lookup-slot (obj-cls obj) prop))))

(defun delete-prop (obj prop)
  (if (obj-p obj)
      (let ((slot (find-slot obj prop)))
        (cond ((not slot) t)
              ((logtest (cdr slot) +slot-nodel+) nil)
              (t (cond ((not (hash-table-p (obj-vals obj)))
                        (hash-obj obj (make-hcls (cls-prototype (obj-cls obj))))) ;; TODO reuse?
                       ((eq obj *env*) ;; Global slots can be cached, so we have to flag them as deleted
                        (setf (car slot) :deleted (cdr slot) +slot-active+)))
                 (remhash (intern-prop prop) (obj-vals obj)))))
      t))