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-06-19 17:10:14.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 --