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

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

Made loading a file not forget encapsulations. (The old behavior can be
restored by setting ccl::*loading-removes-encapsulation* to true).

Added new keyword arg to ADVISE - :dynamic-extent-arglist, if true, declares the
advised arglist to be dynamic-extent, this can be used to minimize runtime
consing when the advice form doesn't save the arglist outside the dynamic extent
of the invocation.

Changed how encapsulation (i.e. tracing and advising) of generic functions
works. Before, the encapsulating function would be installed as the dcode and
then try to guess what the gf code used to do in order to invoke the original
dcode. Now, we just save a copy of the original gf code and jump to it. This
way encapsulation is isolated from having to know details of how the dcode and
the gf interact.

Made (setf %gf-dcode) also update the GF function code to match the dcode. This
is now the only place that has knowledge of how to do that.

register-dcode-proto for %%1st-arg-dcode and %%nth-arg-dcode, since *gf-proto*
is no longer the default.

Also while in there, I consolidated and rearranged some of the encapsulation
recording, hopefully without introducing too many bugs (or at least none that
will be hard to fix).

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