defstruct-for-ps-fixed.lisp

(defmacro defstruct.ps (name-and-options &rest slot-description)
  "This is the tiny subset of defsturt in terms of syntax.
    name-and-options::= structure-name | (structure-name (:include included-structure-name {inherit-slot-description}*))
    slot-description::= slot-name | (slot-name slot-init-form)"
  (bind:bind (((:values name parent-info)
               (parse-defstruct-name-and-options name-and-options))
              (parent (car parent-info))
              (slots
               (parse-defstruct-slot-description slot-description)))
    (setf slots (merge-defstruct-slots parent-info slots))
    `(eval-when (:compile-toplevel :load-toplevel :execute)
       (register-defstruct-slots ',name ',slots)
       ;; JavaScriptにおけるクラス定義
       (defun.ps ,name ()
         ,@(mapcar (lambda (slot)
                     `(setf (@ this ,(car slot)) ,(cadr slot)))
                   slots)
         this)
       ;; 構造体を作成するmake-xxx関数の定義
       (defun.ps ,(symbolicate 'make- name) (&key ,@slots)
         (let ((result (new (,name))))
           ,@(mapcar (lambda (elem)
                       `(setf (@ result ,(car elem)) ,(car elem)))
                     slots)
           result))
       ;; アクセサの定義
       ,@(mapcar (lambda (slot)
                   `(defmacro.ps ,(symbolicate name '- (car slot)) (obj)
                      `(@ ,obj ,',(car slot))))
                 slots)
       ;; 型判別用のxxx-p関数の定義
       (defun.ps ,(symbolicate name '-p) (obj)
         (instanceof obj ,name))
       ;; JavaScriptにおける継承関係の設定
       ,(when parent
              `(def-top-level-form.ps ,(symbolicate '_defstruct-inherit_ name)
                 (funcall (lambda ()
                            (labels ((temp-ctor ()))
                              (setf (@ temp-ctor prototype) (@ ,parent prototype))
                              (setf (@ ,name super-class_) (@ ,parent prototype))
                              (setf (@ ,name prototype) (new (temp-ctor)))
                              (setf (@ ,name prototype constructor) ,name)))))))))