source: branches/qres/ccl/level-1/l1-utils.lisp @ 14049

Last change on this file since 14049 was 14049, checked in by gz, 9 years ago

Misc tweaks and fixes from trunk (r13550,r13560,r13568,r13569,r13581,r13583,r13633-13636,r13647,r13648,r13657-r13659,r13675,r13678,r13688,r13743,r13744,r13769,r13773,r13782,r13813,r13814,r13869,r13870,r13873,r13901,r13930,r13943,r13946,r13954,r13961,r13974,r13975,r13978,r13990,r14010,r14012,r14020,r14028-r14030)

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