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

Last change on this file since 13066 was 13066, checked in by rme, 10 years ago

Change "OpenMCL" to "Clozure CL" in comments and docstrings.

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