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

Last change on this file since 10942 was 10942, checked in by gz, 11 years ago

Propagate r10938:r10941 (duplicate definition warnings) to trunk

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