Sun Jul 13 13:26:38 UTC 2008  mantoniotti
  * Clenaing up.
  Clenaing up.
  Committing in .
  
  Removed Files:
   	templates-hierarchy-saved.lisp
  
diff -rN -u old-cl-unification-1/templates-hierarchy-saved.lisp new-cl-unification-1/templates-hierarchy-saved.lisp
--- old-cl-unification-1/templates-hierarchy-saved.lisp	2013-07-21 11:37:22.000000000 +0000
+++ new-cl-unification-1/templates-hierarchy-saved.lisp	1970-01-01 00:00:00.000000000 +0000
@@ -1,458 +0,0 @@
-;;; -*- Mode: Lisp -*-
-
-(in-package "CL.EXT.DACF.UNIFICATION") ; DACF = Data And Control Flow.
-
-;;; Templates.
-;;; Essentially we extend the type specifier language.
-;;; The interesting thing is that we need to specify how a "match"
-;;; between a template and a CL object is performed.
-
-;;; A template is one of the following
-;;;
-;;;    <template> ::= <logical variable>
-;;;               |   <structure template>
-;;;               |   <instance template>
-;;;               |   <destructuring template>
-;;;               |   <vector template>
-;;;               |   <sequence template>
-;;;               |   <array template>
-;;;               |   <type template>
-;;;               |   <lisp object>
-;;;
-
-;;; Destructuring Template Lambda List (as per standard CL terminology)
-;;;
-;;;     <destructuring template lambda list> ::= <a "destructuring LL" with <template> in lieu of <var>>
-
-;;; Templates for Structures and Instances
-;;;
-;;;	<structure template> ::= (<class designator> <structure-slot-spec>*)
-;;;
-;;;     <instance template>  ::= (<class designator> <slot-spec>*)
-;;;
-;;; where
-;;;
-;;;     <structure-slot-spec> ::= (<reader-name> <template>)
-;;;     <instance-slot-spec>  ::= (slot-access <accessor-name> <template>)
-;;;                           |   (slot-value <slot-name> <template>)
-
-;;; Template for Sequences
-;;;
-;;;     <sequence template>    ::= (<container type> . <destructuring template lambda list>)
-;;;                            |   (subseq <from> <to> . <destructuring template lambda list>)
-;;;     <container type>       ::= list | cons | vector | array
-
-;;; Templates for Vectors and Arrays.
-;;;
-;;;     <vector template> ::= (vector . <destructuring template lambda list>)
-;;;
-;;;     <array template>  ::= (array <shape template>)
-;;;                       |   (aref <index template> <template>)
-;;;     <shape template>  ::= (<destructuring template lambda list>)
-;;;                       |   <sequence template>
-;;;                       |   (<shape template>)
-
-;;; Templates for LIST and CONS
-;;;     <list template>   ::= (list <destructuring template lambda list>)
-;;;     <cons template>   ::= (cons <template> <template>)
-
-;;; A regular list or cons acts as a list or cons template.
-
-(define-condition unification-template-error (simple-error)
-  ())
-
-;;; Templates are introduced by the reader macro #T(...)
-
-(defclass template ()
-  ((spec :accessor template-spec :type (or symbol cons) :initarg :spec))
-  (:default-initargs :spec nil))
-
-(defgeneric template-p (x)
-  (:method ((x template)) t)
-  (:method ((x t)) nil))
-
-
-(defclass type-template (template) ())
-
-(defgeneric type-template-p (x)
-  (:method ((x type-template)) t)
-  (:method ((x t)) nil))
-
-
-(defgeneric type-template-type-spec (x)
-  (:method ((x type-template))
-   (let ((spec (template-spec x)))
-     (if spec
-         (first spec)
-         'null))))
-
-
-
-(defclass nil-template (type-template) ()) ; This is the point where we break the type hierarchy.
-
-(defgeneric nil-template-p (x)
-  (:method ((x nil-template)) t)
-  (:method ((x t)) nil))
-
-
-(defclass expression-template (template) ())
-
-(defgeneric expression-template-p (x)
-  (:method ((x expression-template)) t)
-  (:method ((x t)) nil))
-
-
-(defmethod print-object ((template template) (stream stream))
-  (format stream "#T~S" (template-spec template)))
-
-
-(defclass sequence-template (type-template) ())
-
-(defgeneric sequence-template-p (x)
-  (:method ((x sequence-template)) t)
-  (:method ((x t)) nil))
-
-
-(defclass list-template (sequence-template) ())
-
-(defgeneric list-template-p (x)
-  (:method ((x list-template)) t)
-  (:method ((x t)) nil))
-
-(defclass array-template (type-template) ())
-
-(defgeneric array-template-p (x)
-  (:method ((x array-template)) t)
-  (:method ((x t)) nil))
-
-
-(defclass vector-template (sequence-template array-template) ())
-
-(defgeneric vector-template-p (x)
-  (:method ((x vector-template)) t)
-  (:method ((x t)) nil))
-
-
-(defclass string-template (vector-template) ())
-
-(defgeneric string-template-p (x)
-  (:method ((x string-template)) t)
-  (:method ((x t)) nil))
-
-
-
-
-(defclass symbol-template (type-template) ())
-
-(defgeneric symbol-template-p (x)
-  (:method ((x symbol-template)) t)
-  (:method ((x t)) nil))
-
-
-(defclass number-template (type-template) ())
-
-(defgeneric number-template-p (x)
-  (:method ((x number-template)) t)
-  (:method ((x t)) nil))
-
-
-(defclass structure-object-template (type-template) ())
-
-(defgeneric structure-object-template-p (x)
-  (:method ((x structure-object-template)) t)
-  (:method ((x t)) nil))
-
-
-(defclass standard-object-template (type-template) ())
-
-(defgeneric standard-object-template-p (x)
-  (:method ((x standard-object-template)) t)
-  (:method ((x t)) nil))
-
-
-;;; Expression Templates.
-
-(defclass subseq-template (expression-template) ())
-
-(defgeneric subseq-template-p (x)
-  (:method ((x subseq-template)) t)
-  (:method ((x t)) nil))
-
-
-(defclass elt-template (expression-template) ())
-
-(defgeneric elt-template-p (x)
-  (:method ((x elt-template)) t)
-  (:method ((x t)) nil))
-
-
-(defclass aref-template (elt-template) ())
-
-(defgeneric aref-template-p (x)
-  (:method ((x aref-template)) t)
-  (:method ((x t)) nil))
-
-
-(defclass nth-template (elt-template) ())
-
-(defgeneric nth-template-p (x)
-  (:method ((x nth-template)) t)
-  (:method ((x t)) nil))
-
-
-(defclass nthcdr-template (elt-template) ())
-
-(defgeneric nthcdr-template-p (x)
-  (:method ((x nthcdr-template)) t)
-  (:method ((x t)) nil))
-
-
-(defgeneric make-template (kind spec))
-
-;;; Setting up the reader macro.
-
-(defun |#T-reader| (stream subchar arg)
-  (declare (ignore subchar arg))
-  (let ((spec (read stream t nil t)))
-    (typecase spec
-      (null (make-template nil spec))
-      (cons (make-template (first spec) spec))
-      (t    (make-template spec spec)))))
-
-
-(eval-when (:load-toplevel :execute)
-  (set-dispatch-macro-character #\# #\T #'|#T-reader|))
-
-(defmethod make-template ((kind null) (spec symbol))
-  (assert (null spec) (spec) "MAKE-TEMPLATE called erroneously with ~S and ~S." kind spec)
-  (make-instance 'nil-template :spec spec))
-
-(defmethod make-template ((kind symbol) (spec symbol))
-  (make-instance 'symbol-template :spec spec))
-
-(defmethod make-template ((kind (eql 'symbol)) (spec cons))
-  (make-instance 'symbol-template :spec spec))
-
-(defmethod make-template ((kind symbol) (spec cons))
-  (cond ((subtypep kind 'number)
-         (make-instance 'number-template :spec spec))
-        ((subtypep kind 'structure-object)
-         (make-instance 'structure-object-template :spec spec))
-        ((subtypep kind 'standard-object)
-         (make-instance 'standard-object-template :spec spec))
-        (t
-         (error 'unification-template-error
-                :format-control "Unknown template specifier ~S."
-                :format-arguments (list kind)))
-        ))
-
-(defmethod make-template ((kind cons) (spec cons))
-  (cond ((subtypep kind 'number)
-         (make-instance 'number-template :spec spec))
-        ((subtypep kind 'string)
-         (make-instance 'string-template :spec spec))
-        ((subtypep kind 'vector)
-         (make-instance 'vector-template :spec spec))
-        ((subtypep kind 'array)
-         (make-instance 'array-template :spec spec))
-        (t
-         (error 'unification-template-error
-                :format-control "Unknown template specifier ~S."
-                :format-arguments (list kind)))
-        ))
-
-(defmethod make-template ((kind (eql 'sequence)) (spec cons))
-  (make-instance 'sequence-template :spec spec))
-
-(defmethod make-template ((kind (eql 'list)) (spec cons))
-  (make-instance 'list-template :spec spec))
-
-(defmethod make-template ((kind (eql 'vector)) (spec cons))
-  (make-instance 'vector-template :spec spec))
-
-(defmethod make-template ((kind (eql 'string)) (spec cons))
-  (make-instance 'stringvector-template :spec spec))
-
-(defmethod make-template ((kind (eql 'array)) (spec cons))
-  (make-instance 'array-template :spec spec))
-
-
-(defmethod make-template ((kind (eql 'subseq)) (spec cons))
-  (make-instance 'subseq-template :spec spec))
-
-(defmethod make-template ((kind (eql 'elt)) (spec cons))
-  (make-instance 'elt-template :spec spec))
-
-(defmethod make-template ((kind (eql 'aref)) (spec cons))
-  (make-instance 'aref-template :spec spec))
-
-(defmethod make-template ((kind (eql 'nth)) (spec cons))
-  (make-instance 'nth-template :spec spec))
-
-(defmethod make-template ((kind (eql 'nthcdr)) (spec cons))
-  (make-instance 'nthcdr-template :spec spec))
-
-
-
-
-;;; Implementation.
-
-;;; Symbol Templates.
-;;; Specification is
-;;;
-;;;    (symbol <symbol>)
-
-(defun symbol-template-symbol (x)
-  (declare (type symbol-template x))
-  (assert (symbol-template-p x) (x) "Non symbol template ~S." x)
-  (let ((spec (template-spec x)))
-    (cond ((symbolp spec) spec)
-          ((consp spec) (second spec)))))
-
-
-;;; Number template
-;;; Specification is
-;;;
-;;;	(<number type> <number>)
-;;; or
-;;;
-;;;	<number>
-
-(defun number-template-number (x)
-  (declare (type number-template x))
-  (assert (number-template-p x) (x) "Non number template ~S." x)
-  (let ((spec (template-spec x)))
-    (etypecase spec
-      (symbol spec)
-      (number spec)
-      (consp (second spec)))))
-
-
-;;; Sequence Templates.
-;;; Specification is
-;;;
-;;;	(<sequence subtype> . <destructuring template lambda list>)
-;;; or
-;;;     (subseq <from> <to> . <destructuring template lambda list>)
-
-(defun sequence-template-lambda-list (x)
-  (declare (type sequence-template x))
-  (assert (sequence-template-p x) (x) "Non sequence template ~S." x)
-  (rest (template-spec x)))
-
-
-;;; Array Templates.
-;;; Specification is
-;;;
-;;;	(array (['*' | <element type>] [<dimension spec>])  <shape template>)
-;;; or
-;;;	(<array type specifier> <shape template>)
-
-
-(defun array-template-shape-template (x)
-  (declare (type array-template x))
-  (assert (array-template-p x) (x) "Non array template ~S." x)
-  (let ((spec (template-spec x)))
-    (third spec)))
-
-
-(defun array-template-type-template (x)
-  (declare (type array-template x))
-  (assert (array-template-p x) (x) "Non array template ~S." x)
-  (let ((spec (template-spec x)))
-    (second spec)))
-
-
-(defun aref-template-indexes (x)
-  (declare (type aref-template x))
-  (assert (aref-template-p x) (x) "Non aref template ~S." x)
-  (let ((spec (template-spec x)))
-    (second spec)))
-
-
-(defun aref-template-element (x)
-  (declare (type aref-template x))
-  (assert (aref-template-p x) (x) "Non array template ~S." x)
-  (let ((spec (template-spec x)))
-    (third spec)))
-
-
-;;; Vector Templates.
-;;; Specification is
-;;;
-;;;	(vector . <destructuring template lambda list>)
-
-;;; Structure and Standard Object Templates.
-
-(defun structure-object-template-slots (x)
-  (and (structure-object-template-p x)
-       (rest (template-spec x))))
-
-
-(defun standard-object-template-slots (x)
-  (and (standard-object-template-p x)
-       (rest (template-spec x))))
-
-
-;;;===========================================================================
-;;; Template variables.
-;;; Let's walk down a template.
-;;; Note that there is an asymmetry here: I admit some containers to have
-;;; variables inside, but I do not search instances of a class for variables.
-;;; This is an asymmetry that would be way too hard to fix without more
-;;; introspective power (which is available in the MOP, but not standard.)
-
-(defgeneric collect-template-vars (template))
-
-(defmethod collect-template-vars ((template template))
-  (let ((spec (template-spec template)))
-    (nconc (collect-template-vars (car spec))
-           (collect-template-vars (cdr spec)))))
-
-(defmethod collect-template-vars ((template symbol-template))
-  (let ((template (symbol-template-symbol template)))
-    (when (and (variablep template) (not (variable-any-p template)))
-      (list template))))
-
-
-(defmethod collect-template-vars ((template number-template))
-  (let ((template (number-template-number template)))
-    (etypecase template
-      (number ())
-      (symbol (cond ((variablep template) template)
-                    ((and (boundp template)
-                          (numberp (symbol-value template)))
-                     (symbol-value template))
-                    (t
-                     (error "Invalid number template ~S." template)))))))
-
-
-(defmethod collect-template-vars ((template symbol))
-  (when (and (variablep template) (not (variable-any-p template)))
-    (list template)))
-
-(defmethod collect-template-vars ((template null))
-  ())
-
-(defmethod collect-template-vars ((template cons))
-  (nconc (collect-template-vars (car template))
-         (collect-template-vars (cdr template))))
-
-(defmethod collect-template-vars ((template string))
-  ())
-
-
-(defmethod collect-template-vars ((template vector))
-  (loop for e across template
-        nconc (collect-template-vars e)))
-
-
-(defmethod collect-template-vars ((template array))
-  (loop for i below (array-total-size template)
-        nconc (collect-template-vars (row-major-aref template i))))
-
-
-(defmethod collect-template-vars ((template t))
-  ())
-
-;;; end of file -- templates.lisp --