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