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