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

Last change on this file was 16685, checked in by rme, 4 years ago

Update copyright/license headers in files.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 35.9 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;; Copyright 1994-2009 Clozure Associates
4;;;
5;;; Licensed under the Apache License, Version 2.0 (the "License");
6;;; you may not use this file except in compliance with the License.
7;;; You may obtain a copy of the License at
8;;;
9;;;     http://www.apache.org/licenses/LICENSE-2.0
10;;;
11;;; Unless required by applicable law or agreed to in writing, software
12;;; distributed under the License is distributed on an "AS IS" BASIS,
13;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
14;;; See the License for the specific language governing permissions and
15;;; limitations under the License.
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;;; Once we're bootstrapped, we should move the real PREPARE-TO-DESTRUCTURE
125;;; here.
126(defun %early-prepare-to-destructure (list &rest ignore)
127  (declare (ignore ignore))
128  list)
129
130(setf (fdefinition 'prepare-to-destructure) #'%early-prepare-to-destructure)
131
132
133
134
135
136
137
138(defun %keyword-present-p (keys keyword)
139  (let* ((not-there (cons nil nil)))
140    (declare (dynamic-extent not-there))
141    (not (eq (getf keys keyword not-there) not-there))))
142
143(defun check-keywords (keys actual allow-others)
144  (let* ((len (ignore-errors (list-length actual))))
145    (if (null len)
146      (signal-simple-program-error "Circular or dotted keyword list: ~s" actual)
147      (if (oddp len)
148        (signal-simple-program-error "Odd length keyword list: ~s" actual))))
149  (setq allow-others (or allow-others (getf actual :allow-other-keys)))
150  (do* ((a actual (cddr a))
151        (k (car a) (car a)))
152       ((null a))
153    (unless (typep k 'symbol)
154      (signal-simple-program-error
155       "Invalid keyword argument ~s in ~s.  ~&Valid keyword arguments are ~s." k actual keys))
156    (unless (or allow-others
157                (eq k :allow-other-keys)
158                (member k keys))
159      (signal-simple-program-error "Unknown keyword argument ~s in ~s.  ~&Valid keyword arguments are ~s." k actual keys))))
160
161(%fhave 'set-macro-function #'%macro-have)   ; redefined in sysutils.
162
163;;; Define special forms.
164(dolist (sym '(block catch compiler-let eval-when
165               flet function go if labels let let* macrolet
166               multiple-value-call multiple-value-prog1
167               progn progv quote return-from setq tagbody
168               the throw unwind-protect locally load-time-value
169               symbol-macrolet
170               ;; These are implementation-specific special forms :
171               nfunction
172               #+ppc-target
173               ppc-lap-function
174               #+arm-target
175               arm-lap-function
176               #+x86-target
177               x86-lap-function
178               fbind
179               with-c-frame with-variable-c-frame))
180  (%macro-have sym sym))
181
182
183(defun %macro (named-fn &optional doc &aux arglist)
184  ;; "doc" is either a string or a list of the form :
185  ;; (doc-string-or-nil . (body-pos-or-nil . arglist-or-nil))
186  (if (listp doc)
187    (setq arglist (cddr doc)
188          doc (car doc)))
189  (let* ((name (function-name named-fn)))
190    (record-source-file name 'function)
191    (set-macro-function name named-fn)
192    (when (and doc *save-doc-strings*)
193      (set-documentation name 'function doc))
194    (when arglist
195      (record-arglist name arglist))
196    (when *fasload-print* (format t "~&~S~%" name))
197    name))
198
199
200(defun %defvar (var &optional doc)
201  "Returns boundp"
202  (%proclaim-special var)
203  (record-source-file var 'variable)
204  (when (and doc *save-doc-strings*)
205    (set-documentation var 'variable doc))
206  (cond ((not (boundp var))
207         (when *fasload-print* (format t "~&~S~%" var))
208         nil)
209        (t t)))
210
211(defun %defparameter (var value &optional doc)
212  (%proclaim-special var)
213  (record-source-file var 'variable)
214  (when (and doc *save-doc-strings*)
215    (set-documentation var 'variable doc))
216  (when *fasload-print* (format t "~&~S~%" var))
217  (set var value)
218  var)
219
220
221(defun %defglobal (var value &optional doc)
222  (%symbol-bits var (logior (ash 1 $sym_vbit_global) (the fixnum (%symbol-bits var))))
223  (%defparameter var value doc))
224
225;Needed early for member etc.
226(defun identity (x)
227  "This function simply returns what was passed to it."
228  x)
229
230(defun coerce-to-function (arg)
231  (if (functionp arg)
232    arg
233    (if (symbolp arg)
234      (%function arg)
235      (report-bad-arg arg 'function))))
236
237;;; takes arguments in arg_x, arg_y, arg_z, returns "multiple values"
238;;; Test(-not) arguments are NOT validated beyond what is done
239;;; here.
240;;; if both :test and :test-not supplied, signal error.
241;;; if test provided as #'eq or 'eq, return first value 'eq.
242;;; if test defaulted, provided as 'eql, or provided as #'eql, return
243;;; first value 'eql.
244;;; if test-not provided as 'eql or provided as #'eql, return second
245;;; value 'eql.
246;;; if key provided as either 'identity or #'identity, return third value nil.
247(defun %key-conflict (test-fn test-not-fn key)
248  (let* ((eqfn #'eq)
249         (eqlfn #'eql)
250         (idfn #'identity))
251    (if (or (eq key 'identity) (eq key idfn))
252      (setq key nil))
253    (if test-fn
254      (if test-not-fn
255        (%err-disp $xkeyconflict ':test test-fn ':test-not test-not-fn)
256        (if (eq test-fn eqfn)
257          (values 'eq nil key)
258          (if (eq test-fn eqlfn)
259            (values 'eql nil key)
260            (values test-fn nil key))))
261      (if test-not-fn
262        (if (eq test-not-fn eqfn)
263          (values nil 'eq key)
264          (if (eq test-not-fn eqlfn)
265            (values nil 'eql key)
266            (values nil test-not-fn key)))
267        (values 'eql nil key)))))
268
269
270
271
272;;; Assoc.
273
274;;; (asseql item list) <=> (assoc item list :test #'eql :key #'identity)
275
276
277
278;;; (assoc-test item list test-fn)
279;;;   <=>
280;;;     (assoc item list :test test-fn :key #'identity)
281;;; test-fn may not be FUNCTIONP, so we coerce it here.
282(defun assoc-test (item list test-fn)
283  (dolist (pair list)
284    (if pair
285      (if (funcall test-fn item (car pair))
286        (return pair)))))
287
288
289
290; (assoc-test-not item list test-not-fn)
291;   <=>
292;     (assoc item list :test-not test-not-fn :key #'identity)
293; test-not-fn may not be FUNCTIONP, so we coerce it here.
294(defun assoc-test-not (item list test-not-fn)
295  (dolist (pair list)
296    (if pair
297      (if (not (funcall test-not-fn item (car pair)))
298        (return pair)))))
299
300(defun assoc (item list &key test test-not key)
301  "Return the cons in ALIST whose car is equal (by a given test or EQL) to
302   the ITEM."
303  (multiple-value-bind (test test-not key) (%key-conflict test test-not key)
304    (if (null key)
305      (if (eq test 'eq)
306        (assq item list)
307        (if (eq test 'eql)
308          (asseql item list)
309          (if test
310            (assoc-test item list test)
311            (assoc-test-not item list test-not))))
312      (if test
313        (dolist (pair list)
314          (if pair
315            (if (funcall test item (funcall key (car pair)))
316              (return pair))))
317        (dolist (pair list)
318          (if pair
319            (unless (funcall test-not item (funcall key (car pair)))
320              (return pair))))))))
321
322
323;;;; Member.
324
325;;; (member-test-not item list test-not-fn)
326;;;   <=>
327;;;     (member item list :test-not test-not-fn :key #'identity)
328(defun member-test-not (item list test-not-fn)
329  (do* ((l list (cdr l)))
330       ((endp l))
331    (unless (funcall test-not-fn item (%car l)) (return l))))
332
333(defun member (item list &key test test-not key)
334  "Return the tail of LIST beginning with first element satisfying EQLity,
335   :TEST, or :TEST-NOT with the given ITEM."
336  (multiple-value-bind (test test-not key) (%key-conflict test test-not key)
337    (if (null key)
338      (if (eq test 'eq)
339        (memq item list)
340        (if (eq test 'eql)
341          (memeql item list)
342          (if test
343            (member-test item list test)
344            (member-test-not item list test-not))))
345      (if test
346        (do* ((l list (cdr l)))
347             ((endp l))
348          (if (funcall test item (funcall key (car l)))
349              (return l)))
350        (do* ((l list (cdr l)))
351             ((null l))
352          (unless (funcall test-not item (funcall key (car l)))
353              (return l)))))))
354
355
356(defun adjoin (item list &key test test-not key)
357  "Add ITEM to LIST unless it is already a member"
358  (if (and (not test)(not test-not)(not key))
359    (if (not (memeql item list))(cons item list) list)
360    (multiple-value-bind (test test-not key) (%key-conflict test test-not key)
361      (if
362        (if (null key)
363          (if (eq test 'eq)
364            (memq item list)
365            (if (eq test 'eql)
366              (memeql item list)
367              (if test
368                (member-test item list test)
369                (member-test-not item list test-not))))
370          (if test
371            (member (funcall key item) list :test test :key key)
372            (member (funcall key item) list :test-not test-not :key key)))
373        list
374        (cons item list)))))
375
376(defun adjoin-eq (elt list)
377  (if (memq elt list)
378    list
379    (cons elt list)))
380
381(defun adjoin-eql (elt list)
382  (if (memeql elt list)
383    list
384    (cons elt list)))
385
386(defun union-eq (list1 list2)
387  (let ((res list2))
388    (dolist (elt list1)
389      (unless (memq elt res)
390        (push elt res)))
391    res))
392
393(defun union-eql (list1 list2)
394  (let ((res list2))
395    (dolist (elt list1)
396      (unless (memeql elt res)
397        (push elt res)))
398    res))
399
400;;; Fix this someday.  Fix EQUALP, while you're at it ...
401(defun similar-as-constants-p (x y)
402  (or (eq x y)                          ; Redefinition of constants to themselves.
403      (if (and (stringp x) (stringp y)) ;The most obvious case where equalp & s-a-c-p need to differ...
404        (string= x y)
405        (equalp x y))))
406
407(defun undefine-constant (var)
408  (%set-sym-global-value var (%unbound-marker-8)))
409
410(defparameter *cerror-on-constant-redefinition* t)
411
412(defun define-constant (var value)
413  (block nil
414    (if (constant-symbol-p var)
415      (let* ((old-value (%sym-global-value var)))
416        (unless (eq old-value (%unbound-marker-8))
417          (if (or (eql old-value value)
418                  (and (not *strict-checking*) (similar-as-constants-p old-value value)))
419            (return)
420            ;; This should really be a cell error, allow options other than
421            ;; redefining (such as don't redefine and continue)...
422            (when *cerror-on-constant-redefinition*
423              (cerror "Redefine ~S to have new value ~*~s"
424                      "Constant ~S is already defined with a different value (~s)"
425                      var old-value value))))))
426    (%symbol-bits var 
427                  (%ilogior (%ilsl $sym_bit_special 1) (%ilsl $sym_bit_const 1)
428                            (%symbol-bits var)))
429    (%set-sym-global-value var value))
430  var)
431
432(defun %defconstant (var value &optional doc)
433  (%proclaim-special var)
434  (record-source-file var 'constant)
435  (define-constant var value)
436  (when (and doc *save-doc-strings*)
437    (set-documentation var 'variable doc))
438  (when *fasload-print* (format t "~&~S~%" var))
439  var)
440
441(defparameter *nx1-compiler-special-forms* ())
442(defparameter *nx-proclaimed-types* ())
443(defparameter *nx-proclaimed-ftypes* nil)
444
445(defun compiler-special-form-p (sym)
446  (or (eq sym 'quote)
447      (if (memq sym *nx1-compiler-special-forms*) t)))
448
449
450
451(defparameter *nx-known-declarations* ())
452(defparameter *nx-proclaimed-inline* ())
453(defparameter *nx-proclaimed-ignore* ())
454(defparameter *nx-globally-inline* ())
455
456
457
458(defconstant *cl-types* '(
459array
460atom
461base-char
462bignum
463bit
464bit-vector 
465character
466#|
467lisp:common
468|#
469compiled-function 
470complex 
471cons                   
472double-float
473extended-char
474fixnum
475float
476function
477hash-table
478integer
479keyword
480list 
481long-float
482nil 
483null
484number 
485package
486pathname 
487random-state 
488ratio
489rational
490readtable
491real
492sequence 
493short-float
494signed-byte 
495simple-array
496simple-bit-vector
497simple-string 
498simple-base-string
499simple-vector 
500single-float
501standard-char
502stream 
503string
504#|
505lisp:string-char
506|#
507symbol
508t
509unsigned-byte 
510vector
511))
512
513;; Redefined in sysutils.
514(%fhave 'specifier-type-if-known
515        (qlfun bootstrapping-type-specifier-p (name &optional env &key &allow-other-keys)
516          (declare (ignore env))
517          (memq name *cl-types*)))
518
519
520
521(defun proclaim (spec)
522  (case (car spec)
523    (special (apply #'proclaim-special (%cdr spec)))
524    (notspecial (apply #'proclaim-notspecial (%cdr spec)))
525    (optimize (%proclaim-optimize (%cdr spec)))
526    (inline (apply #'proclaim-inline t (%cdr spec)))
527    (notinline (apply #'proclaim-inline nil (%cdr spec)))
528    (declaration (apply #'proclaim-declaration (%cdr spec)))
529    (ignore (apply #'proclaim-ignore t (%cdr spec)))
530    (unignore (apply #'proclaim-ignore nil (%cdr spec)))
531    (type (apply #'proclaim-type (%cdr spec)))
532    (ftype (apply #'proclaim-ftype (%cdr spec)))
533    (function (apply #'proclaim-type spec))
534    (t (unless (memq (%car spec) *nx-known-declarations*)
535         ;; Any type name is now (ANSI CL) a valid declaration.
536         (if (specifier-type-if-known (%car spec))
537           (apply #'proclaim-type spec)
538           (signal-program-error "Unknown declaration specifier ~s in ~S" (%car spec) spec))))))
539
540(defun bad-proclaim-spec (spec)
541  (signal-program-error "Invalid declaration specifier ~s" spec))
542
543
544(defun using-linear-scan () *backend-use-linear-scan*)
545
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(defun fdefinition (name)
741  (or (fboundp name) ;Our fboundp returns the binding
742      (prog1 (%err-disp $xfunbnd name))))
743
744(defun symbol-function (name)
745  "Return the definition of NAME, even if it is a macro or a special form.
746   Error if NAME doesn't have a definition."
747  (fdefinition (require-type name 'symbol)))
748
749
750(defun %make-function (name fn env)
751  (compile-user-function fn name env))
752   
753;;;;;;;;; VALUE BINDING Functions
754
755;; Lock used only to make sure calls to GENSYM don't step on each other.  Users who
756;; modify *gensym-counter* in multi-threaded apps will need to do their own locking.
757(defparameter *gensym-lock* (make-lock))
758
759(defun gensym (&optional (string-or-integer nil string-or-integer-p))
760  "Creates a new uninterned symbol whose name is a prefix string (defaults
761   to \"G\"), followed by a decimal number. Thing, when supplied, will
762   alter the prefix if it is a string, or be used for the decimal number
763   if it is a number, of this symbol. The default value of the number is
764   the current value of *gensym-counter* which is incremented each time
765   it is used."
766  (let ((prefix "G")
767        (counter nil))
768    (when string-or-integer-p
769      (etypecase string-or-integer
770        (integer (setq counter string-or-integer)) ; & emit-style-warning
771        (string (setq prefix (ensure-simple-string string-or-integer)))))
772    (unless counter
773      (with-lock-grabbed (*gensym-lock*)
774        (setq *gensym-counter* (1+ (setq counter *gensym-counter*)))))
775    (make-symbol (%str-cat prefix (%integer-to-string counter)))))
776
777(defun make-keyword (name)
778  (if (and (symbolp name) (eq (symbol-package name) *keyword-package*))
779    name
780    (values (intern (string name) *keyword-package*))))
781
782
783
784
785; destructive, removes first match only
786(defun remove-from-alist (thing alist)
787 (let ((start alist))
788  (if (eq thing (%caar alist))
789   (%cdr alist)
790   (let* ((prev start)
791          (this (%cdr prev))
792          (next (%cdr this)))
793    (while this
794     (if (eq thing (%caar this))
795      (progn
796       (%rplacd prev next)
797       (return-from remove-from-alist start))
798      (setq prev this
799            this next
800            next (%cdr next))))
801    start))))
802
803;destructive
804(defun add-to-alist (thing val alist &aux (pair (assq thing alist)))
805  (if pair
806    (progn (%rplacd pair thing) alist)
807    (cons (cons thing val) alist)))
808
809;non-destructive...
810(defun alist-adjoin (thing val alist &aux (pair (assq thing alist)))
811  (if (and pair (eq (%cdr pair) val))
812    alist
813    (cons (cons thing val) alist)))
814
815(defun %str-assoc (str alist)
816  (assoc str alist :test #'string-equal))
817
818(defstatic *pathname-escape-character*
819  #+windows-target #\>
820  #-windows-target #\\
821  "Not CL.  A Coral addition for compatibility between CL spec and the shell.")
822
823(defun caar (x) (car (car x)))
824(defun cadr (x) (car (cdr x)))
825(defun cdar (x) (cdr (car x)))
826(defun cddr (x) (cdr (cdr x)))
827
828(defun caaar (x) (car (car (car x))))
829(defun caadr (x) (car (car (cdr x))))
830(defun cadar (x) (car (cdr (car x))))
831(defun caddr (x) (car (cdr (cdr x))))
832(defun cdaar (x) (cdr (car (car x))))
833(defun cdadr (x) (cdr (car (cdr x))))
834(defun cddar (x) (cdr (cdr (car x))))
835(defun cdddr (x) (cdr (cdr (cdr x))))
836
837(%fhave 'type-of #'%type-of)
838
839
840
841(defun pointerp (thing &optional errorp)
842  (if (macptrp thing)
843    t
844    (if errorp (error "~S is not a pointer" thing) nil)))
845
846
847;Add an item to a dialog items list handle.  HUH ?
848(defun %rsc-string (n)
849  (or (cdr (assq n *error-format-strings*))
850  (%str-cat "Error #" (%integer-to-string n))))
851
852(defun string-arg (arg)
853 (or (string-argp arg) (error "~S is not a string" arg)))
854
855(defun string-argp (arg)
856  (cond ((symbolp arg) (symbol-name arg))
857        ((typep arg 'character) (string arg))
858        ((stringp arg) (ensure-simple-string arg))
859        (t nil)))
860 
861(defun symbol-arg (arg)
862  (unless (symbolp arg)
863    (report-bad-arg arg 'symbol))
864  arg)
865
866(defun %cstrlen (ptr)
867  ;;(#_strlen ptr)
868  (do* ((i 0 (1+ i)))
869       ((zerop (the fixnum (%get-byte ptr i))) i)
870    (declare (fixnum i))))
871
872
873(defun %set-cstring (ptr string)
874  (%cstr-pointer string ptr)
875  string)
876
877(defsetf %get-cstring %set-cstring)
878
879;;; Deprecated, but used by UFFI.
880(defun %put-cstring (ptr str &optional (offset 0))
881  (setf (%get-cstring (%inc-ptr ptr offset)) str)
882  ;; 0 is the traditional, not-very-useful return value ...
883  0)
884
885
886
887
888
889
890;;; Returns a simple string and adjusted start and end, such that
891;;; 0<= start <= end <= (length simple-string).
892(defun get-sstring (str &optional (start 0) (end (length (require-type str 'string))))
893  (multiple-value-bind (sstr offset) (array-data-and-offset (string str))
894    (setq start (+ start offset) end (+ end offset))
895    (when (< (length sstr) end)(setq end (length sstr)))
896    (when (< end start) (setq start end))
897    (values sstr start end)))
898
899;e.g. (bad-named-arg :key key 'function)
900(defun bad-named-arg (name arg &optional (type nil type-p))
901  (if type-p
902    (%err-disp $err-bad-named-arg-2 name arg type)
903    (%err-disp $err-bad-named-arg name arg)))
904
905(defun verify-arg-count (call min &optional max)
906  "If call contains less than MIN number of args, or more than MAX
907   number of args, error. Otherwise, return call.
908   If Max is NIL, the maximum args for the fn are infinity."
909 (or (verify-call-count (car call) (%cdr call) min max) call))
910
911(defun verify-call-count (sym args min &optional max &aux argcount)
912  (if (%i< (setq argcount  (list-length args)) min)
913    (%err-disp $xtoofew (cons sym args))
914    (if (if max (%i> argcount max))
915      (%err-disp $xtoomany (cons sym args)))))
916
917(defun getf (place key &optional (default ()))
918  "Search the property list stored in Place for an indicator EQ to INDICATOR.
919  If one is found, return the corresponding value, else return DEFAULT."
920  (let ((p (pl-search place key))) (if p (%cadr p) default)))
921
922(defun remprop (symbol key)
923  "Look on property list of SYMBOL for property with specified
924  INDICATOR. If found, splice this indicator and its value out of
925  the plist, and return the tail of the original list starting with
926  INDICATOR. If not found, return () with no side effects.
927
928  NOTE: The ANSI specification requires REMPROP to return true (not false)
929  or false (the symbol NIL). Portable code should not rely on any other value."
930  (do* ((prev nil plist)
931        (plist (symbol-plist symbol) tail)
932        (tail (cddr plist) (cddr tail)))
933       ((null plist))
934    (when (eq (car plist) key)
935      (if prev
936        (rplacd (cdr prev) tail)
937        (setf (symbol-plist symbol) tail))
938      (return t))))
939
940
941
942;;; If this returns non-nil, safe to do %rplaca of %cdr to update.
943(defun pl-search (plist key)
944  (unless (plistp plist)
945    (report-bad-arg plist '(satisfies plistp)))
946  (%pl-search plist key))
947
948
949(defun rassoc (item alist &key (test #'eql test-p) test-not (key #'identity))
950  (declare (list alist))
951  "Return the cons in ALIST whose CDR is equal (by a given test or EQL) to
952   the ITEM."
953  (if (or test-p (not test-not))
954    (progn
955      (if test-not (error "Cannot specify both :TEST and :TEST-NOT."))
956      (dolist (pair alist)
957        (if (atom pair)
958          (if pair (error "Invalid alist containing ~S: ~S" pair alist))
959          (when (funcall test item (funcall key (cdr pair))) (return pair)))))
960    (progn
961      (unless test-not (error "Must specify at least one of :TEST or :TEST-NOT"))
962      (dolist (pair alist)
963        (if (atom pair)
964          (if pair (error "Invalid alist containing ~S: ~S" pair alist))
965          (unless (funcall test-not item (funcall key (cdr pair))) (return pair)))))))
966
967(defun *%saved-method-var%* ()
968  (declare (special %saved-method-var%))
969  %saved-method-var%)
970
971(defun set-*%saved-method-var%* (new-value)
972  (declare (special %saved-method-var%))
973  (setq %saved-method-var% new-value))
974
975(defsetf *%saved-method-var%* set-*%saved-method-var%*)
976
977
978
979
980
981
982(setf (symbol-function 'clear-type-cache) #'false)      ; bootstrapping
983
984(defun make-array-1 (dims element-type element-type-p
985                          displaced-to
986                          displaced-index-offset
987                          adjustable
988                          fill-pointer
989                          initial-element initial-element-p
990                          initial-contents initial-contents-p
991                          size)
992  (let ((subtype (element-type-subtype element-type)))
993    (when (and element-type (null subtype))
994      (error "Unknown element-type ~S" element-type))
995    (when (null size)
996      (cond ((listp dims)
997             (setq size 1)
998             (dolist (dim dims)
999               (when (< dim 0)
1000                 (report-bad-arg dim '(integer 0 *)))
1001               (setq size (* size dim))))
1002            (t (setq size dims)))) ; no need to check vs. array-dimension-limit
1003    (cond
1004     (displaced-to
1005      (when (or initial-element-p initial-contents-p)
1006        (error "Cannot specify initial values for displaced arrays"))
1007      (when (and element-type-p
1008                 (neq (array-element-subtype displaced-to) subtype))
1009        (error "The ~S array ~S is not of ~S ~S"
1010               :displaced-to displaced-to :element-type element-type))
1011      (%make-displaced-array dims displaced-to
1012                             fill-pointer adjustable displaced-index-offset t))
1013     (t
1014      (when displaced-index-offset
1015        (error "Cannot specify ~S for non-displaced-array" :displaced-index-offset))
1016      (when (null subtype)
1017        (error "Cannot make an array of empty type ~S" element-type))
1018      (make-uarray-1 subtype dims adjustable fill-pointer 
1019                     initial-element initial-element-p
1020                     initial-contents initial-contents-p
1021                     nil size)))))
1022
1023(defun %make-simple-array (subtype dims)
1024  (let* ((size (if (listp dims) (apply #'* dims) dims))
1025         (vector (%alloc-misc size subtype)))
1026    (if (and (listp dims)
1027             (not (eql (length dims) 1)))
1028      (let* ((array (%make-displaced-array dims vector)))
1029        (%set-simple-array-p array)
1030        array)
1031      vector)))
1032
1033(defun make-uarray-1 (subtype dims adjustable fill-pointer
1034                              initial-element initial-element-p
1035                              initial-contents initial-contents-p
1036                              temporary 
1037                              size)
1038  (declare (ignore temporary))
1039  (when (null size)(setq size (if (listp dims)(apply #'* dims) dims)))
1040  (let ((vector (%alloc-misc size subtype)))  ; may not get here in that case
1041    (if initial-element-p
1042      (cond ((and (eql subtype target::subtag-simple-base-string)
1043                  (eql initial-element #\Null)))
1044            ((and (eql subtype target::subtag-double-float-vector)
1045                  (eql initial-element 0.0d0)))
1046            ((and (eql subtype target::subtag-single-float-vector)
1047                  (eql initial-element 0.0s0)))
1048            (t (or (eql initial-element 0)
1049                   (%init-misc initial-element vector))))
1050      (if initial-contents-p
1051        (if (null dims) (uvset vector 0 initial-contents)
1052            (init-uvector-contents vector 0 dims initial-contents))))
1053    (if (and (null fill-pointer)
1054             (not adjustable)
1055             dims
1056             (or (atom dims) (null (%cdr dims))))
1057      vector
1058      (let ((array (%make-displaced-array dims vector 
1059                                          fill-pointer adjustable nil)))
1060        (when (and (null fill-pointer) (not adjustable))
1061          (%set-simple-array-p array))
1062        array))))
1063
1064(defun init-uvector-contents (vect offset dims contents
1065                              &aux (len (length contents)))
1066  "Returns final offset. Assumes dims not ()."
1067  (unless (eq len (if (atom dims) dims (%car dims)))
1068    (error "~S doesn't match array dimensions of ~S ."  contents vect))
1069  (cond ((or (atom dims) (null (%cdr dims)))
1070         (if (listp contents)
1071           (let ((contents-tail contents))
1072             (dotimes (i len)
1073               (declare (fixnum i))
1074               (uvset vect offset (pop contents-tail))
1075               (setq offset (%i+ offset 1))))
1076           (dotimes (i len)
1077             (declare (fixnum i))
1078             (uvset vect offset (elt contents i))
1079             (setq offset (%i+ offset 1)))))
1080        (t (setq dims (%cdr dims))
1081           (if (listp contents)
1082             (let ((contents-tail contents))
1083               (dotimes (i len)
1084                 (declare (fixnum i))
1085                 (setq offset
1086                       (init-uvector-contents vect offset dims (pop contents-tail)))))
1087             (dotimes (i len)
1088               (declare (fixnum i))
1089               (setq offset
1090                     (init-uvector-contents vect offset dims (elt contents i)))))))
1091  offset)
1092
1093(defun %get-signed-long-long (ptr &optional (offset 0))
1094  (%%get-signed-longlong ptr offset))
1095
1096(defun %set-signed-long-long (ptr arg1
1097                                  &optional
1098                                  (arg2 (prog1 arg1 (setq arg1 0))))
1099  (%%set-signed-longlong ptr arg1 arg2))
1100                                 
1101(defun %get-unsigned-long-long (ptr &optional (offset 0))
1102  (%%get-unsigned-longlong ptr offset))
1103
1104(defun %set-unsigned-long-long (ptr arg1
1105                                  &optional
1106                                  (arg2 (prog1 arg1 (setq arg1 0))))
1107  (%%set-unsigned-longlong ptr arg1 arg2))
1108
1109(defun %composite-pointer-ref (size pointer offset)
1110  (declare (ignorable size))
1111  (%inc-ptr pointer offset))
1112
1113(defun %set-composite-pointer-ref (size pointer offset new)
1114  (#_memmove (%inc-ptr pointer offset)
1115             new
1116             size))
1117
1118
1119(defsetf %composite-pointer-ref %set-composite-pointer-ref)
1120
1121
1122(defsetf pathname-encoding-name set-pathname-encoding-name)
1123
1124;end of L1-utils.lisp
1125
Note: See TracBrowser for help on using the repository browser.