source: branches/working-0711/ccl/level-1/l1-utils.lisp @ 12050

Last change on this file since 12050 was 12050, checked in by gz, 12 years ago

Tighten up proclaim/declaim error checking, both runtime and compile time

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