darcs - cl-unification

repos / cl-unification / annotate_shade

summary | shortlog | log | tree | commit | commitdiff | headdiff | annotate | headblob | headfilediff | filehistory
normal | plain | shade | zebra

Rather than a new UNIFY** function, make UNIFY* work that way

Annotate for file match-block.lisp

2007-11-09  mantoniotti  ;;;; -*- Mode: Lisp -*-
13:43:20              '  
                      '  ;;;; match-block.lisp --
                      '  ;;;; Various macros built on top of the unifier: MATCH, MATCHING and MATCH-CASE.
2004-11-17  mantoniotti  
22:19:54              '  (in-package "UNIFY")
                      '  
                      '  (defun clean-unify-var-name (v)
                      '    (assert (variablep v))
                      '    (intern (subseq (symbol-name v) 1)
                      '            (symbol-package v)))
                      '  
2010-02-04          pix  (defun %template-for-match (template)
07:32:18              '    (if (variablep template)
                      '        `',template ; Logical variables are special-cased.
                      '        template))
2004-11-17  mantoniotti  
2010-02-04          pix  (defun %wrap-var-bindings (template environment-var forms)
07:32:18              '    (let* ((template-vars (collect-template-vars template))
                      '           (bindings (loop for v in template-vars
                      '                           nconc (list `(,v (find-variable-value ',v
                      '                                                                 ,environment-var))
                      '                                       `(,(clean-unify-var-name v) ,v)))))
                      '      `(let* ,bindings
                      '         (declare (ignorable ,@(mapcar #'first bindings)))
                      '         ,@forms)))
2010-01-12          pix  
2004-11-17  mantoniotti  (defmacro match ((template object
22:19:54              '                             &key
2010-02-04          pix                             (match-named nil)
07:32:18              '                             (substitution '(make-empty-environment))
2004-11-17  mantoniotti                             (errorp t)
22:19:54              '                             (error-value nil))
                      '                   &body forms)
2010-02-05          pix    "Sets up a lexical environment to evaluate FORMS after an unification.
03:21:40              '  
                      '  MATCH unifies a TEMPLATE and an OBJECT and then sets up a lexical
                      '  environment where the variables present in the template are bound
                      '  lexically.  Note that both variable names '?FOO' and 'FOO' are bound
                      '  for convenience.
                      '  
                      '  The MATCH form returns the values returned by the evaluation of the
                      '  last of the FORMS.
                      '  
                      '  If ERRORP is non-NIL (the default) then the form raises a
                      '  UNIFICATION-FAILURE, otherwise the result of evaluating ERROR-VALUE,
                      '  whose default is NIL is returned. (Note that UNIFICATION-FAILUREs
                      '  raising from the evaluation of FORMS will also be caught and handled
                      '  according to ERRORP settings.)
                      '  
                      '  If MATCH-NAMED is not NIL, then a surrounding BLOCK named MATCH-NAMED
                      '  is set up around the matching code.
                      '  "
2010-02-04          pix    (let ((env-var (gensym "UNIFICATION-ENV-"))
07:32:18              '          (template (%template-for-match template))
                      '          )
                      '      `(block ,match-named
                      '         (handler-case
                      '             (let* ((,env-var (unify ,template ,object ,substitution))
                      '                    )
                      '               ,(%wrap-var-bindings template env-var forms))
                      '  
                      '           ;; Yes.  The above is sligthly wasteful.
                      '  
                      '           (unification-failure (uf)
                      '             (if ,errorp
                      '                 (error uf)
                      '                 ,error-value))
                      '           ))))
                      '  
2009-04-15  mantoniotti  
10:16:24              '  (defmacro matchf ((template object
                      '                              &key
2010-02-04          pix                              (match-named nil)
07:32:18              '                              (substitution '(make-empty-environment))
2009-04-15  mantoniotti                              (errorp t)
10:16:24              '                              (error-value nil))
                      '                    &body forms)
2010-02-05          pix    "Sets up a lexical environment to evaluate FORMS after an unification.
2009-04-15  mantoniotti  
2010-02-05          pix  MATCHF unifies a TEMPLATE and an OBJECT and then sets up a lexical
2009-04-15  mantoniotti  environment where the variables present in the template are bound
10:16:24              '  lexically.  Note that both variable names '?FOO' and 'FOO' are bound
                      '  for convenience.
                      '  
                      '  MATCHF does not 'evaluate' TEMPLATE (note that using the #T syntax will
                      '  generate a template at read-time).
                      '  
2010-02-05          pix  The MATCHF form returns the values returned by the evaluation of the
2009-04-15  mantoniotti  last of the FORMS.
10:16:24              '  
                      '  If ERRORP is non-NIL (the default) then the form raises a
                      '  UNIFICATION-FAILURE, otherwise the result of evaluating ERROR-VALUE,
                      '  whose default is NIL is returned. (Note that UNIFICATION-FAILUREs
2010-02-05          pix  raising from the evaluation of FORMS will also be caught and handled
2009-04-15  mantoniotti  according to ERRORP settings.)
10:16:24              '  
2010-02-05          pix  If MATCH-NAMED is not NIL, then a surrounding BLOCK named MATCH-NAMED
03:21:40              '  is set up around the matching code.
                      '  "
2010-02-04          pix    (let ((env-var (gensym "UNIFICATION-ENV-"))
07:32:18              '          (template (cond ((variablep template)
                      '                           `',template) ; Logical variables are special-cased.
                      '                          ((listp template) ; Same for lists.
                      '                           (make-instance 'list-template
                      '                                          :spec (cons 'list template)))
                      '                          ;`',template)
                      '                          (t
                      '                           template)))
                      '          )
                      '      ;; Logical variables and lists are special cased for convenience.
                      '      ;; Lists are especially inteded as abbreviation for destructuring.
                      '      `(block ,match-named
                      '         (handler-case
                      '             (let* ((,env-var (unify ,template ,object ,substitution))
                      '                    )
                      '               ,(%wrap-var-bindings template env-var forms))
                      '  
                      '           ;; Yes.  The above is sligthly wasteful.
                      '  
                      '           (unification-failure (uf)
                      '             (if ,errorp
                      '                 (error uf)
                      '                 ,error-value))
                      '           ))))
