source: trunk/ccl/level-1/l1-utils.lisp @ 492

Last change on this file since 492 was 492, checked in by gb, 16 years ago

%GET-DOUBLE-FLOAT/%SET-DOUBLE-FLOAT were shadowed by later versions.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 46.5 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17
18
19; L1-utils.lisp
20
21
22#+allow-in-package
23(in-package "CCL")
24
25;The following forms (up thru defn of %DEFUN) must come before any DEFUN's.
26;Any (non-kernel) functions must be defined before they're used!
27;In fact, ALL functions must be defined before they're used!  How about that ?
28
29
30
31(setq %lisp-system-fixups% nil)
32
33(setq *lfun-names* (make-hash-table :test 'eq :weak t))
34
35
36
37(setq *warn-if-redefine-kernel* nil)
38
39(setq *warn-if-redefine* nil)
40(setq *record-source-file* t)
41
42; Kluge for record-source-file bootstrapping
43
44; Set T by l1-boot.lisp
45(setq *level-1-loaded* nil)
46
47(%fhave 'full-pathname (qlfun bootstrapping-full-pathname (name) name))
48
49(%fhave '%source-files (qlfun bootstrapping-%source-files (name)
50                         (get name 'bootstrapping-source-files)))
51(%fhave '%set-source-files (qlfun bootstrapping-%set-source-files (name value)
52                             (put name 'bootstrapping-source-files value)))
53
54
55
56
57
58; real one is  in setf.lisp
59(%fhave '%setf-method (qlfun bootstripping-setf-fsname (spec)
60                                   spec nil))
61
62; this new thing breaks for case of a function being defined in non-file place
63; use some euphemism for that such as t or "{No file}"
64; something is broken (probably) here calling assq with garbage
65
66(defun source-file-or-files (symbol type setf-p method)
67  (let ((source-files-info (%source-files symbol))   
68        assoc-pair files)
69    (cond ((null (consp source-files-info))
70           (values source-files-info
71                   nil
72                   (if (and source-files-info (eq type 'function)(not setf-p)) source-files-info)))
73          (t (setq assoc-pair (assq type (if setf-p
74                                           (cdr (assq 'setf source-files-info))
75                                           source-files-info)))
76             (if (neq type 'method)
77               (setq files assoc-pair)
78               (setq files
79                     (do* ((lst (cdr assoc-pair) (cdr lst))
80                           (clst (car lst)(car lst)))
81                          ((null lst) nil)
82                       (when (consp clst)
83                         (when (or (eq method (car clst))  ; method is a place holder for q's and s's
84                                   (and (methods-congruent-p method (car clst))
85                                        ; below avoids clutter
86                                        (rplaca clst method)))
87                           (return clst))))))
88             (values source-files-info assoc-pair files)))))
89
90; warn if defining in no file iff previously defined in a file (i.e. dont
91; warn every time something gets redefined in the listener)
92; fix to not to bitch if file is anywhere in list
93; name is function-name or (method-name (class-names)) or ((setf method-name) (class-names))
94; store('method (method file  file) (method file file) ...)
95; if type is 'method we expect name to be an actual method
96; Remember to smash old methods with newer methods to avoid clutter - done
97
98(defun physical-pathname-p (file)(declare (ignore file)) nil) ; redefined later
99
100
101;(%defvar *enqueued-window-title* nil)
102
103(defun booted-probe-file (file)
104  (declare (ignore file))
105  nil)
106
107(queue-fixup
108 (defun booted-probe-file (file)
109   (probe-file file)))
110
111(defun record-source-file (name def-type
112                                &optional (file-name *loading-file-source-file*)) 
113  (let (symbol setf-p method old-file)
114    (flet ((same-file (x y)
115             (or (eq x y)
116                 ;; funny because equal not defined before us
117                 (and x
118                      y
119                      (or (equal x y)
120                          (equal
121                           (or (booted-probe-file x) (full-pathname x))
122                           (or (booted-probe-file y) (full-pathname y))))))))
123      (when (and *record-source-file* ) ;file-name)
124        (when (and file-name (physical-pathname-p file-name))
125          (setq file-name (namestring (back-translate-pathname file-name)))
126          (cond ((equalp file-name *last-back-translated-name*)
127                 (setq file-name *last-back-translated-name*))
128                (t (setq *last-back-translated-name* file-name))))
129        (when (eq t def-type) (report-bad-arg def-type '(not (eql t))))
130        (cond ((eq def-type 'method)
131               (setq method name symbol (%method-name name) name nil))
132              ((consp name)
133               (cond ((neq (car name) 'setf)
134                      (warn "record-source-file hates ~s" name))
135                     (t (setq symbol name))))
136              ((symbolp name) (setq symbol name)))
137        (cond ((and (consp symbol)(eq (car symbol) 'setf))
138               (let ((tem (%setf-method (cadr symbol))))
139                 (if tem 
140                   (setq symbol tem)
141                   (progn (setq symbol (cadr symbol))
142                          (setq setf-p t))))))
143        ;; assoc-pair is e.g. (function file1 ...)  or (class . file)
144        ;; or (method (method-object file1 ...) ...) or (method
145        ;; (method-object . file) ...)
146        (when (symbolp symbol)          ; avoid boot problems - you thought
147          (multiple-value-bind (source-files-info assoc-pair files)
148              (source-file-or-files symbol def-type setf-p method) 
149            (setq old-file 
150                  (cond ((consp files)
151                         (if (consp (cdr files)) (cadr files) (cdr files)))
152                        (t files)))
153            (unless
154                (if (or (not (consp files))(not (consp (cdr files))))
155                  (same-file old-file file-name)
156                  (do ((lst (cdr files)(cdr lst)))
157                      ((null (consp lst)) nil) 
158                    (when (same-file file-name (car lst))
159                      (rplaca lst (cadr files))
160                      (rplaca (cdr files) file-name)
161                      (return t))))
162              (when (and *warn-if-redefine*
163                         (neq def-type 'method) ; This should be more specific
164                         (cond ((eq def-type 'function)
165                                (and (fboundp name) old-file))
166                               (t old-file)))
167                (warn " ~S ~S previously defined in: ~A
168         is now being redefined in: ~A~%"
169                      def-type
170                      name
171                      (or old-file "{Not Recorded}")
172                      (or file-name "{No file}")))
173              (if (consp files)
174                (%rplacd files (cons file-name 
175                                     (if (consp (cdr files))(cdr files)(list (cdr files)))))
176               
177                (if assoc-pair
178                  (%rplacd assoc-pair (cons (if (eq def-type 'method)
179                                              `(,method . , file-name)
180                                              file-name)
181                                            (if (consp (%cdr assoc-pair))
182                                              (%cdr assoc-pair)
183                                              (list (%cdr assoc-pair)))))
184                  (%set-source-files
185                   symbol
186                   (cond ((and (eq def-type 'function)
187                               (null setf-p)
188                               (not (consp  source-files-info)))
189                          (if (null old-file)
190                            file-name
191                            `((function ,file-name ,old-file))))
192                         (t
193                          (when (and source-files-info
194                                     (not (consp source-files-info)))
195                            (setq source-files-info `((function . , source-files-info))))
196                          (let ((thing (if (neq def-type 'method) 
197                                         `(,def-type . ,file-name)
198                                         `(,def-type (,method . ,file-name)))))
199                            (cons (if setf-p `(setf ,thing) thing) source-files-info))))))))
200            ))))))
201
202(record-source-file 'record-source-file 'function)
203
204(defun inherit-from-p (ob parent)
205  (memq (if (symbolp parent) (find-class parent nil) parent)
206        (%inited-class-cpl (class-of ob))))
207
208;;; returns new plist with value spliced in or key, value consed on.
209(defun setprop (plist key value &aux loc)
210  (if (setq loc (pl-search plist key))
211    (progn (%rplaca (%cdr loc) value) plist)
212    (cons key (cons value plist))))
213
214(defun getf-test (place indicator test &optional default)
215  (loop
216    (when (null place)
217      (return default))
218    (when (funcall test indicator (car place))
219      (return (cadr place)))
220    (setq place (cddr place))))
221
222(defun setprop-test (plist indicator test value)
223  (let ((tail plist))
224    (loop
225      (when (null tail)
226        (return (cons indicator (cons value plist))))
227      (when (funcall test indicator (car tail))
228        (setf (cadr tail) value)
229        (return plist))
230      (setq tail (cddr tail)))))
231
232(defun plistp (p &aux len)
233  (and (listp p)
234       (setq len (list-length p))
235       (not (%ilogbitp 0 len))))  ; (evenp p)
236
237(defun %imax (i1 i2)
238 (if (%i> i1 i2) i1 i2))
239
240(defun %imin (i1 i2)
241  (if (%i< i1 i2) i1 i2))
242
243
244
245
246;|#
247
248
249(eval-when (:compile-toplevel :execute)
250  (defmacro need-use-eql-macro (key)
251    `(let* ((typecode (typecode ,key)))
252       (declare (fixnum typecode))
253       (or (= typecode ppc32::subtag-macptr)
254           (and (>= typecode ppc32::min-numeric-subtag)
255                (<= typecode ppc32::max-numeric-subtag)))))
256  (require "NUMBER-MACROS")
257)
258
259
260
261
262
263
264(defun loading-file-source-file ()
265  *loading-file-source-file*)
266
267(setq *save-local-symbols* t)
268
269(%fhave 'require-type (nfunction bootstrapping-require-type
270                                 (lambda (thing type)
271                                   (declare (ignore type))
272                                   thing)))
273(%fhave '%require-type 
274        (nfunction bootstrapping-%require-type
275                   (lambda (thing predicate)
276                     (declare (ignore predicate))
277                     thing)))
278
279(setf (type-predicate 'macptr) 'macptrp)
280
281
282
283
284
285
286(defun %pop-required-arg-ptr (ptr)
287  (if (atom (destructure-state.current ptr))
288    (signal-program-error "Required arguments in ~s don't match lambda list ~s."
289           (destructure-state.whole ptr) (destructure-state.lambda ptr))
290    (pop (destructure-state.current ptr))))
291
292(defun %default-optional-value (ptr &optional default)
293  (let* ((tail (destructure-state.current ptr)))
294    (if tail
295      (if (atom tail)
296        (signal-program-error "Optional arguments in ~s don't match lambda list ~s."
297               (destructure-state.whole ptr) (destructure-state.lambda ptr))
298        (pop (destructure-state.current ptr)))
299      default)))
300
301(defun %check-extra-arguments (ptr)
302  (when (destructure-state.current ptr)
303    (signal-program-error "Extra arguments in ~s don't match lambda list ~s."
304                          (destructure-state.whole ptr) (destructure-state.lambda ptr))))
305
306(defun %keyword-present-p (keys keyword)
307  (let* ((not-there (cons nil nil)))
308    (declare (dynamic-extent not-there))
309    (not (eq (getf keys keyword not-there) not-there))))
310
311(defun check-keywords (keys actual allow-others)
312  (let* ((len (ignore-errors (list-length actual))))
313    (if (null len)
314      (signal-simple-program-error "Circular or dotted keyword list: ~s" actual)
315      (if (oddp len)
316        (signal-simple-program-error "Odd length keyword list: ~s" actual))))
317  (setq allow-others (or allow-others (getf actual :allow-other-keys)))
318  (do* ((a actual (cddr a))
319        (k (car a) (car a)))
320       ((null a))
321    (unless (typep k 'symbol)
322      (signal-simple-program-error
323       "Invalid keyword argument ~s in ~s.  ~&Valid keyword arguments are ~s." k actual keys))
324    (unless (or allow-others
325                (eq k :allow-other-keys)
326                (member k keys))
327      (signal-simple-program-error "Unknown keyword argument ~s in ~s.  ~&Valid keyword arguments are ~s." k actual keys))))
328
329(%fhave 'set-macro-function #'%macro-have)   ; redefined in sysutils.
330
331; Define special forms.
332(dolist (sym '(block catch compiler-let eval-when
333               flet function go if labels let let* macrolet
334               multiple-value-call multiple-value-prog1
335               progn progv quote return-from setq tagbody
336               the throw unwind-protect locally load-time-value
337               symbol-macrolet
338; These are implementation-specific special forms :
339               nfunction
340               %vreflet ppc-lap-function sparc-lap-function fbind))
341  (%macro-have sym sym))
342
343
344
345(locally (declare (special *fred-special-indent-alist*))
346   (setq *fred-special-indent-alist* nil))
347 
348(defun %macro (named-fn &optional doc &aux body-pos arglist)
349  ; "doc" is either a string or a list of the form :
350  ; (doc-string-or-nil . (body-pos-or-nil . arglist-or-nil))
351  (if (listp doc)
352    (setq body-pos (cadr doc)
353          arglist (cddr doc)
354          doc (car doc)))
355  (let* ((name (function-name named-fn)))
356    (record-source-file name 'function)
357    (set-macro-function name named-fn)
358    (when (and doc *save-doc-strings*)
359      (set-documentation name 'function doc))
360    (when body-pos
361      (setf (assq name *fred-special-indent-alist*) body-pos))
362    (when arglist
363      (record-arglist name arglist))
364    (when *fasload-print* (format t "~&~S~%" name))
365    name))
366
367
368(defun %defvar (var &optional doc)
369  "Returns boundp"
370  (%proclaim-special var)
371  (record-source-file var 'variable)
372  (when (and doc *save-doc-strings*)
373    (set-documentation var 'variable doc))
374  (cond ((not (boundp var))
375         (when *fasload-print* (format t "~&~S~%" var))
376         nil)
377        (t t)))
378
379(defun %defparameter (var value &optional doc)
380  (%proclaim-special var)
381  (record-source-file var 'variable)
382  (when (and doc *save-doc-strings*)
383    (set-documentation var 'variable doc))
384  (when *fasload-print* (format t "~&~S~%" var))
385  (set var value)
386  var)
387
388(defun %defglobal (var value &optional doc)
389  (%symbol-bits var (logior (ash 1 $sym_vbit_global) (the fixnum (%symbol-bits var))))
390  (%defparameter var value doc))
391
392;Needed early for member etc.
393(defun identity (x) x)
394
395(%fhave 'find-unencapsulated-definition #'identity)
396
397(defun coerce-to-function (arg)
398  (if (functionp arg)
399    arg
400    (if (symbolp arg)
401      (%function arg)
402      (report-bad-arg arg 'function))))
403
404; takes arguments in arg_x, arg_y, arg_z, returns "multiple values"
405; Test(-not) arguments are NOT validated beyond what is done
406; here.
407; if both :test and :test-not supplied, signal error.
408; if test provided as #'eq or 'eq, return first value 'eq.
409; if test defaulted, provided as 'eql, or provided as #'eql, return first value 'eql.
410; if test-not provided as 'eql or provided as #'eql, return second value 'eql.
411; if key provided as either 'identity or #'identity, return third value nil.
412(defun %key-conflict (test-fn test-not-fn key)
413  (let* ((eqfn #'eq)
414         (eqlfn #'eql)
415         (idfn #'identity))
416    (if (or (eq key 'identity) (eq key idfn))
417      (setq key nil))
418    (if test-fn
419      (if test-not-fn
420        (%err-disp $xkeyconflict ':test test-fn ':test-not test-not-fn)
421        (if (eq test-fn eqfn)
422          (values 'eq nil key)
423          (if (eq test-fn eqlfn)
424            (values 'eql nil key)
425            (values test-fn nil key))))
426      (if test-not-fn
427        (if (eq test-not-fn eqfn)
428          (values nil 'eq key)
429          (if (eq test-not-fn eqlfn)
430            (values nil 'eql key)
431            (values nil test-not-fn key)))
432        (values 'eql nil key)))))
433
434
435
436
437;;; Assoc.
438
439; (asseql item list) <=> (assoc item list :test #'eql :key #'identity)
440
441(defun asseql (item list)
442  (if (need-use-eql-macro item)
443    (dolist (pair list)
444      (if pair
445        (if (eql item (car pair))
446          (return pair))))
447    (assq item list)))
448
449; (assoc-test item list test-fn)
450;   <=>
451;     (assoc item list :test test-fn :key #'identity)
452; test-fn may not be FUNCTIONP, so we coerce it here.
453(defun assoc-test (item list test-fn)
454  (dolist (pair list)
455    (if pair
456      (if (funcall test-fn item (car pair))
457        (return pair)))))
458
459
460
461; (assoc-test-not item list test-not-fn)
462;   <=>
463;     (assoc item list :test-not test-not-fn :key #'identity)
464; test-not-fn may not be FUNCTIONP, so we coerce it here.
465(defun assoc-test-not (item list test-not-fn)
466  (dolist (pair list)
467    (if pair
468      (if (not (funcall test-not-fn item (car pair)))
469        (return pair)))))
470
471(defun assoc (item list &key test test-not key)
472  (multiple-value-bind (test test-not key) (%key-conflict test test-not key)
473    (if (null key)
474      (if (eq test 'eq)
475        (assq item list)
476        (if (eq test 'eql)
477          (asseql item list)
478          (if test
479            (assoc-test item list test)
480            (assoc-test-not item list test-not))))
481      (if test
482        (dolist (pair list)
483          (if pair
484            (if (funcall test item (funcall key (car pair)))
485              (return pair))))
486        (dolist (pair list)
487          (if pair
488            (unless (funcall test-not item (funcall key (car pair)))
489              (return pair))))))))
490
491
492;;;; Member.
493
494; (memeql item list) <=> (member item list :test #'eql :key #'identity)
495
496;nil or error - supposed to error if not proper list?
497(defun memeql (item list)
498  (if (need-use-eql-macro item)
499    (do* ((l list (%cdr l)))
500         ((endp l))
501      (when (eql (%car l) item) (return l)))
502    (memq item list))
503)
504
505; (member-test item list test-fn)
506;   <=>
507;     (member item list :test test-fn :key #'identity)
508(defun member-test (item list test-fn)
509  (if (or (eq test-fn 'eq)(eq test-fn  #'eq)
510          (and (or (eq test-fn 'eql)(eq test-fn  #'eql))
511               (not (need-use-eql-macro item))))
512    (do* ((l list (cdr l)))
513         ((null l))
514      (when (eq item (car l))(return l)))
515    (if (or (eq test-fn 'eql)(eq test-fn  #'eql))
516      (do* ((l list (cdr l)))
517           ((null l))
518        (when (eql item (car l))(return l)))   
519      (do* ((l list (cdr l)))
520           ((null l))
521        (when (funcall test-fn item (car l)) (return l))))))
522
523
524; (member-test-not item list test-not-fn)
525;   <=>
526;     (member item list :test-not test-not-fn :key #'identity)
527(defun member-test-not (item list test-not-fn)
528  (do* ((l list (cdr l)))
529       ((endp l))
530    (unless (funcall test-not-fn item (%car l)) (return l))))
531
532(defun member (item list &key test test-not key)
533  (multiple-value-bind (test test-not key) (%key-conflict test test-not key)
534    (if (null key)
535      (if (eq test 'eq)
536        (memq item list)
537        (if (eq test 'eql)
538          (memeql item list)
539          (if test
540            (member-test item list test)
541            (member-test-not item list test-not))))
542      (if test
543        (do* ((l list (cdr l)))
544             ((endp l))
545          (if (funcall test item (funcall key (car l)))
546              (return l)))
547        (do* ((l list (cdr l)))
548             ((null l))
549          (unless (funcall test-not item (funcall key (car l)))
550              (return l)))))))
551
552(defun adjoin (item list &key test test-not key)
553  (if (and (not test)(not test-not)(not key))
554    (if (not (memeql item list))(cons item list) list)
555    (multiple-value-bind (test test-not key) (%key-conflict test test-not key)
556      (if
557        (if (null key)
558          (if (eq test 'eq)
559            (memq item list)
560            (if (eq test 'eql)
561              (memeql item list)
562              (if test
563                (member-test item list test)
564                (member-test-not item list test-not))))
565          (if test
566            (member (funcall key item) list :test test :key key)
567            (member (funcall key item) list :test-not test-not :key key)))
568        list
569        (cons item list)))))
570
571(defun adjoin-eq (elt list)
572  (if (memq elt list)
573    list
574    (cons elt list)))
575
576(defun adjoin-eql (elt list)
577  (if (memeql elt list)
578    list
579    (cons elt list)))
580
581(defun union-eq (list1 list2)
582  (let ((res list2))
583    (dolist (elt list1)
584      (unless (memq elt res)
585        (push elt res)))
586    res))
587
588(defun union-eql (list1 list2)
589  (let ((res list2))
590    (dolist (elt list1)
591      (unless (memeql elt res)
592        (push elt res)))
593    res))
594
595; Fix this someday.  Fix EQUALP, while you're at it ...
596(defun similar-as-constants-p (x y)
597  (or (eq x y)                          ; Redefinition of constants to themselves.
598      (if (and (stringp x) (stringp y)) ;The most obvious case where equalp & s-a-c-p need to differ...
599        (string= x y)
600        (equalp x y))))
601
602(defun undefine-constant (var)
603  (%set-sym-global-value var (%unbound-marker-8)))
604
605(defun define-constant (var value)
606  (block nil
607    (if (constant-symbol-p var)
608      (let* ((old-value (%sym-global-value var)))
609        (unless (eq old-value (%unbound-marker-8))
610          (if (similar-as-constants-p (%sym-global-value var) value)
611            (return)
612            ;; This should really be a cell error, allow options other than
613            ;; redefining (such as don't redefine and continue)...
614            (cerror "Redefine ~S anyway"
615                    "Constant ~S is already defined with a different value"
616                    var)))))
617    (%symbol-bits var 
618                  (%ilogior (%ilsl $sym_bit_special 1) (%ilsl $sym_bit_const 1)
619                            (%symbol-bits var)))
620    (%set-sym-global-value var value))
621  var)
622
623(defun %defconstant (var value &optional doc)
624  (%proclaim-special var)
625  (record-source-file var 'constant)
626  (define-constant var value)
627  (when (and doc *save-doc-strings*)
628    (set-documentation var 'variable doc))
629  (when *fasload-print* (format t "~&~S~%" var))
630  var)
631
632(defparameter *nx1-compiler-special-forms* ())
633(defparameter *nx-proclaimed-types* ())
634(defparameter *nx-proclaimed-ftypes* nil)
635
636(defun compiler-special-form-p (sym)
637  (or (eq sym 'quote)
638      (if (memq sym *nx1-compiler-special-forms*) t)))
639
640(defun evaluator-special-form-p (sym)
641  (declare (ignore sym))
642 '(get sym 'special-in-evaluator)
643 nil)
644
645(defparameter *nx-known-declarations* ())
646(defparameter *nx-proclaimed-inline* ())
647(defparameter *nx-proclaimed-ignore* ())
648(defparameter *nx-globally-inline* ())
649
650
651
652(defconstant *cl-types* '(
653array
654atom
655base-char
656bignum
657bit
658bit-vector 
659character
660#|
661lisp:common
662|#
663compiled-function 
664complex 
665cons                   
666double-float
667extended-char
668fixnum
669float
670function
671hash-table
672integer
673keyword
674list 
675long-float
676nil 
677null
678number 
679package
680pathname 
681random-state 
682ratio
683rational
684readtable
685real
686sequence 
687short-float
688signed-byte 
689simple-array
690simple-bit-vector
691simple-string 
692simple-base-string
693simple-extended-string 
694simple-vector 
695single-float
696standard-char
697stream 
698string
699#|
700lisp:string-char
701|#
702symbol
703t
704unsigned-byte 
705vector
706))
707
708(defun proclaim (spec)
709  (case (car spec)
710    (special (apply #'proclaim-special (%cdr spec)))
711    (notspecial (apply #'proclaim-notspecial (%cdr spec)))
712    (optimize (%proclaim-optimize (%cdr spec)))
713    (inline (apply #'proclaim-inline t (%cdr spec)))
714    (notinline (apply #'proclaim-inline nil (%cdr spec)))
715    (declaration (apply #'proclaim-declaration (%cdr spec)))
716    (ignore (apply #'proclaim-ignore t (%cdr spec)))
717    (unignore (apply #'proclaim-ignore nil (%cdr spec)))
718    (type (apply #'proclaim-type (%cdr spec)))
719    (ftype (apply #'proclaim-ftype (%cdr spec)))
720    ;(function (proclaim-ftype (cons 'function (cddr spec)) (cadr spec)))
721    (t (unless (memq (%car spec) *nx-known-declarations*) ;not really right...
722         (if (memq (%car spec) *cl-types*)
723           (apply #'proclaim-type spec)
724           (warn "Unknown declaration specifier(s) in ~S" spec))))))
725
726(defun proclaim-type (type &rest vars)
727  (declare (dynamic-extent vars))
728  (dolist (var vars)
729    (if (symbolp var)
730      (let ((spec (assq var *nx-proclaimed-types*)))
731        (if spec
732          (rplacd spec type)
733          (push (cons var type) *nx-proclaimed-types*)))
734      (warn "Invalid type declaration for ~S" var))))
735
736#| redefined from nfcomp
737(defun proclaim-ftype (type &rest names)
738  (declare (ignore type names))
739  ;remember to accept (setf name)'s when implement this.
740  nil)
741|#
742
743(defun proclaim-ftype (ftype &rest names)
744  (declare (dynamic-extent names))
745  (unless *nx-proclaimed-ftypes*
746    (setq *nx-proclaimed-ftypes* (make-hash-table :test #'eq)))
747  (dolist (name names)
748    (setf (gethash (ensure-valid-function-name name) *nx-proclaimed-ftypes*) ftype)))
749
750(defun proclaimed-ftype (name)
751  (when *nx-proclaimed-ftypes*
752    (gethash (ensure-valid-function-name name) *nx-proclaimed-ftypes*)))
753
754(defun proclaim-special (&rest vars)
755  (declare (dynamic-extent vars))
756  (dolist (sym vars) (%proclaim-special sym)))
757
758(defun proclaim-notspecial (&rest vars)
759  (declare (dynamic-extent vars))
760  (dolist (sym vars) (%proclaim-notspecial sym)))
761
762(defun proclaim-inline (t-or-nil &rest names)
763  (declare (dynamic-extent names))
764  ;This is just to make it more likely to detect forgetting about the first arg...
765  (unless (or (eq nil t-or-nil) (eq t t-or-nil)) (report-bad-arg t-or-nil '(member t nil)))
766  (dolist (name names)
767    (setq name (ensure-valid-function-name name))
768    (if (listp *nx-proclaimed-inline*)
769      (setq *nx-proclaimed-inline*
770          (alist-adjoin name
771                        (or t-or-nil (if (compiler-special-form-p name) t))
772                        *nx-proclaimed-inline*))     
773      (setf (gethash name *nx-proclaimed-inline*)
774            (or t-or-nil (if (compiler-special-form-p name) t))))))
775
776(defun proclaim-declaration (&rest syms)
777  (declare (dynamic-extent syms))
778  (dolist (sym syms)
779    (setq *nx-known-declarations* 
780          (adjoin sym *nx-known-declarations* :test 'eq))))
781
782(defun proclaim-ignore (t-or-nil &rest syms)
783  (declare (dynamic-extent syms))
784  ;This is just to make it more likely to detect forgetting about the first arg...
785  (unless (or (eq nil t-or-nil) (eq t t-or-nil)) (report-bad-arg t-or-nil '(member t nil)))
786  (dolist (sym syms)
787    (setq *nx-proclaimed-ignore*
788          (alist-adjoin sym t-or-nil *nx-proclaimed-ignore*))))
789
790(queue-fixup
791 (when (listp *nx-proclaimed-inline*)
792  (let ((table (make-hash-table :size 100 :test #'eq)))
793    (dolist (x *nx-proclaimed-inline*)
794      (let ((name (car x)) (value (cdr x)))
795        (when (symbolp name)
796          (setf (gethash name table) value))))
797    (setq *nx-proclaimed-inline* table))))
798
799(defun proclaimed-special-p (sym)
800  (%ilogbitp $sym_vbit_special (%symbol-bits sym)))
801
802(defun proclaimed-inline-p (sym)
803  (if (listp *nx-proclaimed-inline*)
804    (%cdr (assq sym *nx-proclaimed-inline*))
805    (gethash sym *nx-proclaimed-inline*)))
806
807(defun proclaimed-notinline-p (sym)
808  (if (listp *nx-proclaimed-inline*)
809    (and (setq sym (assq sym *nx-proclaimed-inline*))
810         (null (%cdr sym)))
811    (null (gethash sym *nx-proclaimed-inline* t))))
812
813
814
815(defun self-evaluating-p (form)
816;   (or (numberp form)
817;       (characterp form)
818;       (null form)
819;       (eq form t)
820;       (keywordp form)
821;       (arrayp form) ; making the following redundant
822;       ;(stringp form)
823;       ;(bit-vector-p form)
824;       )
825  (and (atom form)
826       (or (not (non-nil-symbol-p form))
827           (eq form t)
828           (keywordp form)))
829  )
830
831(defun constantp (form &optional env)
832   (or (self-evaluating-p form)
833       (quoted-form-p form)
834       (constant-symbol-p form)
835       (and env
836            (symbolp form)
837            (eq :constant (variable-information form env)))))
838
839(defun eval-constant (form)
840  (if (quoted-form-p form) (%cadr form)
841    (if (constant-symbol-p form) (symbol-value form)
842      (if (self-evaluating-p form) form
843        (report-bad-arg form '(satisfies constantp))))))
844
845; SETQ'd above before we could DEFVAR.
846(defvar *fred-special-indent-alist*)
847; avoid hanging onto beezillions of pathnames
848(defvar *last-back-translated-name* nil)
849(defvar *lfun-names*)
850
851(defvar %lambda-lists% (make-hash-table :test #'eq :weak t))
852(defparameter *save-arglist-info* t)
853
854
855(defun record-arglist (name args)
856  "Used by defmacro & defgeneric"
857  (when (or *save-arglist-info* *save-local-symbols*)
858    (setf (gethash name %lambda-lists%) args)))
859
860
861;Support the simple case of defsetf.
862(%fhave 'store-setf-method
863        (qlfun bootstrapping-store-setf-method (name fn &optional doc)
864          (declare (ignore doc))
865          (put name 'bootstrapping-setf-method (require-type fn 'symbol))))
866(%fhave '%setf-method
867        (qlfun bootstrapping-%setf-method (name)
868          (get name 'bootstrapping-setf-method)))
869
870
871;;; Lisp Development System/Application Module Loading
872
873(defvar *lds* t
874  "True to load all Lisp Development System modules")
875(defvar *app-optional-modules* nil
876  "Optional modules to load into application and keys to control contents")
877(defvar *app-modules* nil
878  "Custom modules to load into application")
879
880#| *app-modules* keys:
881:unbind-macros
882:unintern-macros
883:unbind-constants
884:unintern-constants
885:clear-vars
886|#
887
888; (lds <lds-form>)
889; (lds <lds-form> <else-form> ...)
890; (lds <lds-form> :module <module(s)>)
891; (lds <lds-form> :module <module(s)> <else-form> ...)
892
893(defmacro lds (form &rest base-forms &aux modules)
894  (when (eq (first base-forms) :module)
895    (setq modules (second base-forms)
896          base-forms (cddr base-forms)))
897  `(if ,(if (null modules)
898          '*lds*
899          `(or *lds* (,(if (listp modules) 'intersection 'memq)
900                      ',modules *app-modules*)))
901     ,form
902     ,@(if base-forms `((progn ,@base-forms)))))
903
904(defun lds-key-aux (test keys forms)
905  `(,test (,(if (listp keys) 'intersection 'memq)
906           ',keys *app-modules*)
907          ,@forms))
908
909(defmacro lds-key (keys &rest forms)
910  (lds-key-aux 'when keys forms))
911
912(defmacro lds-not-key (keys &rest forms)
913  (lds-key-aux 'unless keys forms))
914
915#| tests
916(lds (print "included"))
917(lds (print "included")
918     (print "other") (print "another"))
919(lds (print "included") :module :eval)
920(lds (print "included") :module :eval
921     (print "other") (print "another"))
922(lds (print "included") :module (:eval :compiler))
923(lds (print "included") :module (:eval :compiler)
924     (print "other") (print "another"))
925
926(setq *lds* nil)
927(setq *lds* t)
928(setq *app-modules* nil)
929(setq *app-modules* '(:eval))
930(setq *app-modules* '(:compiler))
931
932(lds-key :uno (foo))
933(lds-key :uno (foo)(bar))
934(lds-key (:uno :dos) (foo))
935(lds-key (:uno :dos) (foo) (bar))
936(lds-not-key :uno (foo))
937(lds-not-key :uno (foo) (bar))
938(lds-not-key (:uno :dos) (foo))
939(lds-not-key (:uno :dos) (foo) (bar))
940|#
941
942
943; defmacro uses (setf (assq ...) ...) for &body forms.
944(defun adjoin-assq (indicator alist value)
945  (let ((cell (assq indicator alist)))
946    (if cell 
947      (setf (cdr cell) value)
948      (push (cons indicator value) alist)))
949  alist)
950
951(defmacro setf-assq (indicator place value)
952  (let ((res (gensym)))
953    `(let (,res)
954       (setf ,place (adjoin-assq ,indicator ,place (setq ,res ,value)))
955       ,res)))
956
957(defsetf assq setf-assq)
958(defsetf %typed-miscref %typed-miscset)
959
960(defun quoted-form-p (form)
961   (and (consp form)
962        (eq (%car form) 'quote)
963        (consp (%cdr form))
964        (null (%cdr (%cdr form)))))
965
966(defun lambda-expression-p (form)
967  (and (consp form)
968       (eq (%car form) 'lambda)
969       (consp (%cdr form))
970       (listp (%cadr form))))
971
972;;;;;FUNCTION BINDING Functions
973
974; A symbol's entrypoint contains:
975;  1) something tagged as $t_lfun if the symbol is
976;     not fbound as a macro or special form;
977;  2) a cons, otherwise, where the cdr is a fixnum
978;     whose value happens to be the same bit-pattern
979;     as a "jsr_subprim $sp-apply-macro" instruction.
980;     The car of this cons is either:
981;     a) a function -> macro-function;
982;     b) a symbol: special form not redefined as a macro.
983;     c) a cons whose car is a function -> macro function defined
984;        on a special form.
985
986
987(defun macro-function (form &optional env)
988  (setq form (require-type form 'symbol))
989  (when env
990    ; A definition-environment isn't a lexical environment, but it can
991    ; be an ancestor of one.
992    (unless (istruct-typep env 'lexical-environment)
993        (report-bad-arg env 'lexical-environment))
994      (let ((cell nil))
995        (tagbody
996          top
997          (if (setq cell (%cdr (assq form (lexenv.functions env))))
998            (return-from macro-function 
999              (if (eq (car cell) 'macro) (%cdr cell))))
1000          (unless (listp (setq env (lexenv.parent-env env)))
1001            (go top)))))
1002      ; Not found in env, look in function cell.
1003  (%global-macro-function form))
1004
1005(defun symbol-function (name)
1006  "Returns the definition of name, even if it is a macro or a special form.
1007   Errors if name doesn't have a definition."
1008  (or (fboundp name) ;Our fboundp returns the binding
1009      (prog1 (%err-disp $xfunbnd name))))
1010
1011(%fhave 'fdefinition #'symbol-function)
1012
1013
1014(defun kernel-function-p (f)
1015  (declare (ignore f))
1016  nil)
1017
1018(defun %make-function (name fn env)
1019  (let ((compile-it *compile-definitions*))
1020    (when (and compile-it (neq compile-it t))
1021      (setq compile-it (funcall compile-it env)))
1022    (if (not compile-it)
1023      ; bad things will probably occur if env contains unmunched function bindings
1024      ; but enclose says the behavior in that case is "undefined"
1025      (make-evaluated-function name fn env)
1026      (compile-user-function fn name env))))
1027   
1028;;;;;;;;; VALUE BINDING Functions
1029
1030(defun gensym (&optional (string-or-integer nil string-or-integer-p))
1031  "Behaves just like Common Lisp. Imagine that."
1032  (let ((prefix "G")
1033        (counter nil))
1034    (when string-or-integer-p
1035      (etypecase string-or-integer
1036        (integer (setq counter string-or-integer)) ; & emit-style-warning
1037        (string (setq prefix (ensure-simple-string string-or-integer)))))
1038    (unless counter
1039      (setq *gensym-counter* (1+ (setq counter *gensym-counter*))))
1040    (make-symbol (%str-cat prefix (%integer-to-string counter)))))
1041
1042(defun make-keyword (name)
1043  (if (and (symbolp name) (eq (symbol-package name) *keyword-package*))
1044    name
1045    (values (intern (string name) *keyword-package*))))
1046
1047
1048
1049
1050; destructive, removes first match only
1051(defun remove-from-alist (thing alist)
1052 (let ((start alist))
1053  (if (eq thing (%caar alist))
1054   (%cdr alist)
1055   (let* ((prev start)
1056          (this (%cdr prev))
1057          (next (%cdr this)))
1058    (while this
1059     (if (eq thing (%caar this))
1060      (progn
1061       (%rplacd prev next)
1062       (return-from remove-from-alist start))
1063      (setq prev this
1064            this next
1065            next (%cdr next))))
1066    start))))
1067
1068;destructive
1069(defun add-to-alist (thing val alist &aux (pair (assq thing alist)))
1070  (if pair
1071    (progn (%rplacd pair thing) alist)
1072    (cons (cons thing val) alist)))
1073
1074;non-destructive...
1075(defun alist-adjoin (thing val alist &aux (pair (assq thing alist)))
1076  (if (and pair (eq (%cdr pair) val))
1077    alist
1078    (cons (cons thing val) alist)))
1079
1080(defun %str-assoc (str alist)
1081  (assoc str alist :test #'string-equal))
1082
1083(defglobal *pathname-escape-character* #\\
1084  "Not CL.  A Coral addition for compatibility between CL spec and the shell.")
1085
1086
1087(defun caar (x)
1088 (car (car x)))
1089
1090(defun cadr (x)
1091 (car (cdr x)))
1092
1093(defun cdar (x)
1094 (cdr (car x)))
1095
1096(defun cddr (x)
1097 (cdr (cdr x)))
1098
1099(defun caaar (x)
1100 (car (car (car x))))
1101
1102(defun caadr (x)
1103 (car (car (cdr x))))
1104
1105(defun cadar (x)
1106 (car (cdr (car x))))
1107
1108(defun caddr (x)
1109 (car (cdr (cdr x))))
1110
1111(defun cdaar (x)
1112 (cdr (car (car x))))
1113
1114(defun cdadr (x)
1115 (cdr (car (cdr x))))
1116
1117(defun cddar (x)
1118 (cdr (cdr (car x))))
1119
1120(defun cdddr (x)
1121 (cdr (cdr (cdr x))))
1122
1123(defun cadddr (x)
1124 (car (cdr (cdr (cdr x)))))
1125
1126(%fhave 'type-of #'%type-of)
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136(defun pointerp (thing &optional errorp)
1137  (if (macptrp thing)
1138    t
1139    (if errorp (error "~S is not a pointer" thing) nil)))
1140
1141(defun zone-pointerp (thing)
1142  (pointerp thing))
1143
1144(defun handlep (p)
1145  (declare (ignore p))
1146  nil)
1147
1148(defun %get-ostype (pointer &optional (offset 0))
1149  (values (make-keyword (%str-from-ptr (%inc-ptr pointer offset) 4))))
1150
1151
1152     
1153(defun %put-ostype (pointer str &optional (offset 0))
1154  (%put-ostype pointer str offset))     ; gets compiled inline
1155
1156(defun %set-ostype (pointer offset &optional (str (prog1 offset
1157                                                   (setq offset 0))))
1158  (%put-ostype pointer str offset)
1159  str)
1160
1161(defsetf %get-ostype %set-ostype)
1162
1163
1164
1165
1166
1167
1168(defun %ostype-ptr (str)
1169  (%stack-block ((type 4))
1170    (%put-ostype type str)
1171    (%get-ptr type)))
1172
1173(defun ostype-p (x)
1174  (or (integerp x)
1175      (and (stringp x)
1176           (eql 4 (length x))
1177           (or (eq 'base-char (array-element-type x))
1178               (dotimes (i 4 t)
1179                 (unless (< (the fixnum (char-code (char x i))) 256)
1180                   (return nil)))))
1181      (and (symbolp x)
1182           (ostype-p (symbol-name x)))))
1183
1184
1185
1186
1187
1188;Add an item to a dialog items list handle.  HUH ?
1189(defun %rsc-string (n)
1190  (or (cdr (assq n *error-format-strings*))
1191  (%str-cat "Error #" (%integer-to-string n))))
1192
1193(defun string-arg (arg)
1194 (or (string-argp arg) (error "~S is not a string" arg)))
1195
1196(defun string-argp (arg)
1197 (if (symbolp arg) (symbol-name arg)
1198   (if (stringp arg) (ensure-simple-string arg)
1199     nil)))
1200
1201(defun symbol-arg (arg)
1202  (unless (symbolp arg)
1203    (report-bad-arg arg 'symbol))
1204  arg)
1205
1206(defun %cstrlen (ptr)
1207  ;;(#_strlen ptr)
1208  (do* ((i 0 (1+ i)))
1209       ((zerop (the fixnum (%get-byte ptr i))) i)
1210    (declare (fixnum i))))
1211                                                 
1212
1213(defun %put-cstring (ptr str &optional (offset 0))
1214  (do* ((len (length str))
1215        (i 0 (1+ i)))
1216       ((= i len) (setf (%get-byte ptr offset) 0))
1217    (setf (%get-byte ptr offset) (char-code (schar str i)))
1218    (incf offset)))
1219
1220
1221
1222(defun %put-double-float (macptr value &optional (offset 0))
1223  (%set-double-float macptr offset value))
1224
1225
1226
1227
1228
1229(defun %put-single-float (macptr value &optional (offset 0))
1230  (%set-single-float macptr offset value))
1231
1232
1233 
1234; Single float is sign, 8 bits of exponent, 23 bits of mantissa
1235; Double float is sign, 11 bits of exponent, 52 bits of mantissa
1236#|
1237(defun %single-float-ptr->double-float-ptr (single double)
1238  (let* ((hi (%get-word single))
1239         (low (%get-word single 2))
1240         (negative (logbitp 16 hi))
1241         (expt (logand #xff (the fixnum (ash hi -7))))
1242         (normalized-expt (- expt #x7f))
1243         (double-expt (+ normalized-expt #x3ff))
1244         (double-expt-with-sign
1245          (if negative
1246            (the fixnum (+ (ash 1 11) double-expt))
1247            double-expt))
1248         (mantissa (+ low (the fixnum (logand hi #x7f))))
1249         (word0 (+ (the fixnum (ash double-expt-with-sign 4))
1250                   (the fixnum (ash mantissa -19))))
1251         (word1 (logand (the fixnum (ash mantissa -3)) #xffff))
1252         (word2 (ash (the fixnum (logand mantissa 7)) 13)))
1253    (declare (fixnum hi low expt normalized-expt double-expt
1254                     double-expt-with-sign mantissa word0 word1 word2))
1255    (setf (%get-word double) word0
1256          (%get-word double 2) word1
1257          (%get-word double 4) word2
1258          (%get-word double 6) 0)
1259    double))
1260|#
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272;Returns a simple string and adjusted start and end, such that
1273; 0<= start <= end <= (length simple-string).
1274(defun get-sstring (str &optional (start 0) (end (length (require-type str 'string))))
1275  (multiple-value-bind (sstr offset) (array-data-and-offset (string str))
1276    (setq start (+ start offset) end (+ end offset))
1277    (when (< (length sstr) end)(setq end (length sstr)))
1278    (when (< end start) (setq start end))
1279    (values sstr start end)))
1280
1281;e.g. (bad-named-arg :key key 'function)
1282(defun bad-named-arg (name arg &optional (type nil type-p))
1283  (if type-p
1284    (%err-disp $err-bad-named-arg-2 name arg type)
1285    (%err-disp $err-bad-named-arg name arg)))
1286
1287(defun verify-arg-count (call min &optional max)
1288  "If call contains less than MIN number of args, or more than MAX
1289   number of args, error. Otherwise, return call.
1290   If Max is NIL, the maximum args for the fn are infinity."
1291 (or (verify-call-count (car call) (%cdr call) min max) call))
1292
1293(defun verify-call-count (sym args min &optional max &aux argcount)
1294  (if (%i< (setq argcount  (list-length args)) min)
1295    (%err-disp $xtoofew (cons sym args))
1296    (if (if max (%i> argcount max))
1297      (%err-disp $xtoomany (cons sym args)))))
1298
1299(defun getf (place key &optional (default ()))
1300  (let ((p (pl-search place key))) (if p (%cadr p) default)))
1301
1302(defun remprop (symbol key)
1303  (do* ((prev nil plist)
1304        (plist (symbol-plist symbol) tail)
1305        (tail (cddr plist) (cddr tail)))
1306       ((null plist))
1307    (when (eq (car plist) key)
1308      (if prev
1309        (rplacd (cdr prev) tail)
1310        (setf (symbol-plist symbol) tail))
1311      (return t))))
1312
1313
1314
1315; If this returns non-nil, safe to do %rplaca of %cdr to update.
1316(defun pl-search (plist key)
1317  (unless (plistp plist)
1318    (report-bad-arg plist '(satisfies plistp)))
1319  (%pl-search plist key))
1320
1321
1322
1323
1324
1325
1326
1327(defun position (item sequence &rest ignored-keys)
1328  (declare (ignore ignored-keys)
1329           (dynamic-extent ignored-keys))
1330  (xposition item sequence))
1331
1332(defun xposition (item sequence)
1333  (if (listp sequence)
1334    (do* ((list sequence (%cdr list))
1335          (count 0 (1+ count)))
1336         ((endp list) nil)
1337      (when (eql (car list) item) (return count)))
1338    (dotimes (i (length sequence))
1339      (declare (fixnum i))
1340      (when (eql (aref sequence i) item) (return i)))))
1341
1342(defun position-positional-test-key (item sequence test key)
1343  (declare (ignore test key))
1344  (xposition item sequence))
1345
1346(defun delete (item list &rest ignored-keys)
1347  (declare (ignore ignored-keys)
1348           (dynamic-extent ignored-keys)
1349           (inline delete))
1350  (if list
1351      (if (eq item (car list))
1352          (delete item (%cdr list))
1353          (%rplacd list (delete item (%cdr list))))))
1354
1355(defun rassoc (item alist &key (test #'eql test-p) test-not (key #'identity))
1356  (declare (list alist))
1357  "Returns the cons in alist whose cdr is equal (by a given test or EQL) to
1358   the Item."
1359  (if (or test-p (not test-not))
1360    (progn
1361      (if test-not (error "Cannot specify both :TEST and :TEST-NOT."))
1362      (dolist (pair alist)
1363        (if (atom pair)
1364          (if pair (error "Invalid alist containing ~S: ~S" pair alist))
1365          (when (funcall test item (funcall key (cdr pair))) (return pair)))))
1366    (progn
1367      (unless test-not (error "Must specify at least one of :TEST or :TEST-NOT"))
1368      (dolist (pair alist)
1369        (if (atom pair)
1370          (if pair (error "Invalid alist containing ~S: ~S" pair alist))
1371          (unless (funcall test-not item (funcall key (cdr pair))) (return pair)))))))
1372
1373(defun *%saved-method-var%* ()
1374  (declare (special %saved-method-var%))
1375  %saved-method-var%)
1376
1377(defun set-*%saved-method-var%* (new-value)
1378  (declare (special %saved-method-var%))
1379  (setq %saved-method-var% new-value))
1380
1381(defsetf *%saved-method-var%* set-*%saved-method-var%*)
1382
1383(defun beep (&optional (times 1) idlecount)
1384  (dotimes (i times) (declare (fixnum i)) (princ #.(string #\bell)))
1385  (when idlecount (dotimes (i idlecount) (declare (fixnum i)))))
1386
1387
1388
1389(defun true (&rest p) (declare (ignore p)) t)
1390(defun false (&rest p) (declare (ignore p)) nil)
1391
1392(setf (symbol-function 'clear-type-cache) #'false)      ; bootstrapping
1393
1394(defun make-array-1 (dims element-type element-type-p
1395                          displaced-to
1396                          displaced-index-offset
1397                          adjustable
1398                          fill-pointer
1399                          initial-element initial-element-p
1400                          initial-contents initial-contents-p
1401                          size)
1402  (let ((subtype (element-type-subtype element-type)))
1403    (when (and element-type (null subtype))
1404      (error "Unknown element-type ~S" element-type))
1405    (when (null size)
1406      (cond ((listp dims)
1407             (setq size 1)
1408             (dolist (dim dims)
1409               (when (< dim 0)
1410                 (report-bad-arg dim '(integer 0 *)))
1411               (setq size (* size dim))))
1412            (t (setq size dims)))) ; no need to check vs. array-dimension-limit
1413    (cond
1414     (displaced-to
1415      (when (or initial-element-p initial-contents-p)
1416        (error "Cannot specify initial values for displaced arrays"))
1417      (when (and element-type-p
1418                 (neq (array-element-subtype displaced-to) subtype))
1419        (error "The ~S array ~S is not of ~S ~S"
1420               :displaced-to displaced-to :element-type element-type))
1421      (%make-displaced-array dims displaced-to
1422                             fill-pointer adjustable displaced-index-offset))
1423     (t
1424      (when displaced-index-offset
1425        (error "Cannot specify ~S for non-displaced-array" :displaced-index-offset))
1426      (when (null subtype)
1427        (error "Cannot make an array of empty type ~S" element-type))
1428      (make-uarray-1 subtype dims adjustable fill-pointer 
1429                     initial-element initial-element-p
1430                     initial-contents initial-contents-p
1431                     nil size)))))
1432
1433(defun make-uarray-1 (subtype dims adjustable fill-pointer
1434                              initial-element initial-element-p
1435                              initial-contents initial-contents-p
1436                              temporary 
1437                              size)
1438  (declare (ignore temporary))
1439  (when (null size)(setq size (if (listp dims)(apply #'* dims) dims)))
1440  (let ((vector (%alloc-misc size subtype)))  ; may not get here in that case
1441    (if initial-element-p
1442      (dotimes (i (uvsize vector)) (declare (fixnum i))(uvset vector i initial-element))
1443      (if initial-contents-p
1444        (if (null dims) (uvset vector 0 initial-contents)
1445            (init-uvector-contents vector 0 dims initial-contents))))
1446    (if (and (null fill-pointer)
1447             (not adjustable)
1448             dims
1449             (or (atom dims) (null (%cdr dims))))
1450      vector
1451      (let ((array (%make-displaced-array dims vector 
1452                                          fill-pointer adjustable nil)))
1453        (when (and (null fill-pointer) (not adjustable))
1454          (%set-simple-array-p array))
1455        array))))
1456
1457(defun init-uvector-contents (vect offset dims contents
1458                              &aux (len (length contents)))
1459  "Returns final offset. Assumes dims not ()."
1460  (unless (eq len (if (atom dims) dims (%car dims)))
1461    (error "~S doesn't match array dimensions of ~S ."  contents vect))
1462  (cond ((or (atom dims) (null (%cdr dims)))
1463         (if (listp contents)
1464           (let ((contents-tail contents))
1465             (dotimes (i len)
1466               (declare (fixnum i))
1467               (uvset vect offset (pop contents-tail))
1468               (setq offset (%i+ offset 1))))
1469           (dotimes (i len)
1470             (declare (fixnum i))
1471             (uvset vect offset (elt contents i))
1472             (setq offset (%i+ offset 1)))))
1473        (t (setq dims (%cdr dims))
1474           (if (listp contents)
1475             (let ((contents-tail contents))
1476               (dotimes (i len)
1477                 (declare (fixnum i))
1478                 (setq offset
1479                       (init-uvector-contents vect offset dims (pop contents-tail)))))
1480             (dotimes (i len)
1481               (declare (fixnum i))
1482               (setq offset
1483                     (init-uvector-contents vect offset dims (elt contents i)))))))
1484  offset)
1485
1486(defun %get-signed-long-long (ptr &optional (offset 0))
1487  (%%get-signed-longlong ptr offset))
1488
1489(defun %set-signed-long-long (ptr arg1
1490                                  &optional
1491                                  (arg2 (prog1 arg1 (setq arg1 0))))
1492  (%%set-signed-longlong ptr arg1 arg2))
1493                                 
1494(defun %get-unsigned-long-long (ptr &optional (offset 0))
1495  (%%get-unsigned-longlong ptr offset))
1496
1497(defun %set-unsigned-long-long (ptr arg1
1498                                  &optional
1499                                  (arg2 (prog1 arg1 (setq arg1 0))))
1500  (%%set-unsigned-longlong ptr arg1 arg2))
1501
1502(defun %composite-pointer-ref (size pointer offset)
1503  (declare (ignorable size))
1504  (%inc-ptr pointer offset))
1505
1506(defun %set-composite-pointer-ref (size pointer offset new)
1507  (#_bcopy new
1508           (%inc-ptr pointer offset)
1509           size))
1510
1511
1512(defsetf %composite-pointer-ref %set-composite-pointer-ref)
1513
1514
1515;end of L1-utils.lisp
1516
Note: See TracBrowser for help on using the repository browser.