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

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

incorporate 0.14.2 changes

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 46.2 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  (compile-user-function fn name env))
1020   
1021;;;;;;;;; VALUE BINDING Functions
1022
1023(defun gensym (&optional (string-or-integer nil string-or-integer-p))
1024  "Behaves just like Common Lisp. Imagine that."
1025  (let ((prefix "G")
1026        (counter nil))
1027    (when string-or-integer-p
1028      (etypecase string-or-integer
1029        (integer (setq counter string-or-integer)) ; & emit-style-warning
1030        (string (setq prefix (ensure-simple-string string-or-integer)))))
1031    (unless counter
1032      (setq *gensym-counter* (1+ (setq counter *gensym-counter*))))
1033    (make-symbol (%str-cat prefix (%integer-to-string counter)))))
1034
1035(defun make-keyword (name)
1036  (if (and (symbolp name) (eq (symbol-package name) *keyword-package*))
1037    name
1038    (values (intern (string name) *keyword-package*))))
1039
1040
1041
1042
1043; destructive, removes first match only
1044(defun remove-from-alist (thing alist)
1045 (let ((start alist))
1046  (if (eq thing (%caar alist))
1047   (%cdr alist)
1048   (let* ((prev start)
1049          (this (%cdr prev))
1050          (next (%cdr this)))
1051    (while this
1052     (if (eq thing (%caar this))
1053      (progn
1054       (%rplacd prev next)
1055       (return-from remove-from-alist start))
1056      (setq prev this
1057            this next
1058            next (%cdr next))))
1059    start))))
1060
1061;destructive
1062(defun add-to-alist (thing val alist &aux (pair (assq thing alist)))
1063  (if pair
1064    (progn (%rplacd pair thing) alist)
1065    (cons (cons thing val) alist)))
1066
1067;non-destructive...
1068(defun alist-adjoin (thing val alist &aux (pair (assq thing alist)))
1069  (if (and pair (eq (%cdr pair) val))
1070    alist
1071    (cons (cons thing val) alist)))
1072
1073(defun %str-assoc (str alist)
1074  (assoc str alist :test #'string-equal))
1075
1076(defglobal *pathname-escape-character* #\\
1077  "Not CL.  A Coral addition for compatibility between CL spec and the shell.")
1078
1079
1080(defun caar (x)
1081 (car (car x)))
1082
1083(defun cadr (x)
1084 (car (cdr x)))
1085
1086(defun cdar (x)
1087 (cdr (car x)))
1088
1089(defun cddr (x)
1090 (cdr (cdr x)))
1091
1092(defun caaar (x)
1093 (car (car (car x))))
1094
1095(defun caadr (x)
1096 (car (car (cdr x))))
1097
1098(defun cadar (x)
1099 (car (cdr (car x))))
1100
1101(defun caddr (x)
1102 (car (cdr (cdr x))))
1103
1104(defun cdaar (x)
1105 (cdr (car (car x))))
1106
1107(defun cdadr (x)
1108 (cdr (car (cdr x))))
1109
1110(defun cddar (x)
1111 (cdr (cdr (car x))))
1112
1113(defun cdddr (x)
1114 (cdr (cdr (cdr x))))
1115
1116(defun cadddr (x)
1117 (car (cdr (cdr (cdr x)))))
1118
1119(%fhave 'type-of #'%type-of)
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129(defun pointerp (thing &optional errorp)
1130  (if (macptrp thing)
1131    t
1132    (if errorp (error "~S is not a pointer" thing) nil)))
1133
1134(defun zone-pointerp (thing)
1135  (pointerp thing))
1136
1137(defun handlep (p)
1138  (declare (ignore p))
1139  nil)
1140
1141(defun %get-ostype (pointer &optional (offset 0))
1142  (values (make-keyword (%str-from-ptr (%inc-ptr pointer offset) 4))))
1143
1144
1145     
1146(defun %put-ostype (pointer str &optional (offset 0))
1147  (%put-ostype pointer str offset))     ; gets compiled inline
1148
1149(defun %set-ostype (pointer offset &optional (str (prog1 offset
1150                                                   (setq offset 0))))
1151  (%put-ostype pointer str offset)
1152  str)
1153
1154(defsetf %get-ostype %set-ostype)
1155
1156
1157
1158
1159
1160
1161(defun %ostype-ptr (str)
1162  (%stack-block ((type 4))
1163    (%put-ostype type str)
1164    (%get-ptr type)))
1165
1166(defun ostype-p (x)
1167  (or (integerp x)
1168      (and (stringp x)
1169           (eql 4 (length x))
1170           (or (eq 'base-char (array-element-type x))
1171               (dotimes (i 4 t)
1172                 (unless (< (the fixnum (char-code (char x i))) 256)
1173                   (return nil)))))
1174      (and (symbolp x)
1175           (ostype-p (symbol-name x)))))
1176
1177
1178
1179
1180
1181;Add an item to a dialog items list handle.  HUH ?
1182(defun %rsc-string (n)
1183  (or (cdr (assq n *error-format-strings*))
1184  (%str-cat "Error #" (%integer-to-string n))))
1185
1186(defun string-arg (arg)
1187 (or (string-argp arg) (error "~S is not a string" arg)))
1188
1189(defun string-argp (arg)
1190 (if (symbolp arg) (symbol-name arg)
1191   (if (stringp arg) (ensure-simple-string arg)
1192     nil)))
1193
1194(defun symbol-arg (arg)
1195  (unless (symbolp arg)
1196    (report-bad-arg arg 'symbol))
1197  arg)
1198
1199(defun %cstrlen (ptr)
1200  ;;(#_strlen ptr)
1201  (do* ((i 0 (1+ i)))
1202       ((zerop (the fixnum (%get-byte ptr i))) i)
1203    (declare (fixnum i))))
1204                                                 
1205
1206(defun %put-cstring (ptr str &optional (offset 0))
1207  (do* ((len (length str))
1208        (i 0 (1+ i)))
1209       ((= i len) (setf (%get-byte ptr offset) 0))
1210    (setf (%get-byte ptr offset) (char-code (schar str i)))
1211    (incf offset)))
1212
1213
1214
1215(defun %put-double-float (macptr value &optional (offset 0))
1216  (%set-double-float macptr offset value))
1217
1218
1219
1220
1221
1222(defun %put-single-float (macptr value &optional (offset 0))
1223  (%set-single-float macptr offset value))
1224
1225
1226 
1227; Single float is sign, 8 bits of exponent, 23 bits of mantissa
1228; Double float is sign, 11 bits of exponent, 52 bits of mantissa
1229#|
1230(defun %single-float-ptr->double-float-ptr (single double)
1231  (let* ((hi (%get-word single))
1232         (low (%get-word single 2))
1233         (negative (logbitp 16 hi))
1234         (expt (logand #xff (the fixnum (ash hi -7))))
1235         (normalized-expt (- expt #x7f))
1236         (double-expt (+ normalized-expt #x3ff))
1237         (double-expt-with-sign
1238          (if negative
1239            (the fixnum (+ (ash 1 11) double-expt))
1240            double-expt))
1241         (mantissa (+ low (the fixnum (logand hi #x7f))))
1242         (word0 (+ (the fixnum (ash double-expt-with-sign 4))
1243                   (the fixnum (ash mantissa -19))))
1244         (word1 (logand (the fixnum (ash mantissa -3)) #xffff))
1245         (word2 (ash (the fixnum (logand mantissa 7)) 13)))
1246    (declare (fixnum hi low expt normalized-expt double-expt
1247                     double-expt-with-sign mantissa word0 word1 word2))
1248    (setf (%get-word double) word0
1249          (%get-word double 2) word1
1250          (%get-word double 4) word2
1251          (%get-word double 6) 0)
1252    double))
1253|#
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265;Returns a simple string and adjusted start and end, such that
1266; 0<= start <= end <= (length simple-string).
1267(defun get-sstring (str &optional (start 0) (end (length (require-type str 'string))))
1268  (multiple-value-bind (sstr offset) (array-data-and-offset (string str))
1269    (setq start (+ start offset) end (+ end offset))
1270    (when (< (length sstr) end)(setq end (length sstr)))
1271    (when (< end start) (setq start end))
1272    (values sstr start end)))
1273
1274;e.g. (bad-named-arg :key key 'function)
1275(defun bad-named-arg (name arg &optional (type nil type-p))
1276  (if type-p
1277    (%err-disp $err-bad-named-arg-2 name arg type)
1278    (%err-disp $err-bad-named-arg name arg)))
1279
1280(defun verify-arg-count (call min &optional max)
1281  "If call contains less than MIN number of args, or more than MAX
1282   number of args, error. Otherwise, return call.
1283   If Max is NIL, the maximum args for the fn are infinity."
1284 (or (verify-call-count (car call) (%cdr call) min max) call))
1285
1286(defun verify-call-count (sym args min &optional max &aux argcount)
1287  (if (%i< (setq argcount  (list-length args)) min)
1288    (%err-disp $xtoofew (cons sym args))
1289    (if (if max (%i> argcount max))
1290      (%err-disp $xtoomany (cons sym args)))))
1291
1292(defun getf (place key &optional (default ()))
1293  (let ((p (pl-search place key))) (if p (%cadr p) default)))
1294
1295(defun remprop (symbol key)
1296  (do* ((prev nil plist)
1297        (plist (symbol-plist symbol) tail)
1298        (tail (cddr plist) (cddr tail)))
1299       ((null plist))
1300    (when (eq (car plist) key)
1301      (if prev
1302        (rplacd (cdr prev) tail)
1303        (setf (symbol-plist symbol) tail))
1304      (return t))))
1305
1306
1307
1308; If this returns non-nil, safe to do %rplaca of %cdr to update.
1309(defun pl-search (plist key)
1310  (unless (plistp plist)
1311    (report-bad-arg plist '(satisfies plistp)))
1312  (%pl-search plist key))
1313
1314
1315
1316
1317
1318
1319
1320(defun position (item sequence &rest ignored-keys)
1321  (declare (ignore ignored-keys)
1322           (dynamic-extent ignored-keys))
1323  (xposition item sequence))
1324
1325(defun xposition (item sequence)
1326  (if (listp sequence)
1327    (do* ((list sequence (%cdr list))
1328          (count 0 (1+ count)))
1329         ((endp list) nil)
1330      (when (eql (car list) item) (return count)))
1331    (dotimes (i (length sequence))
1332      (declare (fixnum i))
1333      (when (eql (aref sequence i) item) (return i)))))
1334
1335(defun position-positional-test-key (item sequence test key)
1336  (declare (ignore test key))
1337  (xposition item sequence))
1338
1339(defun delete (item list &rest ignored-keys)
1340  (declare (ignore ignored-keys)
1341           (dynamic-extent ignored-keys)
1342           (inline delete))
1343  (if list
1344      (if (eq item (car list))
1345          (delete item (%cdr list))
1346          (%rplacd list (delete item (%cdr list))))))
1347
1348(defun rassoc (item alist &key (test #'eql test-p) test-not (key #'identity))
1349  (declare (list alist))
1350  "Returns the cons in alist whose cdr is equal (by a given test or EQL) to
1351   the Item."
1352  (if (or test-p (not test-not))
1353    (progn
1354      (if test-not (error "Cannot specify both :TEST and :TEST-NOT."))
1355      (dolist (pair alist)
1356        (if (atom pair)
1357          (if pair (error "Invalid alist containing ~S: ~S" pair alist))
1358          (when (funcall test item (funcall key (cdr pair))) (return pair)))))
1359    (progn
1360      (unless test-not (error "Must specify at least one of :TEST or :TEST-NOT"))
1361      (dolist (pair alist)
1362        (if (atom pair)
1363          (if pair (error "Invalid alist containing ~S: ~S" pair alist))
1364          (unless (funcall test-not item (funcall key (cdr pair))) (return pair)))))))
1365
1366(defun *%saved-method-var%* ()
1367  (declare (special %saved-method-var%))
1368  %saved-method-var%)
1369
1370(defun set-*%saved-method-var%* (new-value)
1371  (declare (special %saved-method-var%))
1372  (setq %saved-method-var% new-value))
1373
1374(defsetf *%saved-method-var%* set-*%saved-method-var%*)
1375
1376(defun beep (&optional (times 1) idlecount)
1377  (dotimes (i times) (declare (fixnum i)) (princ #.(string #\bell)))
1378  (when idlecount (dotimes (i idlecount) (declare (fixnum i)))))
1379
1380
1381
1382(defun true (&rest p) (declare (ignore p)) t)
1383(defun false (&rest p) (declare (ignore p)) nil)
1384
1385(setf (symbol-function 'clear-type-cache) #'false)      ; bootstrapping
1386
1387(defun make-array-1 (dims element-type element-type-p
1388                          displaced-to
1389                          displaced-index-offset
1390                          adjustable
1391                          fill-pointer
1392                          initial-element initial-element-p
1393                          initial-contents initial-contents-p
1394                          size)
1395  (let ((subtype (element-type-subtype element-type)))
1396    (when (and element-type (null subtype))
1397      (error "Unknown element-type ~S" element-type))
1398    (when (null size)
1399      (cond ((listp dims)
1400             (setq size 1)
1401             (dolist (dim dims)
1402               (when (< dim 0)
1403                 (report-bad-arg dim '(integer 0 *)))
1404               (setq size (* size dim))))
1405            (t (setq size dims)))) ; no need to check vs. array-dimension-limit
1406    (cond
1407     (displaced-to
1408      (when (or initial-element-p initial-contents-p)
1409        (error "Cannot specify initial values for displaced arrays"))
1410      (when (and element-type-p
1411                 (neq (array-element-subtype displaced-to) subtype))
1412        (error "The ~S array ~S is not of ~S ~S"
1413               :displaced-to displaced-to :element-type element-type))
1414      (%make-displaced-array dims displaced-to
1415                             fill-pointer adjustable displaced-index-offset t))
1416     (t
1417      (when displaced-index-offset
1418        (error "Cannot specify ~S for non-displaced-array" :displaced-index-offset))
1419      (when (null subtype)
1420        (error "Cannot make an array of empty type ~S" element-type))
1421      (make-uarray-1 subtype dims adjustable fill-pointer 
1422                     initial-element initial-element-p
1423                     initial-contents initial-contents-p
1424                     nil size)))))
1425
1426(defun make-uarray-1 (subtype dims adjustable fill-pointer
1427                              initial-element initial-element-p
1428                              initial-contents initial-contents-p
1429                              temporary 
1430                              size)
1431  (declare (ignore temporary))
1432  (when (null size)(setq size (if (listp dims)(apply #'* dims) dims)))
1433  (let ((vector (%alloc-misc size subtype)))  ; may not get here in that case
1434    (if initial-element-p
1435      (dotimes (i (uvsize vector)) (declare (fixnum i))(uvset vector i initial-element))
1436      (if initial-contents-p
1437        (if (null dims) (uvset vector 0 initial-contents)
1438            (init-uvector-contents vector 0 dims initial-contents))))
1439    (if (and (null fill-pointer)
1440             (not adjustable)
1441             dims
1442             (or (atom dims) (null (%cdr dims))))
1443      vector
1444      (let ((array (%make-displaced-array dims vector 
1445                                          fill-pointer adjustable nil)))
1446        (when (and (null fill-pointer) (not adjustable))
1447          (%set-simple-array-p array))
1448        array))))
1449
1450(defun init-uvector-contents (vect offset dims contents
1451                              &aux (len (length contents)))
1452  "Returns final offset. Assumes dims not ()."
1453  (unless (eq len (if (atom dims) dims (%car dims)))
1454    (error "~S doesn't match array dimensions of ~S ."  contents vect))
1455  (cond ((or (atom dims) (null (%cdr dims)))
1456         (if (listp contents)
1457           (let ((contents-tail contents))
1458             (dotimes (i len)
1459               (declare (fixnum i))
1460               (uvset vect offset (pop contents-tail))
1461               (setq offset (%i+ offset 1))))
1462           (dotimes (i len)
1463             (declare (fixnum i))
1464             (uvset vect offset (elt contents i))
1465             (setq offset (%i+ offset 1)))))
1466        (t (setq dims (%cdr dims))
1467           (if (listp contents)
1468             (let ((contents-tail contents))
1469               (dotimes (i len)
1470                 (declare (fixnum i))
1471                 (setq offset
1472                       (init-uvector-contents vect offset dims (pop contents-tail)))))
1473             (dotimes (i len)
1474               (declare (fixnum i))
1475               (setq offset
1476                     (init-uvector-contents vect offset dims (elt contents i)))))))
1477  offset)
1478
1479(defun %get-signed-long-long (ptr &optional (offset 0))
1480  (%%get-signed-longlong ptr offset))
1481
1482(defun %set-signed-long-long (ptr arg1
1483                                  &optional
1484                                  (arg2 (prog1 arg1 (setq arg1 0))))
1485  (%%set-signed-longlong ptr arg1 arg2))
1486                                 
1487(defun %get-unsigned-long-long (ptr &optional (offset 0))
1488  (%%get-unsigned-longlong ptr offset))
1489
1490(defun %set-unsigned-long-long (ptr arg1
1491                                  &optional
1492                                  (arg2 (prog1 arg1 (setq arg1 0))))
1493  (%%set-unsigned-longlong ptr arg1 arg2))
1494
1495(defun %composite-pointer-ref (size pointer offset)
1496  (declare (ignorable size))
1497  (%inc-ptr pointer offset))
1498
1499(defun %set-composite-pointer-ref (size pointer offset new)
1500  (#_bcopy new
1501           (%inc-ptr pointer offset)
1502           size))
1503
1504
1505(defsetf %composite-pointer-ref %set-composite-pointer-ref)
1506
1507
1508;end of L1-utils.lisp
1509
Note: See TracBrowser for help on using the repository browser.