;;; A Common Lisp-like DEFSTRUCT facility for Scheme. (define-syntax (def-struct struct-name . specs&methods) (receive (slots methods) (let* ((meths&specs (reverse specs&methods)) (maybe-meths (car meths&specs))) (if (and (pair? maybe-meths) (pair? (car maybe-meths))) (return (reverse! (cdr meths&specs)) maybe-meths) (return specs&methods '#f))) (let* ((stype-name (concatenate-symbol struct-name '-stype)) (slot-names (for (s in slots) (save (if (symbol? s) s (car s))))) (slotac-names (for (s in slot-names) (save (concatenate-symbol struct-name ': s)))) (master-name (concatenate-symbol struct-name '-master)) (maker-name (concatenate-symbol 'make- struct-name)) (newer-name (concatenate-symbol struct-name ':new)) (predicate-name (concatenate-symbol struct-name '?)) (handler-name (concatenate-symbol struct-name '-handler)) (handler-form `(object nil ,@methods ((print self port) ;; Normal default is PRINT-STRUCTURE (print-defstruct self port)) (((*value t-implementation-env 'hash) self) (hash-def-struct self))))) `(block ;define the structure type, and place in the var structname-STYPE (define ,stype-name (make-stype ',struct-name ',slot-names ,handler-form)) ;assign the slot accessors to structname:slot variables ,@@(loop (for slot in slot-names) (for slot-accessor in slotac-names) (incr i from 2 by 4) (save `(define-constant ,slot-accessor (make-structure-accessor ,stype-name ,i ',slot)))) ;assign the niladic structure maker to MAKE-structname (define ,maker-name (stype-constructor ,stype-name)) ;assign the structure maker to the variable structname:NEW ,@(%def-struct-create-NEW-macros struct-name newer-name maker-name) ;assign the type predicate to the variable structname? (define ,predicate-name (stype-predicator ,stype-name)) ;assign the handler to the variable structname-HANDLER (define ,handler-name (stype-handler ,stype-name)) ;assign the master to the variable structname-MASTER (define ,master-name (stype-master ,stype-name)) ;intialise all the slots in the master ,@(for (slot in slots) (slotaccessor in slotac-names) (when (pair? slot)) (save `(set (,slotaccessor ,master-name) ,(cadr slot)))) ,stype-name ))))