-
Notifications
You must be signed in to change notification settings - Fork 0
/
potatismos.ljsp
1 lines (1 loc) · 1.66 KB
/
potatismos.ljsp
1
(macro (a) ((lambda (obj-sym fail-sym arg-sym args-sym slots name) (subst-symbols (quote (progn <constructor> <predicate> (progn . <getters-setters>) (quote <name>))) (quote <name>) name (quote <constructor>) (subst-symbols (quote (defun <constructor-name> <args-sym> (let (<obj-sym>) (progn . <body>) (list* (quote struct) (quote <name>) <obj-sym>)))) (quote <constructor-name>) (symbol-concat (quote make-) name) (quote <name>) name (quote <args-sym>) args-sym (quote <obj-sym>) obj-sym (quote <body>) (mapcar (lambda (x) (subst-symbols (quote (let ((<arg-sym> (getf <args-sym> (quote <slot-name>) <fail-sym>))) (if (eq? <arg-sym> <fail-sym>) (setq <obj-sym> (acons (quote <slot-name>) <slot-initform> <obj-sym>)) (setq <obj-sym> (acons (quote <slot-name>) <arg-sym> <obj-sym>))))) (quote <slot-name>) (first x) (quote <slot-initform>) (second x) (quote <arg-sym>) arg-sym (quote <args-sym>) args-sym (quote <fail-sym>) fail-sym (quote <obj-sym>) obj-sym)) slots)) (quote <predicate>) (subst-symbols (quote (defun <predicate-name> (obj) (and (eq? (first obj) (quote struct)) (eq? (second obj) (quote <name>))))) (quote <predicate-name>) (symbol-concat name (quote ?)) (quote <name>) name) (quote <getters-setters>) (mapcar (lambda (x) (subst-symbols (quote (progn (defun <getter-name> (obj) (cdr (assq (quote <slot-name>) (cddr obj)))) (defun <setter-name> (obj q) (rplacd (assq (quote <slot-name>) (cddr obj)) q) q))) (quote <getter-name>) (symbol-concat name (quote -) (first x)) (quote <setter-name>) (symbol-concat name (quote -set-) (first x)) (quote <slot-name>) (first x))) slots))) (gensym) (gensym) (gensym) (gensym) (mapcar (lambda (x) (if (atom? x) (cons x nil) x)) (cddr a)) (cadr a)))