2004-11-17  mantoniotti  
22:19:54              '  
                      '  
                      '  (define-condition unification-non-exhaustive (unification-failure)
2010-02-04          pix    ())
2004-11-17  mantoniotti  
22:19:54              '  
                      '  (defmacro matching ((&key errorp
2010-02-04          pix                            (default-substitution
07:32:18              '                             (make-empty-environment))
                      '                            (matching-named nil))
2010-01-15          pix                      &body match-clauses)
2010-02-05          pix    "MATCHING sets up a COND-like environment for multiple template matching clauses.
03:21:40              '  
                      '  The syntax of MATCHING comprises a number of clauses of the form
                      '  
                      '    <clause> ::= <regular-clause> | <default-clause>
                      '    <regular-clause> ::= ((<template> <form>) &body <forms>)
                      '    <default-clause> ::= (t &body <forms>)
                      '                     |   (otherwise &body <forms>)
                      '  <form> and <forms> are regular Common Lisp forms.
                      '  <template> is a unification template.
                      '  
                      '  The full syntax of MATCHING is
                      '  
                      '    matching (&key errorp default-substitution) <clauses>
                      '  
                      '  Each clause evaluates its forms in an environment where the variables
                      '  present in the template are bound lexically.  Note that both variable
                      '  names '?FOO' and 'FOO' are bound for convenience.
                      '  
                      '  The values returned by the MATCHING form are those of the last form in
                      '  the first clause that satisfies the match test.
                      '  
                      '  If ERRORP is non-NIL then if none of the regular clauses matches, then
                      '  an error of type UNIFICATION-NON-EXAUSTIVE is signalled, regardless of
                      '  any default clause.  Otherwise, the default clause behaves as a
                      '  standard COND default clause.  The default value of ERRORP is NIL.
                      '  "
2010-02-04          pix    (declare (ignore default-substitution)) ; For the time being.
07:32:18              '    (labels ((%%match%% (clause-var template object forms substitution)
                      '               (let ((template (%template-for-match template))
                      '                     )
                      '                 `((setf ,clause-var
