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

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

Moved record-source-file from l1-utils to lib;source-files.

From the working-0711 branch: make the definition types used in record
source file be instances so they can specialize behaviors. Modified to
have a simplier api, to have more internal functionality go through
definition-type gf's, and to not require definition types to be
pre-defined.

While in there, made it issue load-time redefinition warnings for
methods as well as functions, and added a mechanism to get rid of
many of the duplicate conses that record-source-file used to create.

Note that this doesn't change the 'file' part of record-source-file,
just the behind-the-scenes handling of the definition-type arg.

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