Handling deftemplates in MPS

There are three parts to my MPS (Minimal Production System) experiment, the "engine" itself and the deftemplate and defrule macros. So far, I've spent most of my time on the deftemplate macro. It turned out to be a bit trickier than I thought to implement. Mostly because I was stuck thinking about too complex macro expansions (which I never got to work).

Here is the syntax as BNF (well, sort of[1]):

|  deftemplate-construct
|    ::= (deftemplate deftemplate-name
|                     [comment]
|                     single-slot-definition*)
|
|  single-slot-definition
|    ::= (slot slot-name [default-attribute])
|
|  default-attribute
|    ::= (default ?NONE | expression) |
|        (default-dynamic expression)

It is a subset of CLIPS' deftemplate syntax. There are no multislots and no constraint-attributes for slots (types, ranges and such). But, apart from that, it is more or less the same[2]. And here's how it works:

|; SLIME 2007-03-14
|;;;; Compile file / [...] /mps. ...
|CL-USER> (in-package :mps)
|#[Package "MPS"]
|MPS> (deftemplate foo
|       (slot a-slot)
|       (slot a-default-slot (default 1))
|       (slot required-slot (default ?NONE)))
|FOO
|MPS> (foo)
|
|The slot: REQUIRED-SLOT in deftemplate: FOO requires an explicit value.
|   [Condition of type SIMPLE-ERROR]
|
|Restarts:
| 0: [ABORT] Return to SLIME's top level.
| 1: [ABORT-BREAK] Reset this process
| 2: [ABORT] Kill this process
|
|Invoking restart: Return to SLIME's top level.
|; Evaluation aborted
|MPS> (foo (required-slot 1))
|#S(DEFTEMPLATE/FOO :A-SLOT NIL :A-DEFAULT-SLOT 1 :REQUIRED-SLOT 1)
|MPS> (deftemplate bar
|       (slot default-gensym (default (gensym)))
|       (slot dynamic-gensym (default-dynamic (gensym))))
|BAR
|MPS> (bar)
|#S(DEFTEMPLATE/BAR :DEFAULT-GENSYM #:G31 :DYNAMIC-GENSYM #:G40)
|MPS> (bar)
|#S(DEFTEMPLATE/BAR :DEFAULT-GENSYM #:G31 :DYNAMIC-GENSYM #:G41)
|MPS>

The macro expands into a defstruct (deftemplate/foo) and another defmacro (foo) that is used as a constructor for the template. The reason it is a macro and not a regular function is because a function's arguments are evaluated whilst a macro's is not. And since there's no function named a-slot or a-default-slot etc. So we'd be thrown into the debugger if we tried to evaluate something like (foo (a-slot 1)).

Here's the macroexpansion of a simple template:

|MPS> (pprint (macroexpand-1 '(deftemplate foo
|                               (slot a)
|                               (slot b (default 1)))))
|
|(PROGN (DEFSTRUCT DEFTEMPLATE/FOO "" (A NIL) (B 1))
|       (DEFMACRO FOO (&REST SLOTS)
|         ""
|         (CALL-DEFSTRUCT-CONSTRUCTOR 'DEFTEMPLATE/FOO SLOTS)))
|; No value
|MPS>

Most of the code is spent checking that the template follows the syntax described in the BNF. The expansion itself is rather simple, almost trivial (it is the last progn below).

|(defmacro deftemplate (deftemplate-name &body body)
|  "
|  The deftemplate construct is used to create a template which can then
|  be used by non-ordered facts to access fields of the fact by name.
|
|  Examples:
|  (deftemplate object
|    (slot id (default-dynamic (gensym)))
|    (slot name (default ?NONE))           ; Makes name a required field
|    (slot age))
|  "
|
|  (macrolet ((signal-deftemplate-error (msg &rest args)
|               `(error (concatenate 'string "~&The deftemplate ~A contains at least one invalid slot-definition: ~S." ,msg)
|                       ,@args)))
|    (let ((comment "")
|          (defstruct-name (intern (concatenate 'string "DEFTEMPLATE/" (string deftemplate-name))))
|          (defstruct-slots '()))
|
|      ;; Extract the documentation string
|      (when (stringp (car body))
|        (setf comment (car body))
|        (setf body (cdr body)))
|
|      ;; Check syntax and extract slot-specifiers
|      (dolist (slot body)
|        (let* ((slot-name (cadr slot))
|               (curr-defstruct-slot `(,slot-name nil)))
|          (unless (eq (car slot) 'slot)
|            (signal-deftemplate-error "~&Expected SLOT instead of ~A."
|                                      deftemplate-name slot (car slot)))
|
|          (when (> (length slot) 2)
|            (dolist (default-attribute (cddr slot))
|              (unless (consp default-attribute)
|                (signal-deftemplate-error "~&Expected (default ?NONE|expression) or (default-dynamic expression) instead of ~A."
|                                          deftemplate-name slot default-attribute))
|              (unless (or (eq (car default-attribute) 'default)
|                          (eq (car default-attribute) 'default-dynamic))
|                (signal-deftemplate-error "~&Expected DEFAULT or DEFAULT-DYNAMIC instead of: ~A."
|                                          deftemplate-name slot (car default-attribute)))
|              (if (eq (car default-attribute) 'default)
|                  (if (eq (cadr default-attribute) '?NONE)
|                      (setf curr-defstruct-slot `(,slot-name (required ',slot-name ',deftemplate-name)))
|                      (setf curr-defstruct-slot `(,slot-name ',(eval (cadr default-attribute)))))
|                  (setf curr-defstruct-slot `(,slot-name ,(cadr default-attribute))))))
|
|          (setf defstruct-slots (append defstruct-slots (list curr-defstruct-slot)))))
|
|      `(progn
|         (defstruct ,defstruct-name
|           ,comment
|           ,@defstruct-slots)
|
|         (defmacro ,deftemplate-name (&rest slots)
|           ,comment
|           (call-defstruct-constructor ',defstruct-name slots))))))

and here are the functions used as helpers:

|(defun required (slot-name deftemplate-name)
|  (error "~&The slot: ~A in deftemplate: ~A requires an explicit value." slot-name deftemplate-name))
|
|(defun as-keyword (sym)
|  (intern (string-upcase sym) :keyword))
|
|(defun call-defstruct-constructor (defstruct-name &rest slots)
|  (let ((constructor (intern (concatenate 'string "MAKE-" (string defstruct-name)))))
|    (apply constructor (mapcan #'(lambda (slot)
|                                   `(,(as-keyword (car slot)) ,(cadr slot)))
|                               (car slots)))))

I should probably try to write a macro to abstract away all those (intern (concatenate 'string ...)) calls but otherwise, that's about it for deftemplate. Next up is getting all of the defrule construct working (which feels like a much tougher task).

[1] I hate that I still haven't found a good way of sharing code using Blogger. Tips and pointers are very welcome!

[2] The default and default-dynamic attributes in CLIPS take a variable number of expressions (at least according to the BNF found in the CLIPS Basic Programming Guide, Appendix H). I assume it assigns the value of the last as the default but I haven't tried. Anyway, if you want to evaluate several expressions in that place you're going to have to wrap it explicitly in a progn (effectively making it one expression).