2010-01-21          pix                         (unify* ,template ,object ,substitution))
2010-02-04          pix                   ,(%wrap-var-bindings template clause-var forms))
07:32:18              '                 ))
                      '  
                      '             (build-match-clause (match-clause match-env-var)
                      '               (destructuring-bind ((template object) &body forms)
                      '                   match-clause
                      '                 (%%match%% match-env-var
                      '                            template
                      '                            object
                      '                            forms
                      '                            '(make-empty-environment))))
                      '             )
                      '      (when (or (and (find t match-clauses :key #'first)
                      '                     (find 'otherwise match-clauses :key #'first))
                      '                (> (count t match-clauses :key #'first) 1)
                      '                (> (count 'otherwise match-clauses :key #'first) 1))
                      '        (error 'program-error))
                      '      (let* ((default-clause (or (find t match-clauses
                      '                                       :key #'first)
                      '                                 (find 'otherwise match-clauses
                      '                                       :key #'first)))
                      '             (match-clauses (delete default-clause match-clauses)) ; EQL
                      '                                                                   ; test
                      '                                                                   ; suffices.
                      '             (env-var (gensym "UNIFICATION-ENV-"))
                      '             )
2004-11-17  mantoniotti  
2010-02-04          pix        `(block ,matching-named
07:32:18              '           (let (,env-var)
                      '             (declare (dynamic-extent ,env-var))
                      '             (cond ,@(mapcar (lambda (match-clause)
                      '                               (build-match-clause match-clause
                      '                                                   env-var))
                      '                             match-clauses)
                      '                   (,errorp
                      '                    (error 'unification-non-exhaustive
                      '                           :format-control "Non exhaustive matching."))
2010-01-25          pix                   ,(when default-clause (cons t (cdr default-clause)))))))
2010-02-04          pix      ))
07:32:18              '  
                      '  
                      '  (defmacro match-case ((object &key errorp default-substitution match-case-named)
2010-02-05          pix                        &body clauses)
03:21:40              '    "MATCH-CASE sets up a CASE-like environment for multiple template matching clauses.
                      '  
                      '  The syntax of MATCH-CASE comprises a number of clauses of the form
2005-04-27  mantoniotti  
20:41:56              '    <clause> ::= <regular-clause> | <default-clause>
2010-02-05          pix    <regular-clause> ::= (<template> &body <forms>)
2005-04-27  mantoniotti    <default-clause> ::= (t &body <forms>)
20:41:56              '                     |   (otherwise &body <forms>)
                      '  <form> and <forms> are regular Common Lisp forms.
                      '  <template> is a unification template.
                      '  
2010-02-05          pix  The full syntax of MATCH-CASE is
03:21:40              '  
                      '    match-case <object> (&key errorp default-substitution) <clauses>
2005-04-27  mantoniotti  
20:41:56              '  Each clause evaluates its forms in an environment where the variables
                      '  present in the template are bound lexically.  Note that both variable
                      '  names '?FOO' and 'FOO' are bound for convenience.
                      '  
2010-02-05          pix  The values returned by the MATCH-CASE form are those of the last form in
2005-04-27  mantoniotti  the first clause that satisfies the match test.
20:41:56              '  
                      '  If ERRORP is non-NIL then if none of the regular clauses matches, then
                      '  an error of type UNIFICATION-NON-EXAUSTIVE is signalled, regardless of
                      '  any default clause.  Otherwise, the default clause behaves as a
2010-02-05          pix  standard CASE default clause.  The default value of ERRORP is NIL.
03:21:40              '  "
2010-02-04          pix    (let ((object-var (gensym "OBJECT-VAR-")))
07:32:18              '      `(let ((,object-var ,object))
                      '         (matching (:errorp ,errorp :default-substitution ,default-substitution :matching-named ,match-case-named)
                      '           ,@(mapcar
                      '              (lambda (clause)
                      '                `(,(if (member (first clause) '(t otherwise))
                      '                       (first clause)
                      '                       (list (first clause) object-var))
                      '                   ,@(rest clause)))
                      '              clauses)))))
