diff options
Diffstat (limited to 'src/interp/domain.lisp')
| -rw-r--r-- | src/interp/domain.lisp | 227 |
1 files changed, 227 insertions, 0 deletions
diff --git a/src/interp/domain.lisp b/src/interp/domain.lisp new file mode 100644 index 00000000..952b3a5e --- /dev/null +++ b/src/interp/domain.lisp @@ -0,0 +1,227 @@ +;; 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 (GETDATABSE cname 'CONSTRUCTORKIND) '|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)))))))))) + + + + + + |