Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
(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)))))))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment