;;; *** (load (compile-file "~/Documents/delphin/checktypes-new2.lsp")) ;;; Copyright (c) 1991-2001 John Carroll, Ann Copestake, Robert Malouf, Stephan Oepen ;;; see LICENSE for conditions (in-package :lkb) ;;; Checking the type hierarchy to see if it meets ;;; the various constraints ;;; general purpose functions for creating new atoms ... (defun next (template) (let ((instance nil) (number (+ (or (get template 'last-number) 0) 1))) (setf (get template 'last-number) number) (setf instance (intern (concatenate 'string (symbol-name template) (princ-to-string number)))) (push instance (get template 'children)) (setf (get instance 'root-template) template) instance)) ;;; and destroying them (defun scratch (templates) ;;; see the function Next - scratch removes all info from the template symbols ;;; used by Next and in effect reinitialises the values. It can take a single ;;; item or a list of templates to be reinitialised. (dolist (template (if (listp templates) templates (list templates))) (remprop template 'last-number) (dolist (child (get template 'children)) (setf (symbol-plist child) nil)) ; a bit drastic - have to hope nothing ; important is kept on p-list by anyone else (remprop template 'children))) ;;; Functions to set up type hierarchy from an input file (defparameter *leaf-type-addition* nil) (defvar *type-redefinitions* nil) (defun add-type-from-file (name parents constraint default comment &optional daughters) (declare (special *tdl-context* *tdl-all-contexts*)) ;;; YADU --- extra arg needed (if *leaf-type-addition* (add-leaf-type name parents constraint default comment daughters) (let ((existing-type (get-type-entry name))) (when existing-type (format t "~%WARNING: Type `~A' redefined." name) (push name *type-redefinitions*)) (let ((new-type (make-ltype :name name :parents parents :daughters daughters :comment comment :constraint-spec constraint :default-spec default :enumerated-p (if daughters t)))) (create-mark-field new-type) (when (null parents) (when (and *toptype* (not (eq *toptype* name))) (error "Two top types ~A and ~A have been defined" *toptype* name)) (setf *toptype* name)) (set-type-entry name new-type)) (when (and *tdl-context* (string-equal name (rest (assoc :type *tdl-context*)))) ;; ;; _fix_me_ ;; what to do for annotated re-definition? maybe merge contexts? ;; (19-mar-13; oe) (push *tdl-context* *tdl-all-contexts*) (setf *tdl-context* nil))))) (defun amend-type-from-file (name parents constraint default comment) (let ((ok t) (existing-type (get-type-entry name))) (if existing-type (if (type-parents-equal parents (ltype-parents existing-type)) (progn (setf (ltype-constraint-spec existing-type) constraint) (setf (ltype-default-spec existing-type) default) (setf (ltype-comment existing-type) comment)) (progn (unless (member name *type-redefinitions*) (format t "~%Warning - ~A ignored - patch cannot change type hierarchy" name) (setf ok nil)))) (progn (setf ok nil) (format t "~%Warning - ~A ignored - patch only works to redefine types" name))) ok)) ;;; ERB (2004-08-10) Allow users to add info to a type that's ;;; already been defined. (defun add-info-to-type-from-file (name parents constraint default comment) (let ((existing-type (get-type-entry name))) (unless existing-type (cerror "Cancel load" "Cannot add information to type ~a as it is not already defined" name)) (let* ((existing-parents (ltype-parents existing-type)) (existing-constraint (ltype-constraint-spec existing-type)) (existing-default (ltype-default-spec existing-type)) (existing-comment (ltype-comment existing-type)) (redundant-parents (when (listp existing-parents) (loop for parent in parents if (member parent existing-parents) collect parent)))) (unless (null redundant-parents) (cerror "Cancel load" "Cannot add redundant parents ~a to type ~a" redundant-parents name)) (let ((new-parents (append existing-parents parents)) (new-constraint (append existing-constraint constraint)) (new-default (append existing-default default)) (new-comment (if existing-comment (concatenate 'string existing-comment " " comment) comment))) (setf (ltype-parents existing-type) new-parents) (setf (ltype-constraint-spec existing-type) new-constraint) (setf (ltype-default-spec existing-type) new-default) (setf (ltype-comment existing-type) new-comment))))) (defun type-parents-equal (new-parents old-parents) (and (null (set-difference new-parents old-parents)) (null (set-difference old-parents new-parents)))) ;;; (defvar *type-names* nil) (defvar *partitions* nil) (defparameter *hierarchy-only-p* nil) (defparameter *display-glb-messages* nil "if set, informs user of glbtypes as they are created") (defparameter *display-glb-summary* nil "if set, summary statistics are displayed about glbtype creation") (defun check-type-table nil (scratch 'glbtype) (format t "~%Checking type hierarchy") (force-output) (setq *type-names* (sort (collect-type-names) #'string-lessp)) (when (and *toptype* (add-daughters-to-type-table) (check-for-cycles-etc *toptype*)) (unmark-type-table) (set-up-ancestors-and-descendants) (format t "~%Checking for unique greatest lower bounds") (force-output) (time (let ((*partitions* nil) (nglbs 0)) (find-good-partitions *toptype*) (unmark-type-table) ;; sort partitions so behaviour reproducible if grammar has not changed (setq *partitions* (sort (remove-if #'(lambda (p) (<= (length p) 3)) *partitions*) #'> :key #'length)) (when *display-glb-summary* (format t "~%Examining ~A non-trivial type partitions" (length *partitions*))) (dolist (partition *partitions*) (incf nglbs (compute-and-add-glbtypes partition))) (if (zerop nglbs) (format t "~%No glb types needed") (format t "~%Created ~A glb types" nglbs)) (force-output))) (set-up-ancestors-and-descendants) (if *hierarchy-only-p* (expand-local-only-constraints) (progn (format t "~%Expanding constraints") (when (expand-and-inherit-constraints) (format t "~%Making constraints well formed") (when (strongly-type-constraints) (optimise-check-unif-paths) ;; YADU --- extra expansion stage ;; earlier stages are unchanged (format t "~%Expanding defaults") (when (expand-type-hierarchy-defaults) (format t "~%Type file checked successfully") (gc-types) (clear-type-cache) ; not for consistency, but for efficiency t))))))) (defun patch-type-table nil ;;; added for the case where definitions are changed, but the hierarchy ;;; itself is unaltered (clear-types-for-patching-constraints) (loop for name in *type-names* do (let* ((type-entry (get-type-entry name))) (when (leaf-type-p type-entry) (setf (leaf-type-expanded-p type-entry) nil)) (setf (ltype-constraint type-entry) nil) (setf (ltype-atomic-p type-entry) nil) (setf (ltype-tdfs type-entry) nil) (setf (ltype-appfeats type-entry) nil) (setf (ltype-constraint-mark type-entry) nil) (setf (ltype-local-constraint type-entry) nil))) (unmark-type-table) #+:allegro (when *gc-before-reload* (excl:gc t)) ;; try and force it to reclaim space before we refill it (format t "~%Expanding constraints") (when (expand-and-inherit-constraints) (format t "~%Making constraints well formed") (when (strongly-type-constraints) ;;; YADU --- extra expansion stage ;;; earlier stages are unchanged (format t "~%Expanding defaults") (when (expand-type-hierarchy-defaults) (format t "~%Re-expanding rules") (expand-rules) ; in rules.lsp (format t "~%Type file checked successfully") t)))) (defun unmark-type-table nil (maphash #'(lambda (node type-entry) (declare (ignore node)) (clear-marks type-entry)) *types*)) ;;; First we need to check that the type hierarchy itself is OK ;;; viewed as a graph without considering the constraints ;;; There are several relevant conditions: ;;; connectedness ;;; existance of top ;;; no cycles ;;; unique greatest lower bound ;;; ;;; ;;; no unary branches test is now removed ;;; ;;; we also check for redundant links - where a node is both ;;; an immediate and a non-immediate daughter of another (defun add-daughters-to-type-table nil ;; checks for correctness of parent specs (let ((ok t)) (loop for name in *type-names* do (let* ((type-entry (get-type-entry name)) (parents (ltype-parents type-entry))) ;;; type-parents gets reset by glb code (loop for parent in parents do (let ((parent-entry (get-type-entry parent))) (cond (parent-entry (pushnew name (ltype-daughters parent-entry) :test #'eq)) (t (setf ok nil) (format t "~%~A specified to have non-existent parent ~A" name parent))))))) ok)) (defun check-for-cycles-etc (top) (let ((top-entry (get-type-entry top))) (mark-node-active top-entry) (when (mark-for-cycles top-entry) (unmark-type-table) (if (mark-for-redundancy top-entry) (scan-table) (progn (find-all-redundancies) ;;; tell user about all the problems nil))))) ;;; John's algorithm for marking a graph to check for cycles ;;; 1. start from top - mark node as active and seen ;;; 2. go depth first - marking all nodes as active and seen ;;; until you hit a leaf node. Mark this as seen (but not active) ;;; go back up - when all leaf nodes of a parent have been marked ;;; remove its active mark etc ;;; 3. If you find a node marked as seen but not active then ;;; treat it as a leaf node ;;; 4. If at any point you find that you are about to mark an already ;;; active node then you have a cycle ;;; marks.lsp contains the marking structures and functions (defun mark-for-cycles (type-record) (or (seen-node-p type-record) (progn (mark-node-seen type-record) (not (dolist (daughter (ltype-daughters type-record)) (unless (let ((daughter-entry (get-type-entry daughter))) (if (active-node-p daughter-entry) (progn (format t "~%Cycle involving ~A" daughter) nil) (progn (mark-node-active daughter-entry) (let ((inner-ok (mark-for-cycles daughter-entry))) (unmark-node-active daughter-entry) inner-ok)))) (return t))))))) ;;; checking for redundant links ;;; ;;; mark all daughters of the node as active ;;; marking an already active node indicates a redundant link ;;; recurse on each daughter ;;; only unmark as active when all daughters have been checked ;;; the algorithm requires that some parts of the hierarchy ;;; will be scanned more than once (defun mark-for-redundancy (type-record) ;; assumes no cycles (mark-node-seen type-record) ;; this is here because it's used in the next phase ;; of checking (let ((ok t) (daughters (loop for d in (ltype-daughters type-record) collect (get-type-entry d)))) (loop for daughter in daughters do (if (active-node-p daughter) (progn (setf ok nil) (format t "~%Redundancy involving ~A" (ltype-name daughter))) (mark-node-active daughter))) (when ok (setf ok (not (dolist (daughter daughters) (unless (mark-for-redundancy daughter) (return t))))) (loop for daughter in daughters do (unmark-node-active daughter))) ok)) (defun scan-table nil (let ((ok t)) (maphash #'(lambda (name type-entry) ;; check for unconnected nodes (unless (seen-node-p type-entry) (setf ok nil) (format t "~%~A not connected to top" name)) ;; unmark the node (clear-marks type-entry)) ;;; removed unary branch stuff - can't imagine anyone wanting to ;;; even be warned *types*) ok)) ;;; Set up descendants and ancestors - done before glb computation ;;; because needed for partition finding, and after as well since so much ;;; changes during glb computation that it's not worth trying to keep ;;; descendants and ancestors up-to-date during it (defun set-up-ancestors-and-descendants () (maphash #'(lambda (node type-entry) (declare (ignore node)) (setf (ltype-ancestors type-entry) nil) (setf (ltype-descendants type-entry) nil)) *types*) (maphash #'(lambda (node type-entry) (declare (ignore node)) (set-up-ancestors type-entry)) *types*) (set-up-descendants (get-type-entry *toptype*))) (defun set-up-ancestors (type-entry) (or (ltype-ancestors type-entry) (let ((parents (ltype-parents type-entry)) (ancestors nil)) (when parents (setq ancestors (cons (get-type-entry (car parents)) (set-up-ancestors (get-type-entry (car parents))))) (dolist (parent (cdr parents)) (pushnew (get-type-entry parent) ancestors :test #'eq) (dolist (ancestor (set-up-ancestors (get-type-entry parent))) (pushnew ancestor ancestors :test #'eq)))) (setf (ltype-ancestors type-entry) ancestors) ancestors))) (defun set-up-descendants (type-entry) ;; JAC - 26 Aug 2017 - compute lists of descendants using a temporary bit vector representation ;; in the eventual descendants slot. Uses the bit-code slot as scratch storage (let* ((ntypes (hash-table-count *types*)) (bit-to-entry (make-array ntypes))) (loop for entry being each hash-value in *types* for n from 0 do (setf (ltype-bit-code entry) n) ; type -> integer (setf (svref bit-to-entry n) entry)) ; integer -> type (set-up-descendants-1 type-entry ntypes) (loop for entry being each hash-value in *types* do (setf (ltype-bit-code entry) nil) ; remove scratch storage slot (let ((desc (ltype-descendants entry))) (unless (arrayp desc) (error "Inconsistency - type ~A unreachable in a top-down traversal of the type hierarchy" (ltype-name entry))) (setf (ltype-descendants entry) nil) ; descendants slot now becomes a list (loop with start = 0 for n = (position 1 (the simple-bit-vector desc) :start start) ; iterate across 1's while n do (unless (eq (svref bit-to-entry n) entry) (push (svref bit-to-entry n) (ltype-descendants entry))) (setq start (1+ n))))))) (defun set-up-descendants-1 (type-entry ntypes) (if (arrayp (ltype-descendants type-entry)) (ltype-descendants type-entry) (let ((desc (make-array ntypes :element-type 'bit :initial-element 0))) (setf (sbit desc (ltype-bit-code type-entry)) 1) (loop for daughter in (ltype-daughters type-entry) do (bit-ior desc (set-up-descendants-1 (get-type-entry daughter) ntypes) t)) (setf (ltype-descendants type-entry) desc)))) ;;; Compute partitions of the hierarchy, returning a list of lists of ;;; nodes which are mutually independent. Shortens the type bit ;;; representations and reduces the number of comparisons performed from ;;; ntypes^2 to (a^2 + b^2 + ...) where a,b,... are sizes of partitions. ;;; The key test is whether for each descendant of a type x, each of that ;;; descendant's parents are one of x's descendants - i.e. its parents ;;; remain within the partition's 'envelope' (defun find-good-partitions (type) ;; AAC - Oct 12 1998 - faster version ; alternative only for experimentation, putting all types in the same partition ; (push (mapcar #'(lambda (x) (get-type-entry x)) (cons type (remove type *type-names*))) ; *partitions*) (let* ((type-entry (get-type-entry type)) (daughters (ltype-daughters type-entry))) (when (and (not (active-node-p type-entry)) (not (seen-node-p type-entry))) (mark-node-active type-entry) (when daughters (dolist (daughter daughters) (find-good-partitions daughter)) (let ((descendants (ltype-descendants type-entry)) (desc-names-non-leaf (make-hash-table :test #'eq))) (loop for d in descendants when (ltype-daughters d) ; leaf types are irrelevant do (setf (gethash (ltype-name d) desc-names-non-leaf) t)) (when (loop for descendant in descendants always (or (seen-node-p descendant) (null (cdr (ltype-parents descendant))) (loop for p in (ltype-parents descendant) always (gethash p desc-names-non-leaf)))) (let ((partition-nodes (loop for descendant in descendants when (not (seen-node-p descendant)) collect (progn (mark-node-seen descendant) descendant)))) (when partition-nodes (push (cons type-entry partition-nodes) *partitions*))))))))) ;;; Glb type computation. Assigns a (temporary) bit representation for ;;; each type in heirarchy, and uses it to efficiently check if each pair ;;; of types has a glb and add it if not ;;; The code below implements the type bit operations using a straightforward native ;;; bit vector representation. This approach is relatively slow in practice, but the ;;; code is included as a reference implementation and to help understand the more ;;; complex but much faster approach below - so DO NOT DELETE IT! #+:bitvecglb (progn (defun make-bit-code (nbits) (make-array nbits :element-type 'bit :initial-element 0)) (defmacro bit-code-start (c) 0) (defsetf bit-code-start (c) (value) nil) (defmacro bit-code-end (c) `(1- (length ,c))) (defsetf bit-code-end (c) (value) nil) (defun finalise-bit-code (c) c) (defun bit-code-equal-p (c1 c2) (equal c1 c2)) (defun bit-code-and-zero/one-p (c1 c2 c3) ;; c3 <- c1 AND c2 (destructive) ;; and return a boolean indicating whether c3 would be all zero (and optionally ;; furthermore whether only one bit in c3 is set), although if returning true ;; then the contents of c3 are not used (bit-and c1 c2 c3) (not (find 1 c3))) (defun bit-code-ior (c1 c2 c3) (bit-ior c1 c2 c3)) (let ((temp (make-array 0 :element-type 'bit))) (defun bit-code-subsume-p (c1 c2) ;; does code c1 subsume c2? i.e. for every bit not set in c1, is the ;; corresponding bit in c2 also unset? (unless (= (length temp) (length c1)) (setq temp (make-array (length c1) :element-type 'bit))) (not (find 1 (bit-andc1 c1 c2 temp)))) ) (defun set-bit-code (c n) (setf (sbit c n) 1)) (defun bit-code-position-1 (c) ;; index of first bit that is set in c (position 1 c)) (defun print-bit-code (c) (print c)) ) ;;; The type bit code representation above will not be efficient unless the Lisp system ;;; very carefully implements these logical operations in 64 bit units. This could only ;;; be done with internal sub-primitives analogous to ldb/dpb for integers. In practice we ;;; can do better by representing each code by a simple vector of fixnums, with all ;;; operations on codes being performed 64 or so bits at a time. (A related approach is ;;; described by Henry Baker "Efficient implementation of bit-vector operations in Common ;;; Lisp", ACM Lisp Pointers, 3(2-4).) The scheme as implemented here is completely ;;; portable and should run efficiently in any Lisp system. ;;; ;;; JAC 15-Aug-17: added one or more "summary words" for each type, held in the first ;;; +sw-len+ element(s) of the type's vector - each successive bit in these summary ;;; words is the logical OR of each successive 64 (or so) bits of the type bit code. ;;; Given two types, if the result of ANDing these summary words is all zeros, then ;;; it's guaranteed that the AND of the full representations will also be all zeros. ;;; Similarly, if the result of ANDing the complement of one set of summary words with ;;; another is non-zero, then the former type cannot subsume the latter. See ;;; finalise-bit-code, bit-code-and-zero/one-p and bit-code-subsume-p below. ;;; ;;; JAC 8-Oct-17: added two further initial words holding the vector index of the first ;;; and last non-zero words in the type bit code. These are used to skip initial and final ;;; sequences of zero bits in the AND, subsumption and equal operations. The start index ;;; is also used to sort and index lists of types, and both the start and end indexes are ;;; used as pre-filters and early termination tests for the computations involving AND ;;; and subsumption. In fact, these indices ;;; ;;; The vector layout is ;;; #( ;;; ) ;;; ;;; Using a simple-vector turns out to be much more efficient than a specialized array with ;;; :element-type fixnum - at least in SBCL. For the bit codes we'd ideally use unsigned ;;; 64-bit integers and the Lisp system would not box/unbox - but that's not practical so ;;; we have to make do with (signed) fixnums, and also lose a further bit or so on each ;;; for the Lisp system's type tag. ;;; ;;; NB The summary words are kept consistent only for the AND and subsumption operations. ;;; So do not attempt to use them in the bit code equal, OR or position-1 functions. #-:bitvecglb (progn (defconstant +fixnum-len+ (1+ (integer-length most-positive-fixnum))) (defconstant +sw-len+ 1) ; 0 disables summary words, otherwise must be a small positive integer (defun make-bit-code (nbits) (make-array (+ +sw-len+ 2 (ceiling nbits +fixnum-len+)) ; summary words then 1 each for start and end :element-type t :initial-element 0)) (defmacro bit-code-start (c) #-:noindexglb `(the fixnum (locally #-:tdebug (declare (optimize (speed 3) (safety 0))) (svref (the simple-vector ,c) +sw-len+))) #+:noindexglb (+ +sw-len+ 2)) (defsetf bit-code-start (c) (value) `(setf (svref ,c +sw-len+) ,value)) (defmacro bit-code-end (c) #-:noindexglb `(the fixnum (locally #-:tdebug (declare (optimize (speed 3) (safety 0))) (svref (the simple-vector ,c) (1+ +sw-len+)))) #+:noindexglb `(1- (length ,c))) (defsetf bit-code-end (c) (value) `(setf (svref ,c (1+ +sw-len+)) ,value)) (defun finalise-bit-code (c) #-:tdebug (declare (type simple-vector c) (optimize (speed 3) (safety 0))) #+:tdebug (unless (arrayp c) (error "not an array")) (when (> +sw-len+ 0) ;; each successive bit of the summary words is the logical OR of each successive ;; +fixnum-len+ bits of the type bit code - the outcome is slightly faster than cycling ;; bit-wise through the type bit code, perhaps because closely related types more often ;; end up in the same equivalence set (loop initially (fill c 0 :start 0 :end +sw-len+) for n fixnum from (+ +sw-len+ 2) below (length c) with tf-bit fixnum = 0 with tf-elt fixnum = 0 do (when (= tf-bit +fixnum-len+) ; move to next element? (setq tf-bit 0) (setq tf-elt (rem (1+ tf-elt) +sw-len+))) (unless (zerop (the fixnum (svref c n))) (setf (svref c tf-elt) (logior (svref c tf-elt) (if (zerop tf-bit) most-negative-fixnum (ash 1 (- (1- +fixnum-len+) tf-bit)))))) (incf tf-bit))) #-:noindexglb (setf (bit-code-start c) (position-if-not #'zerop c :start (+ +sw-len+ 2))) #-:noindexglb (setf (bit-code-end c) (position-if-not #'zerop c :start (+ +sw-len+ 2) :from-end t)) c) (defun bit-code-equal-p (c1 c2) #-:tdebug (declare (type simple-vector c1 c2) (optimize (speed 3) (safety 0))) #+:tdebug (unless (and (arrayp c1) (arrayp c2)) (error "not an array")) ;; NB c2 hasn't been through finalise-bit-code so we can't use its summary words, ;; but its start and end indices are correct (and #-:noindexglb (= (bit-code-end c1) (bit-code-end c2)) (loop for n fixnum from (min (bit-code-start c1) (bit-code-start c2)) to (bit-code-end c1) always (= (the fixnum (svref c1 n)) (the fixnum (svref c2 n)))))) (defmacro bit-code-and-zero/one-p (c1 c2 c3) `(locally #-:tdebug (declare (optimize (speed 3) (safety 0))) (or ;; first check the bit code summary words ,(if (> +sw-len+ 0) `(and ,@(loop for i from 0 below +sw-len+ collect `(zerop (logand (the fixnum (svref (the simple-vector ,c1) ,i)) (the fixnum (svref (the simple-vector ,c2) ,i))))))) (bit-code-and-zero/one-p-1 ,c1 ,c2 ,c3)))) (defun bit-code-and-zero/one-p-1 (c1 c2 c3) #-:tdebug (declare (type simple-vector c1 c2 c3) (optimize (speed 3) (safety 0))) #+:tdebug (unless (and (arrayp c1) (arrayp c2) (arrayp c3)) (error "not an array")) (flet ((fixnum-one-1-bit-p (e) (declare (fixnum e)) (zerop (logand e (if (minusp e) most-positive-fixnum (the fixnum (1- e))))))) ;; don't fill in c3 until we know that one of the type bit code words is non-zero (let* ((first-possible-nz (max (bit-code-start c1) (bit-code-start c2))) (last-possible-nz (min (bit-code-end c1) (bit-code-end c2))) (first-actual-nz (loop for n fixnum from first-possible-nz to last-possible-nz unless (zerop (logand (the fixnum (svref c1 n)) (the fixnum (svref c2 n)))) return n)) (last-actual-nz first-actual-nz)) (if first-actual-nz (loop for n fixnum from first-actual-nz to last-possible-nz do (unless (zerop (setf (svref c3 n) (logand (the fixnum (svref c1 n)) (the fixnum (svref c2 n))))) (setq last-actual-nz n)) finally (if (and (= first-actual-nz last-actual-nz) (fixnum-one-1-bit-p (svref c3 first-actual-nz))) (return t) (progn #-:noindexglb (setf (bit-code-start c3) first-actual-nz) #-:noindexglb (setf (bit-code-end c3) last-actual-nz) (fill c3 0 :start (+ +sw-len+ 2) :end first-actual-nz) (fill c3 0 :start (1+ last-possible-nz))))) t)))) (defun bit-code-ior (c1 c2 c3) #-:tdebug (declare (type simple-vector c1 c2 c3) (optimize (speed 3) (safety 0))) #+:tdebug (unless (and (arrayp c1) (arrayp c2) (arrayp c3)) (error "not an array")) (loop for n fixnum from (+ +sw-len+ 2) below (length c1) do (setf (svref c3 n) (logior (the fixnum (svref c1 n)) (the fixnum (svref c2 n)))) finally (return c3))) (defmacro bit-code-subsume-p (c1 c2) `(locally #-:tdebug (declare (optimize (speed 3) (safety 0))) (and ;; first check the bit code summary words ,@(loop for i from 0 below +sw-len+ collect `(zerop (logandc1 (the fixnum (svref ,c1 ,i)) (the fixnum (svref ,c2 ,i))))) ;; first non-zero bit code word of the potential subsumed type is also a good filter #-:noindexglb (zerop (logandc1 (the fixnum (svref ,c1 (bit-code-start ,c2))) (the fixnum (svref ,c2 (bit-code-start ,c2))))) (bit-code-subsume-p1 ,c1 ,c2)))) (defun bit-code-subsume-p1 (c1 c2) #-:tdebug (declare (type simple-vector c1 c2) (optimize (speed 3) (safety 0))) #+:tdebug (unless (and (arrayp c1) (arrayp c2)) (error "not an array")) (loop for n fixnum from (bit-code-start c2) to (bit-code-end c2) always (zerop (logandc1 (the fixnum (svref c1 n)) (the fixnum (svref c2 n)))))) (defun set-bit-code (c n) #-:tdebug (declare (type simple-vector c) (fixnum n) (optimize (speed 3) (safety 0))) #+:tdebug (unless (and (arrayp c) (integerp n)) (error "not an array and/or integer")) (multiple-value-bind (e1 e2) (truncate n +fixnum-len+) (incf e1 (+ +sw-len+ 2)) (setf (svref c e1) (logior (svref c e1) (if (zerop e2) most-negative-fixnum (ash 1 (- (1- +fixnum-len+) e2))))))) (defun bit-code-position-1 (c) #-:tdebug (declare (type simple-vector c) (optimize (speed 3) (safety 0))) #+:tdebug (unless (arrayp c) (error "not an array")) ;; NB c hasn't been through finalise-bit-code, but its start index is correct (let* ((first-nz #-:noindexglb (bit-code-start c) #+:noindexglb (position-if-not #'zerop c :start (+ +sw-len+ 2))) (e (svref c first-nz))) (declare (fixnum e first-nz)) (+ (the fixnum (* (- first-nz (+ +sw-len+ 2)) +fixnum-len+)) (if (minusp e) 0 (- +fixnum-len+ (integer-length e)))))) (defun print-bit-code (c) (flet ((list-hex (n m) (format nil "(~{#x~16,'0X~^ ~})" (loop for i from n to m for e = (svref c i) collect (if (minusp e) (logior (logand e most-positive-fixnum) (1+ most-positive-fixnum)) e))))) (format t "~%# " (list-hex 0 (1- +sw-len+)) (bit-code-start c) (bit-code-end c) (list-hex (bit-code-start c) (bit-code-end c))))) ) ;;; Entry point for glb computation: compute-and-add-glbtypes. We don't need to ;;; consider any types that are at the fringe of the hierarchy and have only ;;; a single parent. Moreover, when checking pairs of types to determine if they ;;; have any common subtypes, we don't need to check any types with zero or only ;;; one descendant. ;;; ;;; Type codes can be looked up efficiently by hashing them on the index of ;;; their first non-zero bit. Thanks to Ulrich Callmeier for his code providing ;;; the basic algorithms for assigning bit codes to types and computing glb types. (defvar *bit-coded-type-table*) (defmacro get-bit-coded-type (bit-coded-type-table code) `(svref ,bit-coded-type-table (bit-code-position-1 ,code))) (defun lookup-type-from-bits (code) ;; hash code and check for equal one in bucket (dolist (type (get-bit-coded-type *bit-coded-type-table* code) nil) (when (bit-code-equal-p (ltype-bit-code type) code) (return type)))) (defun compute-and-add-glbtypes (types) ;; A type satisfying no-split-no-join-type-p or internal-tree-type-p doesn't need a bit ;; code since it is not 'active' with respect to GLB computation: it cannot be a GLB, ;; cannot be a parent/daughter of a new GLB type, and cannot cause a new GLB type to ;; be created. A type satisfying no-split-type-p can be a GLB, can be a daughter of ;; a new GLB type, but cannot cause a new GLB type to be created. (labels ((no-split-no-join-type-p (type) ; no more than 1 incoming and 1 outgoing arc (and (null (cdr (ltype-parents type))) (null (cdr (ltype-daughters type))))) (internal-tree-type-p (type) ; below root of a tree-shaped part of hierarchy (and (null (cdr (ltype-parents type))) (loop for d in (ltype-daughters type) always (internal-tree-type-p (get-type-entry d))))) (no-split-type-p (type) ; no more than 1 outgoing arc (null (cdr (ltype-daughters type))))) (let* ((active-types (cons (car types) (remove-if #'(lambda (x) (or (no-split-no-join-type-p x) (internal-tree-type-p x))) (cdr types)))) (ntypes (length active-types)) (split-types (remove-if #'no-split-type-p active-types))) (if (> (length split-types) 3) (let ((*bit-coded-type-table* (make-array ntypes :initial-element nil))) (assign-type-bit-codes types active-types ntypes) (when *display-glb-summary* (format t "~%Partition ~A of ~A types (~A active, ~A splits)" (ltype-name (car types)) (length types) ntypes (length split-types)) (force-output)) (let ((glbtypes (compute-glbtypes-from-bit-codes split-types ntypes))) (when (and *display-glb-summary* glbtypes) (format t " -> ~A glb~:p" (length glbtypes)) (force-output)) (when glbtypes (insert-glbtypes-into-hierarchy active-types glbtypes)) (dolist (type (append glbtypes active-types)) (setf (ltype-bit-code type) nil)) (length glbtypes))) 0)))) (defun assign-type-bit-codes (types active-types ntypes) ;; Assign a bit code to types (of length the number of types), the first ;; element being the common ancestor of all of them. Code for each type ;; is the OR of all its descendants with one additional bit set. Process ;; only the types list, and pass through any type not in active-types (let ((status (make-hash-table :size ntypes :test #'eq)) (n ntypes)) (labels ((assign-type-bit-codes1 (type) (let ((code (ltype-bit-code type))) (unless code (setq code (make-bit-code ntypes)) (dolist (d-name (ltype-daughters type)) (let ((d (get-type-entry d-name))) (when (gethash d status) (setq code (bit-code-ior code (assign-type-bit-codes1 d) code))))) (when (eq (gethash type status) :active) (decf n) (set-bit-code code n) (setf (ltype-bit-code type) (finalise-bit-code code)) (push type (get-bit-coded-type *bit-coded-type-table* code)))) code))) (loop for type in types do (setf (gethash type status) t)) (loop for type in active-types do (setf (gethash type status) :active)) (assign-type-bit-codes1 (car types))))) (defun compute-glbtypes-from-bit-codes (types ntypes) ;; For every pair of types check if they have any common subtypes (is the ;; AND of the two types' codes non-zero?), and if so, if they already have ;; a glb type (is there a type with a code equal to the AND of the codes?). ;; If not, a glb type is created with this code. Process iterates with new ;; types until no more are constructed (let* ((temp (make-bit-code ntypes)) (new nil) (glbtypes nil)) (loop (unless (cdr types) (return glbtypes)) (loop for t1 on (sort types #'< :key #'(lambda (x) (bit-code-start (ltype-bit-code x)))) for t1c = (ltype-bit-code (car t1)) do (loop for t2 on (cdr t1) for t2c = (ltype-bit-code (car t2)) until (> (bit-code-start t2c) (bit-code-end t1c)) ; will also hold for rest of t2 do (when (and (not (bit-code-and-zero/one-p t1c t2c temp)) (not (lookup-type-from-bits temp))) (let* ((name (make-glb-name nil)) (new-type-entry (make-ltype :name name :glbp t))) (set-type-entry name new-type-entry) (when *display-glb-messages* (format t "~%Fixing ~A and ~A with ~A" (car t1) (car t2) new-type-entry)) (setf (ltype-bit-code new-type-entry) (finalise-bit-code temp)) (push new-type-entry (get-bit-coded-type *bit-coded-type-table* temp)) (push new-type-entry glbtypes) (push new-type-entry new) (setq temp (make-bit-code ntypes)))))) (setq types new new nil)))) (defun insert-glbtypes-into-hierarchy (types glbtypes) ;; Work out the parents and daughters of each GLB type and insert it into the ;; standard linked type node representation of the hierarchy. Consider 'split' ;; and 'join' types separately: only split types may have a GLB immediately ;; below, and only join types may have one immediately above. GLB types may ;; have another GLB either above or below. ;; NB The computation iterates over glbtypes x (glbtypes + authored-types); in ;; principle the iteration could be reduced to (glbtype1 x authored-types) + ;; (glbtype2 x (glbtype1 + authored-types)) + ... However, doing this makes the ;; computation very sensitive to the order in which the glbtypes are processed - ;; in some cases leading to severe slowdowns. (let* ((split-types ; only split nodes can have a GLB type as a daughter (sort (append glbtypes (loop for e in types when (cdr (ltype-daughters e)) collect e)) #'> :key #'(lambda (x) (bit-code-start (ltype-bit-code x))))) (join-types ; only join nodes can have a GLB type as a parent (sort (append glbtypes (loop for e in types when (cdr (ltype-parents e)) collect e)) #'< :key #'(lambda (x) (bit-code-start (ltype-bit-code x))))) (index-len (length (ltype-bit-code (car types)))) (split-index (make-array index-len :initial-element nil)) (join-index (make-array index-len :initial-element nil))) (loop for ts on split-types ; split-index element i contains all types with start i or less for s = (bit-code-start (ltype-bit-code (car ts))) with prev = index-len do (unless (eql s prev) (loop for j from (1- prev) downto s do (setf (svref split-index j) ts)) (setq prev s))) (loop for ts on join-types ; join-index element i contains all types with start at least i for s = (bit-code-start (ltype-bit-code (car ts))) with prev = #+:bitvecglb -1 #-:bitvecglb (1- (+ +sw-len+ 2)) do (unless (eql s prev) (loop for j from (1+ prev) to s do (setf (svref join-index j) ts)) (setq prev s))) (dolist (glb glbtypes) (let ((parents nil) (daughters nil) (glb-start (bit-code-start (ltype-bit-code glb))) (glb-end (bit-code-end (ltype-bit-code glb)))) (declare (list parents daughters)) (flet ((add-to-daughters (ty) ;; ty is a descendant of current glb - try to add it to the current ;; highest disjoint set of descendants. If it subsumes any elements ;; of the set, then delete them and add it instead. If it's subsumed ;; by any, then don't consider this entry further (do ((tail daughters (cdr tail)) (subsumep nil)) ((null tail) (when subsumep (setq daughters (delete nil daughters :test #'eq))) (push ty daughters)) (cond ((bit-code-subsume-p (ltype-bit-code ty) (ltype-bit-code (car tail))) (setf (car tail) nil subsumep t)) ((and (not subsumep) (bit-code-subsume-p (ltype-bit-code (car tail)) (ltype-bit-code ty))) (return))))) (add-to-parents (ty) ;; ty is an ancestor of current glb - try to add entry to the current ;; lowest disjoint set of ancestors (do ((tail parents (cdr tail)) (subsumep nil)) ((null tail) (when subsumep (setq parents (delete nil parents :test #'eq))) (push ty parents)) (cond ((bit-code-subsume-p (ltype-bit-code (car tail)) (ltype-bit-code ty)) (setf (car tail) nil subsumep t)) ((and (not subsumep) (bit-code-subsume-p (ltype-bit-code ty) (ltype-bit-code (car tail)))) (return)))))) ;; iterate over all split types whose start <= glb-start (loop for ty in (svref split-index glb-start) do (cond ((< (bit-code-end (ltype-bit-code ty)) glb-end)) ; ty ends before glb? ((eq ty glb)) ((bit-code-subsume-p (ltype-bit-code ty) (ltype-bit-code glb)) (add-to-parents ty)))) ;; iterate over all join types whose start satisfies glb-start <= start <= glb-end (loop for ty in (svref join-index glb-start) until (> (bit-code-start (ltype-bit-code ty)) glb-end) do (cond ((> (bit-code-end (ltype-bit-code ty)) glb-end)) ; ty ends after glb? ((eq ty glb)) ((bit-code-subsume-p (ltype-bit-code glb) (ltype-bit-code ty)) (add-to-daughters ty)))) ;; (insert-new-type-into-hierarchy (ltype-name glb) glb parents daughters)))) (mapc #'remove-redundant-hierarchy-links glbtypes))) #| (defun insert-glbtypes-into-hierarchy (types glbtypes) ;; A simple, reference implementation of the above function, included to help ;; understand the more complex actual approach (which is around 2.5x faster) ;; - DO NOT DELETE IT! (let ((all-types (append glbtypes types))) (dolist (glb glbtypes) (let ((parents nil) (daughters nil)) (flet ((add-to-daughters (ty) ...) (add-to-parents (ty) ...) (dolist (ty all-types) (cond ((eq ty glb)) ((bit-code-subsume-p (ltype-bit-code ty) (ltype-bit-code glb)) (add-to-parents ty)) ((bit-code-subsume-p (ltype-bit-code glb) (ltype-bit-code ty)) (add-to-daughters ty)))) (insert-new-type-into-hierarchy (ltype-name glb) glb parents daughters)))) (mapc #'remove-redundant-hierarchy-links glbtypes))) |# (defun insert-new-type-into-hierarchy (new-type new-type-entry parents daughters) ;; ancestors and descendants are recomputed later in a single pass (let ((daughter-names (mapcar #'ltype-name daughters)) (parent-names (mapcar #'ltype-name parents))) (create-mark-field new-type-entry) (setf (ltype-daughters new-type-entry) daughter-names) (setf (ltype-parents new-type-entry) parent-names) (dolist (daughter daughters) (pushnew new-type (ltype-parents daughter) :test #'eq)) (dolist (parent parents) (pushnew new-type (ltype-daughters parent) :test #'eq)) (push new-type *ordered-glbtype-list*) (push new-type *type-names*) new-type-entry)) (defun remove-redundant-hierarchy-links (new-type-entry) ;; most efficient to do this at the end of GLB type insertion once all daughters and ;; parents lists have been computed (dolist (daughter (ltype-daughters new-type-entry)) ;; remove from daughter any of its parents that subsume new GLB type (setq daughter (get-type-entry daughter)) (setf (ltype-parents daughter) (loop for pname in (ltype-parents daughter) for p = (get-type-entry pname) unless (and (not (eq p new-type-entry)) (ltype-bit-code p) (bit-code-subsume-p (ltype-bit-code p) (ltype-bit-code new-type-entry))) collect pname))) (dolist (parent (ltype-parents new-type-entry)) ;; remove from parent any of its daughters that are subsumed by new GLB type (setq parent (get-type-entry parent)) (setf (ltype-daughters parent) (loop for dname in (ltype-daughters parent) for d = (get-type-entry dname) unless (and (not (eq d new-type-entry)) (ltype-bit-code d) (bit-code-subsume-p (ltype-bit-code new-type-entry) (ltype-bit-code d))) collect dname)))) (defun make-glb-name (dtrs) (declare (ignore dtrs)) (next 'glbtype)) #| (let* ((true-dtrs (remove-duplicates (loop for dtr in dtrs append (let ((dtr-entry (get-type-entry dtr))) (if (ltype-glbp dtr-entry) (find-other-daughters dtr-entry) (list dtr)))))) (new-name-str (format nil "+~{~A+~}" (mapcar #'abbrev-type-name true-dtrs))) (existing (find-symbol new-name-str))) (if existing (next existing) (intern new-name-str)))) (defun abbrev-type-name (dtr) (let ((strname (string dtr))) (if (> (length strname) 3) (subseq strname 0 3) strname))) |# ;;; Constraint stuff (defun expand-and-inherit-constraints nil (let ((ok t)) (unmark-type-table) ;; a. determine which types are atomic ;; can't do unification really without this info ;; ;; b. expand constraints by first forming fstructure from ;; any constraint spec and then unifying with ;; the parents' constraints, expanding these if necessary ;; marking types when the constraint has been expanded ;; (determine-atomic-types) (loop for node in *type-names* do (let ((type-entry (get-type-entry node))) (unless (leaf-type-p type-entry) (unless (expand-constraint node type-entry) (setf ok nil))))) (when ok (check-feature-table)))) (defun determine-atomic-types nil (dolist (node *type-names*) (let ((type-entry (get-type-entry node))) (let ((constraint-spec (ltype-constraint-spec type-entry))) (unless (leaf-type-p type-entry) (setf (ltype-atomic-p type-entry) (not (or constraint-spec (some #'ltype-constraint-spec (ltype-ancestors type-entry)) (some #'(lambda (daughter) (or (ltype-constraint-spec daughter) (some #'ltype-constraint-spec (ltype-ancestors daughter)))) (ltype-descendants type-entry)))))))))) (defun expand-constraint (node type-entry) (cond ((seen-node-p type-entry) (ltype-inherited-constraint type-entry)) (t (mark-node-seen type-entry) (let* ((*unify-debug-cycles* t) ; turn on cyclic dag warning messages (constraint-spec (ltype-constraint-spec type-entry)) (local-constraint (if constraint-spec (process-unifications constraint-spec)))) (cond ((and constraint-spec (null local-constraint)) (format t "~%Type ~A has an invalid constraint specification" node) nil) (t (when local-constraint (unless (or (eq (type-of-fs local-constraint) *toptype*) (eq (type-of-fs local-constraint) node)) (format t "~%Warning: setting constraint of ~A to have ~A as type" node node)) (setq local-constraint (destructively-retype-dag local-constraint node)) (setf (ltype-local-constraint type-entry) local-constraint) (let ((local-appfeats (top-level-features-of local-constraint))) (loop for feature in local-appfeats do (add-maximal-type feature node)))) ; no need to do inheritance when checking ; for maximal introduction (let ((full-constraint (inherit-constraints node type-entry local-constraint))) (cond (full-constraint (setf (ltype-inherited-constraint type-entry) full-constraint) (setf (ltype-appfeats type-entry) (top-level-features-of full-constraint)) full-constraint) (t (format t "~%Type ~A's constraint ~ specification clashes with its parents'" node) nil))))))))) (defun inherit-constraints (node type-entry local-constraint) (if (ltype-atomic-p type-entry) (create-typed-dag node) (let ((supers (mapcar #'(lambda (parent) (expand-constraint parent (get-type-entry parent))) (ltype-parents type-entry)))) (with-unification-context (nil) (let ((result (reduce #'(lambda (x y) (when (and x y) (unify-dags x (retype-dag y *toptype*)))) supers :initial-value (or local-constraint (create-typed-dag node))))) (if result (copy-dag result))))))) (defun add-maximal-type (feature type) ;; a feature may only be introduced at one ;; point in the type hierarchy ;; Set up a hash table associating maximal types ;; with features ;; When a feature is first found in a constraint spec ;; initially set its entry to that type ;; Subsequently if it is found on another type there are ;; three possibilities ;; the new type may be a subtype of one of the first - do nothing ;; one or more of the old types may be a subtype of the new type - ;; replace the old with the new ;; there may be no subtype relationship - this may be because ;; there is an as yet unencountered type which is a supertype of ;; both or it may be an error ;; - add the new type to the old in a list - then replace ;; as appropriate if the supertype comes along ;; if there is already a list and another type is encountered ;; which is not a supertype of all the types then add it to the ;; list ;; at the end a final pass checks for problems and converts lists ;; to atoms (let ((max-types (maximal-type-of feature))) (if (null max-types) (set-feature-entry feature (list type)) (unless (some #'(lambda (old-type) (subtype-p type old-type)) max-types) (set-feature-entry feature (remove-duplicates (cons type (substitute-if type #'(lambda (old-type) (subtype-p old-type type)) max-types)))))))) ;;; Do strong typing and well-formedness check (defparameter *well-formed-trace* nil) (defun strongly-type-constraints nil ;; c. check for well-formedness ... (let ((ok t) (*unify-debug-cycles* t)) ; turn on cyclic dag warning messages (unmark-type-table) (loop for type-name in *type-names* do (unless (leaf-type-p (get-type-entry type-name)) (unless (progn (setf *well-formed-trace* nil) (wf-constraint-of type-name)) (setf ok nil)))) (setf *well-formed-trace* nil) (unmark-type-table) ;; !!! can't create cyclic dags so don't check for them ok)) (defun wf-constraint-of (type-name) ;; may need to be copied completely before use ;; (print (list '> 'wf-constraint-of type-name)) (let ((type-entry (get-type-entry type-name))) (unless (seen-node-p type-entry) (when (member type-name *well-formed-trace*) (error "~%~A is used in expanding its own constraint expansion sequence: ~A" type-name *well-formed-trace*)) (push type-name *well-formed-trace*) (if (ltype-appfeats type-entry) (let ((new-dag (ltype-inherited-constraint type-entry))) ;; !!! outside here must stay within current generation (let ((*unify-generation* *unify-generation*) (*within-unification-context-p* t)) ;; establish new unification generation now, and also at ;; end (the usual place) (invalidate-marks) (prog1 (if (really-make-features-well-formed new-dag nil type-name) (let ((res (copy-dag new-dag))) (if res (setf (ltype-constraint type-entry) res) (format t "~%Warning: cycle in well-formed constraint for ~A" type-name))) nil) ;; (format t "~%Warning: cannot make constraint for ~A well-formed" type-name)) ;; warning msg is excessive (invalidate-marks) ))) (setf (ltype-constraint type-entry) (ltype-inherited-constraint type-entry))) (mark-node-seen type-entry)) ;; (print (list '< 'wf-constraint-of type-name)) (when (ltype-constraint type-entry) (setf (ltype-inherited-constraint type-entry) nil)) ;;; strong typing has worked, so save some space - otherwise leave ;;; the old structure around for debugging (ltype-constraint type-entry))) ;;; Make appfeats order equivalent so that display is consistent. Mostly ;;; will have same features as parent and be ordered the same already. If not, ;;; take current list, scan parent order, and delete types found in that from ;;; list, moving them to the front of the list (defun canonicalise-feature-order nil (format t "~%Computing display ordering") (unmark-type-table) (inherit-display-ordering *toptype* nil)) (defun inherit-display-ordering (type parent-feature-order) (let* ((type-record (get-type-entry type)) (already-ordered-p t) (ordered-features (if (every #'eq (ltype-appfeats type-record) parent-feature-order) (ltype-appfeats type-record) (let ((parent-ordered nil) (appfeats (cons nil (ltype-appfeats type-record)))) (setq already-ordered-p nil) (dolist (parent-feat parent-feature-order (nreconc parent-ordered (cdr appfeats))) (block found (do ((app-prev-tail appfeats (cdr app-prev-tail)) (app-tail (cdr appfeats) (cdr app-tail))) ((null app-tail)) (when (eq (car app-tail) parent-feat) (setf (cdr app-prev-tail) (cdr app-tail)) (setf (cdr app-tail) parent-ordered) (setq parent-ordered app-tail) (return-from found nil)))))))) (sorted-ordered-features (if (and *feature-ordering* ordered-features) (fix-feature-ordering ordered-features *feature-ordering*) ordered-features))) (setf (ltype-appfeats type-record) sorted-ordered-features) ;; don't process children if this type ;; has been visited previously and its ;; feature ordering wasn't changed this time around ;(print (list type already-ordered-p (seen-node-p type-record))) (unless (and already-ordered-p (seen-node-p type-record)) (mark-node-seen type-record) (unless (ltype-enumerated-p type-record) (loop for daughter in (ltype-daughters type-record) do (inherit-display-ordering daughter sorted-ordered-features)))))) (defun fix-feature-ordering (feats feature-order) (sort feats #'(lambda (x y) (let ((x-list (member x feature-order))) (if x-list (member y x-list)))))) ; should be stable-sort, but seems to be buggy in ACL ;;; Stuff below here is new for YADU ;;; Checking defaults ;;; The type checking for the hard information is defined to behave exactly ;;; as before. The defaults are added in as a final stage ;;; ;;; 1. A default constraint must be internally consistent ;;; 2. A default constraint must be strictly more specific than the ;;; indefeasible constraint ;;; 3. A default constraint must inherit all defaults from its supertypes ;;; i.e. subsequent unification with the constraints ;;; on its supertypes has no further effect ;;; Note that there is no requirement that a default fs be well-formed ;;; However the local default constraint is actually constructed by ;;; creating a wffs from the default specifications and using unify-wffs ;;; to unify it with the indefeasible fs (defun expand-type-hierarchy-defaults nil (let ((ok t)) (unmark-type-table) ;; expand constraints to tdfs by ;; 1) creating the default fss grouped by persistence ;;; and making them well formed ;; 2) unifying-wffsing them with the indefeasible fs ;; 3) creating a tdfs ;; 4) yaduing the tdfs with the supertypes tdfs ;; expanding these if necessary and marking types when ;; the constraint has been expanded (loop for node in *type-names* do (let ((type-entry (get-type-entry node))) (unless (leaf-type-p type-entry) (unless (expand-default-constraint node type-entry) (setf ok nil))))) ok)) (defun expand-default-constraint (node type-entry) (cond ((seen-node-p type-entry) (ltype-tdfs type-entry)) (t (mark-node-seen type-entry) (let* ((indef (ltype-constraint type-entry)) (full-tdfs nil) (default-specs (ltype-default-spec type-entry)) (default-fss (loop for default-spec in default-specs collect (make-equivalent-persistence-defaults indef (car default-spec) (cdr default-spec) node)))) (setf full-tdfs (inherit-default-constraints node type-entry (construct-tdfs indef default-fss))) (setf (ltype-tdfs type-entry) full-tdfs) full-tdfs)))) (defun make-equivalent-persistence-defaults (indef persistence default-spec node) (let* ((local-fs (if default-spec (process-unifications default-spec))) (local-default (if local-fs (create-wffs local-fs)))) (with-unification-context (local-default) (let ((new-default (if local-default (if (unify-wffs local-default indef) local-default)))) (when (and default-spec (not new-default)) (format t "~%Type ~A has inconsistent defaults for ~ persistence ~A: ignoring those defaults" node persistence)) (when new-default (unless (setq new-default (copy-dag new-default)) (format t "~%Defeasible FS contains cycles in type ~A ~ persistence ~A: ignoring those defaults" node persistence))) (unless new-default (setf new-default indef)) (cons persistence new-default))))) ;; Check for defaults that aren't at the top level (defun collect-tails (node dag) (let* ((type (type-of-fs dag)) (type-entry (get-type-entry type))) (when type-entry (let ((tdfs (ltype-tdfs type-entry))) (when (and tdfs (tdfs-tail tdfs)) (format t "~%Default constraint on ~A ignored in ~A" (ltype-name type-entry) node))) (dolist (arc (dag-arcs dag)) (collect-tails node (dag-arc-value arc)))))) (defun inherit-default-constraints (node type-entry local-tdfs) ;;; (collect-tails node (tdfs-indef local-tdfs)) (declare (ignore node)) (let ((current-tail (tdfs-tail local-tdfs))) (loop for parent in (ltype-parents type-entry) do (let ((parent-tdfs (expand-default-constraint parent (get-type-entry parent)))) (unless parent-tdfs (format t "~%Cannot make tdfs for ~A" parent)) (when parent-tdfs (setf current-tail (yadu-general-merge-tails (tdfs-tail parent-tdfs) current-tail (tdfs-indef local-tdfs)))))) (setf (tdfs-tail local-tdfs) current-tail) local-tdfs))