2005-04-27  mantoniotti  
2009-12-17  mantoniotti  
2010-02-04          pix  (defmacro matchf-case ((object &key errorp default-substitution match-case-named)
07:32:18              '                        &body clauses)
2010-02-05          pix    "MATCHF-CASE sets up a CASE-like environment for multiple template matching clauses.
03:21:40              '  
                      '  The syntax of MATCHF-CASE comprises a number of clauses of the form
                      '  
                      '    <clause> ::= <regular-clause> | <default-clause>
                      '    <regular-clause> ::= (<template> &body <forms>)
                      '    <default-clause> ::= (t &body <forms>)
                      '                     |   (otherwise &body <forms>)
                      '  <form> and <forms> are regular Common Lisp forms.
                      '  <template> is a unification template.
                      '  
                      '  The full syntax of MATCHF-CASE is
                      '  
                      '    matchf-case <object> (&key errorp default-substitution) <clauses>
                      '  
                      '  Each clause evaluates its forms in an environment where the variables
                      '  present in the template are bound lexically.  Note that both variable
                      '  names '?FOO' and 'FOO' are bound for convenience.
                      '  
                      '  The values returned by the MATCH-CASE form are those of the last form in
                      '  the first clause that satisfies the match test.
                      '  
                      '  If ERRORP is non-NIL then if none of the regular clauses matches, then
                      '  an error of type UNIFICATION-NON-EXAUSTIVE is signalled, regardless of
                      '  any default clause.  Otherwise, the default clause behaves as a
                      '  standard CASE default clause.  The default value of ERRORP is NIL.
                      '  
                      '  MATCHF-CASE behaves like MATCH-CASE, but the patterns are not
                      '  evaluated (i.e., it relies on MATCHF instead of MATCH to construct the
                      '  macro expansion.
                      '  "
2010-02-04          pix    (declare (ignore default-substitution)) ; For the time being.
07:32:18              '    (let* ((object-var (gensym "OBJECT-VAR-"))
                      '           (otherwise-clause-present-p
                      '            (member (caar (last clauses)) '(t otherwise)))
                      '           (non-otherwise-clauses
                      '            (if otherwise-clause-present-p
                      '                (butlast clauses)
                      '                clauses))
                      '           (otherwise-clause
                      '            (if otherwise-clause-present-p
                      '                (first (last clauses))
                      '                (when errorp
                      '                  `(t (error 'unification-non-exhaustive
                      '                             :format-control "Non exhaustive matching.")))))
                      '           )
                      '      (labels ((generate-matchers (clauses)
                      '                 (if (null clauses)
                      '                     `(progn ,@(rest otherwise-clause))
                      '                     (destructuring-bind (pattern &rest body)
                      '                         (car clauses)
                      '                       `(handler-case (matchf (,pattern ,object-var)
                      '                                        ,@body)
                      '                          (unification-failure ()
                      '                            ,(generate-matchers (cdr clauses))))))))
                      '        `(block ,match-case-named
                      '           (let ((,object-var ,object))
                      '             ,(generate-matchers non-otherwise-clauses))))))
2009-12-17  mantoniotti  
2007-11-09  mantoniotti  ;;;;---------------------------------------------------------------------------
13:43:20              '  ;;;; Testing.
                      '  
                      '  #| Tests
                      '  
                      '  (let ((n 42))
                      '    (matching ()
                      '              ((0 n) 1)
                      '              ((?x n) (* x (1- x)))))
                      '  
                      '  
                      '  (let ((n 42))
                      '    (match-case (n)
                      '                (0 1)
                      '                (?x (* x (1- x)))))
                      '  
                      '  
                      '  (let ((n 42))
                      '    (match-case (n)
                      '                (0 1)
                      '                (otherwise (* n (1- n)))))
                      '  
                      '  (defun fatt (x)
                      '    (match-case (x :errorp t)
                      '                (0 1)
                      '                (#T(number ?n) (* ?n (fatt (1- n))))
                      '                ))
                      '  
                      '  |#
2005-04-27  mantoniotti  
2007-11-09  mantoniotti  ;;;; end of file -- math-blocks.lisp --

There once was a man from Nantucket…

RSS