* interp/domain.lisp: Remove.

2 files changed, 1 insertions, 228 deletions

diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet
index 3455bfe9..846fcca9 100644
--- a/src/interp/Makefile.pamphlet
+++ b/src/interp/Makefile.pamphlet
@@ -308,7 +308,7 @@ lack of understanding. Rather than erase them they are documented
 here for future reference. 
 <<environment>>=
 UNUSED= ${DOC}/construc.lisp.dvi \
-	${DOC}/domain.lisp.dvi 	${DOC}/guess.boot.dvi \
+	${DOC}/guess.boot.dvi \
 	${DOC}/interp-fix.boot.dvi \
 	${DOC}/nhyper.boot.dvi ${DOC}/pf2atree.boot.dvi \
 	${DOC}/redefs.boot.dvi 	${DOC}/word.boot.dvi 
diff --git a/src/interp/domain.lisp b/src/interp/domain.lisp
deleted file mode 100644
index beed4d52..00000000
--- a/src/interp/domain.lisp
+++ /dev/null
@@ -1,227 +0,0 @@
-;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
-;; All rights reserved.
-;; Copyright (C) 2007, Gabriel Dos Reis.
-;; All rights reserved.
-;;
-;; Redistribution and use in source and binary forms, with or without
-;; modification, are permitted provided that the following conditions are
-;; met:
-;;
-;;     - Redistributions of source code must retain the above copyright
-;;       notice, this list of conditions and the following disclaimer.
-;;
-;;     - Redistributions in binary form must reproduce the above copyright
-;;       notice, this list of conditions and the following disclaimer in
-;;       the documentation and/or other materials provided with the
-;;       distribution.
-;;
-;;     - Neither the name of The Numerical ALgorithms Group Ltd. nor the
-;;       names of its contributors may be used to endorse or promote products
-;;       derived from this software without specific prior written permission.
-;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
-;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
-;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
-;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
-;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
-;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
-;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
-;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
-;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-
-;; lisp support for creating domain stubs
-
-(in-package "BOOT")
-;;(SETQ |$optimizableConstructorNames| nil)
-
-(defstruct domain constructor args
-  (dollar (check-dollar-fields constructor args)))
-
-(defstruct (old-compiler-domain (:include domain) (:conc-name oldom-))
-  (devaluate (if dollar (|devaluate| dollar)
-               (CONS constructor (MAPCAR #'|devaluate| args))))
-  (vector nil))  
-
-(defun check-dollar-fields (constructor arglist)
-  (if (some #'(lambda (x) (and (domain-p x) (domain-dollar x))) arglist)
-      (apply constructor (mapcar #'(lambda (x) (if (domain-p x)
-                                                   (or (domain-dollar x) x)
-                                                 x)) arglist))
-    nil))
-
-(defun |domain?| (x) (domain-p x))
-
-(defun |Mapping| (&rest args)
-  (make-old-compiler-domain :constructor '|Mapping| :args args
-                            :vector '|Mapping0|))
-
-(defun |Record| (&rest args)
-  (make-old-compiler-domain :constructor '|Record| :args args
-                            :vector '|Record0|))
-
-(defun |Union| (&rest args)
-  (make-old-compiler-domain :constructor '|Union| :args args
-                            :vector '|Union0|))
-
-(defun |devaluate| (x &aux tag dom)
-  (cond ((REFVECP x)
-         (if (> (QVSIZE x) 5)
-             (cond ((equal (qvelt x 3) '(|Category|))
-                    (qvelt x 0))
-;; next line will become obsolete
-                   ((|isFunctor| (qvelt x 0)) (qvelt x 0))
-                   ((domain-p (qvelt x 0)) (|devaluate| (qvelt x 0)))
-                   (t x))
-             x))
-        ((and (pairp x) (eq (car x) '|:|) (dcq (tag dom) (cdr x)))
-         (list (car x) tag (|devaluate| dom)))
-; 20030527 note that domain-p does not exist
-        ((not (domain-p x)) x)
-; 20030527 note that old-compiler-domain-p does not exist
-        ((old-compiler-domain-p x) (oldom-devaluate x))
-        (t (error "devaluate of new compiler domain"))))
-
-(defun |domainEqual| (x y)
-  (cond ((old-compiler-domain-p x)
-         (if (old-compiler-domain-p y)
-             (equalp (oldom-devaluate x) (oldom-devaluate y))
-             nil))
-        ((old-compiler-domain-p y) nil)
-        (t (error "no new compiler domains yet"))))
-
-(defun |domainSelectDollar| (dom)
-  (or (domain-dollar dom) dom))
-
-(defun |domainSetDollar| (dom dollar)
-  (setf (domain-dollar dom) dollar)
-  (if (old-compiler-domain-p dom)
-      (setf (oldom-devaluate dom) (|devaluate| dollar))))
-
-(defun |domainSelectVector| (dom)
-  (let ((vec (oldom-vector dom)))
-    (cond ((vectorp vec) vec)
-          ((null vec) nil)
-          ((symbolp vec) ;; case for Records and Unions
-           (setq vec (funcall vec (domain-args dom)))
-           (setf (elt vec 0) dom)
-           (setf (oldom-vector dom) vec))
-          ((or (fboundp (car vec))
-               (|loadLib| (cdr vec)) t)
-           (instantiate (car vec) dom)))))
-
-;;(defun instantiate (innername dom) 
-;;  (let ((vec (apply innername (domain-args dom))))
-;;    (setelt vec 0 dom)
-;;    (setf (oldom-vector dom) vec)
-;;    vec))
-
-(defun instantiate (innername dom)
-  (let* ((infovec (get (domain-constructor dom) '|infovec|))
-         (|$dollarVec| (getrefv (size (car infovec )))))
-    (declare (special |$dollarVec|))
-    (setf (elt |$dollarVec| 0) dom)
-    (setf (elt |$dollarVec| 1)
-          (list (symbol-function (|getLookupFun| infovec))
-                |$dollarVec|
-                (elt infovec 1)))
-    (setf (elt |$dollarVec| 2) (elt infovec 2))
-    (setf (oldom-vector dom) |$dollarVec|)
-    (apply innername (domain-args dom))
-    |$dollarVec|))
-  
-(defun universal-domain-constructor (&rest args-env)
-  (let* ((args (fix-domain-args (butlast args-env)))
-         (env (car (last args-env))))
-    (check-constructor-cache env args)))
-
-(defun fix-domain-args (args)
-  (mapcar #'(lambda (x) (if (and (vectorp x) (domain-p (elt x 0)))
-                            (elt x 0) x)) args))
-
-(defun universal-nocache-domain-constructor (&rest args-env)
-  (let* ((args (butlast args-env))
-         (env (car (last args-env))))
-    (make-old-compiler-domain :constructor (car env)
-                              :args args
-                              :vector (cdr env))))
-
-(defun universal-category-defaults-constructor (&rest args-env)
-  (let* ((args (butlast args-env))
-         (env (car (last args-env))))
-    (make-old-compiler-domain :constructor (car env)
-                              :args args
-                              :dollar (car args)
-                              :vector (cdr env))))
-
-(defun cached-constructor (cname)
-  (if (or (|isCategoryPackageName| cname)
-          (and (boundp '|$mutableDomains|)
-               (memq cname |$mutableDomains|)))
-      nil
-    t))
-
-(defun |makeDomainStub| (con) 
-  (|systemDependentMkAutoload| (|constructor?| con) con))
-
-(defun |mkAutoLoad| (fn cname)
-  (cond ((or (memq cname |$CategoryNames|)
-          (eq (|getConstructorKindFromDB| cname) '|category|))
-         (function (lambda (&rest args)
-                     (|autoLoad| fn cname)
-                     (apply cname args))))
-        (t (|systemDependentMkAutoload| fn cname)
-           (symbol-function cname))))
-
-(defun |systemDependentMkAutoload| (fn cname)
-  (let* ((cnameInner (intern (strconc cname ";")))
-         (env (list* cname cnameInner fn))
-         (spadfun
-          (cond ((|isCategoryPackageName| cname)
-                 (cons #'universal-category-defaults-constructor env))
-                ((and (boundp '|$mutableDomains|)
-                      (memq cname |$mutableDomains|))
-                 (cons #'universal-nocache-domain-constructor env))
-                (t (cons #'universal-domain-constructor env)))))
-    (setf (symbol-function cname) (mkConstructor spadfun))
-    (set cname spadfun)))
-
-(defun mkConstructor (spadfun)
-   (function (lambda (&rest args)
-               (apply (car spadfun) (append args (list (cdr spadfun)))))))
-
-(defun |makeAddDomain| (add-domain dollar)
-  (cond ((old-compiler-domain-p add-domain)
-         (make-old-compiler-domain :constructor (domain-constructor add-domain)
-                            :args (domain-args add-domain)
-                            :dollar dollar
-                            :vector (cddr (eval (domain-constructor add-domain)))))
-        (t (error "no new compiler adds supported yet"))))
-
-(defun check-constructor-cache (env arglist)
-  (let ((dollar (check-dollar-fields (car env) arglist)))
-    (if dollar (make-old-compiler-domain :constructor (car env)
-                                         :args arglist
-                                         :dollar dollar
-                                         :vector (cdr env))
-      (let* ((constructor (car env))
-             (devargs (mapcar #'|devaluate| arglist))
-             (cacheddom
-              (|lassocShiftWithFunction| devargs
-               (HGET |$ConstructorCache| constructor)
-               #'|domainEqualList|)))
-        (if cacheddom (|CDRwithIncrement| cacheddom)
-          (cdr (|haddProp| |$ConstructorCache| constructor devargs
-                (cons 1 (make-old-compiler-domain :constructor constructor
-                                                  :args arglist
-                                                  :devaluate
-                                                  (cons constructor devargs)
-                                                  :vector (cdr env))))))))))
-
-
-
-
-          
-