defstruct-for-ps-wrong.lisp

(defpsmacro defstruct (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))
    slot-description::= slot-name | (slot-name slot-init-form)"
  (bind:bind (((:values name parent)
               (parse-defstruct-name-and-options name-and-options))
              (slots
               (parse-defstruct-slot-description slot-description)))
    (setf slots (merge-defstruct-slots parent slots))
    (register-defstruct-slots name slots)
    `(progn
       ;; JavaScriptにおけるクラス定義
       (defun ,name ()
         ,@(mapcar (lambda (slot)
                     `(setf (@ this ,(car slot)) ,(cadr slot)))
                   slots))
       ;; 構造体を作成するmake-xxx関数の定義
       (defun ,(symbolicate 'make- name) (&key ,@slots)
         (let ((result (new (,name))))
           ,@(mapcar (lambda (elem)
                       `(setf (@ result ,(car elem)) ,(car elem)))
                     slots)
           result))
       ;; アクセサの定義（ここのdefmacroが問題）
       ,@(mapcar (lambda (slot)
                   `(defmacro ,(symbolicate name '- (car slot)) (obj)
                      `(@ ,obj ,',(car slot))))
                 slots)
       ;; 型判別用のxxx-p関数の定義
       (defun ,(symbolicate name '-p) (obj)
         (instanceof obj ,name))
       ;; JavaScriptにおける継承関係の設定
       ,(when parent
              `(funcall (lambda ()
                          (defun 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)))))))