1%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2%
3% File:         PK:SUPPORT.SL
4% Description:  Assorted support functions for the kernel.
5% Author:       Brian Beach, Hewlett-Packard CRC
6% Created:      22-Feb-84
7% Modified:     13-Nov-84 14:06:44 (Brian Beach)
8% Package:
9%
10% (c) Copyright 1987, University of Utah, all rights reserved.
11%
12%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
13%
14% Revisions:
15%
16% 05-APR-88 (Julian Padget)
17%  (Re)Incorporated simple definitions of INTERROGATE and MODIFY for
18%  use in booting - will be redefined by symbol-values.  Changed
19%  *DEFINE-CONSTANT to (wgetv symval <expr>)
20% 13-Nov-84 14:05:14 (Brian Beach)
21%  Added changes for PKG-FASL hack:  SUBSEQ function for strings, and
22%  SEARCH-STRING-FOR-CHARACTER.
23%
24%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
25
26(compiletime (load f-strings))
27
28(on fast-integers fast-strings)
29
30(de subseq (string lower-bound upper-bound)    % To be redefined
31
32  % This function is does not check bounds.  The parameters must satisfy the
33  % following conditions:
34  %
35  %    STRING must be a string
36  %    LOWER-BOUND and UPPER-BOUND must be integers:
37  %        0 <= LOWER-BOUND < UPPER-BOUND <= (string-length STRING)
38
39  (unless (stringp string)
40    (kernel-fatal-error (kernelstring2string "SUBSEQ called with a non-string"))
41    )
42
43  (let* ((new-size (- (- upper-bound lower-bound) 1))
44	 (old-pointer  (strinf string))
45	 (new-pointer  (gtstr new-size)))
46    (for (from i 0 new-size 1)
47	 (do (setf (strbyt new-pointer i) (strbyt old-pointer (+ lower-bound i))))
48	 )
49    (mkstr new-pointer)
50    ))
51
52(de search-string-for-character (char string)
53
54  (for (from i 0 (string-upper-bound string))
55       (do (when (eq char (string-fetch string i))
56	     (return i)))
57       (returns nil)   % when none found
58       ))
59
60(de unchecked-string-equal (u v)
61  % EqStr without typechecking or eq
62  (prog (len i)
63        (setq u (strinf u))
64        (setq v (strinf v))
65        (setq len (strlen u))
66        (when (wneq len (strlen v))
67          (return nil))
68        (setq i 0)
69   loop
70        (when (wgreaterp i len)
71          (return t))
72        (when (wneq (strbyt u i) (strbyt v i))
73          (return nil))
74        (setq i (wplus2 i 1))
75        (go loop)))
76
77
78(de copystringtofrom (new old)
79  % Copy all chars in Old to New
80  (prog (slen stripnew stripold)
81        (setq stripnew (strinf new))
82        (setq stripold (strinf old))
83        (setq slen (strlen stripold))
84        (when (wlessp (strlen stripnew) slen)
85          (setq slen (strlen stripnew)))
86        (setq slen (strpack slen))
87        (for (from i 0 slen 1)
88	     (do (setf (vecitm stripnew i) (vecitm stripold i))))
89        (return new)))
90
91(de cons (a b)
92  (let ((ptr (gtheap (pairpack))))
93    (setf (wgetv ptr 0) a)
94    (setf (wgetv ptr 1) b)
95    (mkpair ptr)
96    ))
97
98(de interrogate (index) (wgetv symval index))
99
100(de modify (index val) (setf (wgetv symval index) val))
101
102(de put (u indicator val)   % To be redefined.
103  (unchecked-put u indicator val)
104  )
105
106(de unchecked-put (id indicator value)
107  % Put a property on the property list of ID.
108  (let* ((property-list   (unchecked-prop id))
109	 (old-element     (atsoc indicator property-list)))
110    (if old-element
111      (rplacd old-element value)
112      (unchecked-setprop id (cons (cons indicator value) property-list))
113      )
114    value
115    ))
116
117(de atsoc (u v)
118  % EQ version of ASSOC
119  (cond ((not (pairp v)) nil)
120        ((and (pairp (car v)) (eq u (caar v))) (car v))
121        (t (atsoc u (cdr v)))))
122
123(de unchecked-setprop (u l)
124  % Store L as property list of U
125  (setf (symprp (idinf u)) l)
126  )
127
128
129(de unchecked-prop (u)
130  % Access property list of U
131  (symprp (idinf u))
132  )
133
134(de putd (fnname fntype fnexp)    % To be redefined
135  (code-putd fnname fntype fnexp)
136  )
137
138(de code-putd (fnname fntype fnexp)
139  % A simplified version of PUTD for the small FASLIN.
140  % It is assumed that all functions defined will be already compiled.
141
142  (unless (and (idp fnname)
143	       (idp fntype)
144	       (codep fnexp))
145    (unixputn fnname) (console-newline)
146    (unixputn fntype) (console-newline)   (unixputn fnexp) (console-newline)
147    (kernel-fatal-error (kernelstring2string "Bad parameters to CODE-PUTD"))
148    )
149  (console-print-string " Function :")
150   (console-print-string (symnam (inf fnname)))
151  (console-print-string " ")
152  (console-print-number (inf fnexp)) (console-newline)
153  (plantcodepointer (idinf fnname) (codeinf fnexp))
154  (unless (eq fntype 'expr)
155    (put fnname 'type fntype)
156    ))
157
158(de fluid (list)
159  (for (in id list)
160       (do (fluid1 id))
161       ))
162
163(de fluid1 (id)
164  (put id 'vartype 'fluid)
165  )
166
167(de stderror (x)   % To be redefined
168  (kernel-fatal-error x)
169  )
170
171(de *define-constant (name value)    % to be redefined
172  (setf (wgetv symval (idinf name)) value)
173  (put name 'constant? t)
174  )
175
176(off fast-integers)
177
178% End of file.
179