1;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. 2;; All rights reserved. 3;; 4;; Redistribution and use in source and binary forms, with or without 5;; modification, are permitted provided that the following conditions are 6;; met: 7;; 8;; - Redistributions of source code must retain the above copyright 9;; notice, this list of conditions and the following disclaimer. 10;; 11;; - Redistributions in binary form must reproduce the above copyright 12;; notice, this list of conditions and the following disclaimer in 13;; the documentation and/or other materials provided with the 14;; distribution. 15;; 16;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the 17;; names of its contributors may be used to endorse or promote products 18;; derived from this software without specific prior written permission. 19;; 20;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS 21;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED 22;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A 23;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER 24;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 25;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 26;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 27;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 28;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 29;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 30;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 32 33; NAME: Scratchpad Package 34; PURPOSE: This is an initialization and system-building file for Scratchpad. 35 36(in-package "BOOT") 37 38;;; Common Block 39 40(defvar |$UserLevel| '|development|) 41(defvar |$reportInstantiations| nil) 42(defvar |$reportEachInstantiation| nil) 43(defvar |$reportCounts| nil) 44(defvar |$doNotCompileJustPrint| nil "switch for compile") 45(defvar |$PrintCompilerMessageIfTrue| t) 46(defvar |$Rep| '|$Rep| "should be bound to gensym? checked in coerce") 47(defvar |$scanIfTrue| nil "if t continue compiling after errors") 48(defvar |$Representation| nil "checked in compNoStacking") 49(defvar |$definition| nil "checked in DomainSubstitutionFunction") 50(defvar |$env| nil "checked in isDomainValuedVariable") 51(defvar |$e| nil "checked in isDomainValuedVariable") 52(defvar |$getPutTrace| nil) 53 54;************************************************************************ 55; SYSTEM COMMANDS 56;************************************************************************ 57 58(defun |fin| () 59 (SETQ *EOF* 'T) 60 (THROW 'SPAD_READER NIL)) 61 62(defun QUOTIENT2 (X Y) (values (TRUNCATE X Y))) 63 64(defun INTEXQUO(X Y) 65 (multiple-value-bind (quo remv) (TRUNCATE X Y) 66 (if (= 0 remv) quo nil))) 67 68(defun DIVIDE2 (X Y) (multiple-value-call #'cons (TRUNCATE X Y))) 69 70(defun |makeSF| (mantissa exponent) 71 (FLOAT (/ mantissa (expt 2 (- exponent))) 0.0d0)) 72 73;; This is used in the domain Boolean 74(defun |BooleanEquality| (x y) (if x y (null y))) 75 76(MAKEPROP 'END_UNIT 'KEY T) 77 78;;; (defun |evalSharpOne| (x \#1) (declare (special \#1)) (EVAL x)) 79(defun |evalSharpOne| (x |#1|) 80 (declare (special |#1|)) 81 (EVAL `(let () (declare (special |#1|)) ,x))) 82 83(DEFUN ASSOCIATER (FN LST) 84 (COND ((NULL LST) NIL) 85 ((NULL (CDR LST)) (CAR LST)) 86 ((LIST FN (CAR LST) (ASSOCIATER FN (CDR LST)))))) 87 88; **** X. Random tables 89 90(MAKEPROP 'TAG '|Led| '(TAG TAG 122 121)) 91(MAKEPROP 'EQUATNUM '|Nud| '(|dummy| |dummy| 0 0)) 92(MAKEPROP 'EQUATNUM '|Led| '(|dummy| |dummy| 10000 0)) 93(MAKEPROP 'LET '|Led| '(|:=| LET 125 124)) 94(MAKEPROP 'SEGMENT '|Led| '(\.\. SEGMENT 401 699 (|boot-Seg|))) 95(MAKEPROP 'SEGMENT '|isSuffix| 'T) 96 97;; function to create byte and half-word vectors in new runtime system 8/90 98 99(defun |makeByteWordVec2| (maxelement initialvalue) 100 (let ((n (cond ((null initialvalue) 7) ('t maxelement)))) 101 (make-array (length initialvalue) 102 :element-type (list 'mod (1+ n)) 103 :initial-contents initialvalue))) 104 105(defun |knownEqualPred| (dom) 106 (let ((fun (|compiledLookup| '= '((|Boolean|) $ $) dom))) 107 (if fun (get (bpiname (car fun)) '|SPADreplace|) 108 nil))) 109 110(defun |hashable| (dom) 111 (memq (|knownEqualPred| dom) 112 #-Lucid '(EQ EQL EQUAL) 113 #+Lucid '(EQ EQL EQUAL EQUALP) 114 )) 115