source: trunk/source/lib/level-2.lisp @ 12995

Last change on this file since 12995 was 12995, checked in by gz, 10 years ago

svn ci -m "Merge r12980, replacing r12646 (which defeated type optimizations in addition to being buggy)"

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 16.2 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;; Level-2.lisp
18
19(in-package "CCL")
20
21(eval-when (eval compile)
22  (require "LEVEL-2")
23  (require "BACKQUOTE")
24  (require "DEFSTRUCT-MACROS"))
25
26
27
28(eval-when (eval compile)
29  (require "LISPEQU"))
30
31
32
33
34
35
36
37
38; This incredibly essential thing is part of ANSI CL; put it in the
39; right package someday.
40; Like maybe when it says something about doc strings, or otherwise
41; becomes useful.
42
43(defun parse-macro (name arglist body &optional env)
44  (values (parse-macro-1 name arglist body env)))
45
46; Return a list containing a special declaration for SYM
47; if SYM is declared special in decls.
48; This is so we can be pedantic about binding &WHOLE/&ENVIRONMENT args
49; that have been scarfed out of a macro-like lambda list.
50; The returned value is supposed to be suitable for splicing ...
51(defun hoist-special-decls (sym decls)
52  (when sym
53    (dolist (decl decls)
54      (dolist (spec (cdr decl))
55        (when (eq (car spec) 'special)
56          (dolist (s (%cdr spec))
57            (when (eq s sym)
58              (return-from hoist-special-decls `((declare (special ,sym)))))))))))
59
60(defun parse-macro-1 (name arglist body &optional env)
61  (parse-macro-internal name arglist body env nil))
62
63(defun parse-macro-internal (name arglist body env default-initial-value)
64  (unless (verify-lambda-list arglist t t t)
65    (error "Invalid lambda list ~s" arglist))
66  (multiple-value-bind (lambda-list whole environment)
67      (normalize-lambda-list arglist t t)
68    (multiple-value-bind (body local-decs doc)
69        (parse-body body env t)
70      (let ((whole-var (gensym "WHOLE"))
71            (env-var (gensym "ENVIRONMENT")))
72        (multiple-value-bind (bindings binding-decls)
73            (%destructure-lambda-list lambda-list whole-var nil nil
74                                      :cdr-p t
75                                      :whole-p nil
76                                      :use-whole-var t
77                                      :default-initial-value default-initial-value)
78          (when environment
79            (setq bindings (nconc bindings (list `(,environment ,env-var)))))
80          (when whole
81            (setq bindings (nconc bindings (list `(,whole ,whole-var)))))
82          (values
83            `(lambda (,whole-var ,env-var)
84               (declare (ignorable ,whole-var ,env-var))
85               (block ,name
86                 (let* ,(nreverse bindings)
87                   ,@(when binding-decls `((declare ,@binding-decls)))
88                   ,@local-decs
89                   ,@body)))
90            doc))))))
91
92
93(defun %destructure-lambda-list (lambda-list wholeform  lets decls
94                                             &key cdr-p (whole-p t) use-whole-var default-initial-value)
95  (unless (and (listp lambda-list)
96               (verify-lambda-list lambda-list t whole-p))
97    (signal-simple-program-error "Invalid lambda list: ~s" lambda-list))
98  (multiple-value-bind (normalized whole) (normalize-lambda-list
99                                           lambda-list whole-p)
100    (let* ((argstate :required)
101           (allow-other-keys nil)
102           (rest-arg-name nil)
103           (w (if use-whole-var wholeform (or whole (gensym "WHOLE"))))
104           (argptr (gensym "ARGS"))
105           (has-&key nil)
106           (most-recent-binding nil)
107           (keywords ())
108           (first-keyword-init ())
109           (restp nil))
110      (labels ((simple-var (var &optional (initform `,default-initial-value))
111                 (let* ((binding `(,var ,initform)))
112                   (unless (eq argstate :aux)
113                     (setq most-recent-binding binding))
114                   (push  binding lets)
115                   binding))
116               (structured-var (context sub-lambda-list initform)
117                 (let* ((v (gensym (string context))))
118                   (simple-var v initform)
119                   (multiple-value-setq (lets decls)
120                     (%destructure-lambda-list
121                      sub-lambda-list
122                      v
123                      lets
124                      decls
125                      :default-initial-value default-initial-value
126))
127                   v)))
128        (unless use-whole-var
129          (if (atom w)
130            (simple-var w wholeform)
131            (progn
132              (setq w (structured-var "WHOLE" w (if cdr-p `(cdr ,wholeform) wholeform))
133                    cdr-p nil))))
134        (simple-var argptr `(make-destructure-state ,@(if cdr-p `((cdr ,w)) `(,w)) ,w ',lambda-list))
135        (setq most-recent-binding nil)
136        (push `(dynamic-extent ,argptr) decls)
137        (do* ((tail normalized (cdr tail)))
138             ((null tail)
139              (if has-&key
140                (let* ((key-check-form `(check-keywords
141                                         ',(nreverse keywords)
142                                         ,rest-arg-name ,allow-other-keys)))
143                  (if first-keyword-init
144                    (rplaca (cdr first-keyword-init)
145                            `(progn
146                              ,key-check-form
147                              ,(cadr first-keyword-init)))
148                    (let* ((check-var (gensym "CHECK")))
149                      (push `(ignorable ,check-var) decls)
150                      (simple-var check-var key-check-form))))
151                (unless restp
152                  (let* ((checkform `(%check-extra-arguments ,argptr))
153                         (b most-recent-binding)
154                         (b-init (cadr b)))
155                    (if b
156                      (rplaca (cdr b) `(prog1 ,b-init ,checkform))
157                      (let* ((junk (gensym "JUNK")))
158                        (simple-var junk checkform)
159                        (push `(ignorable ,junk) decls))))))
160              (values lets decls))
161          (let* ((var (car tail)))
162            (cond ((or (eq var '&rest) (eq var '&body))
163                   (let* ((r (cadr tail))
164                          (init `(destructure-state.current ,argptr)))
165                     (if (listp r)
166                       (setq rest-arg-name
167                             (structured-var "REST" r init))
168                       (progn
169                         (setq rest-arg-name (gensym "REST"))
170                         (simple-var rest-arg-name init)
171                         (simple-var r rest-arg-name ))))
172                   (setq restp t)
173                   (setq tail (cdr tail)))
174                  ((eq var '&optional) (setq argstate :optional))
175                  ((eq var '&key)
176                   (setq argstate :key)
177                   (setq has-&key t)
178                   (unless restp
179                     (setq restp t
180                           rest-arg-name (gensym "KEYS"))
181                     (push `(ignorable ,rest-arg-name) decls)
182                     (simple-var rest-arg-name
183                                 `(destructure-state.current ,argptr))))
184                  ((eq var '&allow-other-keys)
185                   (setq allow-other-keys t))
186                  ((eq var '&aux)
187                   (setq argstate :aux))
188                  ((listp var)
189                   (case argstate
190                     (:required
191                      (structured-var "REQ" var `(%pop-required-arg-ptr ,argptr)))
192                     (:optional
193                      (let* ((variable (car var))
194                             (initform (if (cdr var)
195                                         (cadr var)
196                                         `,default-initial-value))
197                             (spvar (if (cddr var)
198                                      (caddr var)
199                                      (gensym "OPT-SUPPLIED-P")))
200                             (varinit `(if ,spvar
201                                        (%default-optional-value ,argptr)
202                                        ,initform)))
203                        (simple-var spvar
204                                    `(not (null (destructure-state.current ,argptr))))
205                        (if (listp variable)
206                          (structured-var "OPT" variable varinit)
207                          (simple-var variable varinit))))
208                     (:key
209                      (let* ((explicit-key (consp (car var)))
210                             (variable (if explicit-key
211                                         (cadar var)
212                                         (car var)))
213                             (keyword (if explicit-key
214                                        (caar var)
215                                        (make-keyword variable)))
216                             (initform (if (cdr var)
217                                         (cadr var)
218                                         `,default-initial-value))
219                             (spvar (if (cddr var)
220                                      (caddr var)
221                                      (gensym "KEY-SUPPLIED-P"))))
222                        (push keyword keywords)
223                        (let* ((sp-init (simple-var spvar
224                                                    `(%keyword-present-p
225                                                      ,rest-arg-name
226                                                      ',keyword)))
227                               (var-init `(if ,spvar
228                                           (getf ,rest-arg-name ',keyword)
229                                           ,initform)))
230                          (unless first-keyword-init
231                            (setq first-keyword-init sp-init))
232                          (if (listp variable)
233                            (structured-var "KEY" variable var-init)
234                            (simple-var variable var-init)))))
235                     (:aux
236                      (simple-var (car var) (cadr var)))
237                     (t (error "NYI: ~s" argstate))))
238                  ((symbolp var)
239                   (case argstate
240                     (:required
241                      (simple-var var `(%pop-required-arg-ptr ,argptr)))
242                     (:optional
243                      (simple-var var `(%default-optional-value ,argptr
244                                        ',default-initial-value)))
245                     (:key
246                      (let* ((keyword (make-keyword var)))
247                        (push keyword keywords)
248                        (let* ((init (simple-var
249                                      var
250                                      `(getf ,rest-arg-name
251                                        ',keyword
252                                        ,@(if default-initial-value
253                                             `(',default-initial-value))))))
254                          (unless first-keyword-init
255                            (setq first-keyword-init init)))))
256                     (:aux
257                      (simple-var var)))))))))))
258
259
260
261
262
263
264(defun apply-to-htab-syms (function pkg-vector)
265  (let* ((sym nil)
266         (foundp nil))
267    (dotimes (i (uvsize pkg-vector))
268      (declare (fixnum i))
269      (multiple-value-setq (sym foundp) (%htab-symbol pkg-vector i))
270      (when foundp (funcall function sym)))))
271
272(defun iterate-over-external-symbols (pkg-spec function)
273  (apply-to-htab-syms function (car (pkg.etab (pkg-arg (or pkg-spec *package*))))))
274
275(defun iterate-over-present-symbols (pkg-spec function)
276  (let ((pkg (pkg-arg (or pkg-spec *package*))))
277    (apply-to-htab-syms function (car (pkg.etab pkg)))
278    (apply-to-htab-syms function (car (pkg.itab pkg)))))
279
280(defun iterate-over-accessable-symbols (pkg-spec function)
281  (let* ((pkg (pkg-arg (or pkg-spec *package*)))
282         (used (pkg.used pkg))
283         (shadowed (pkg.shadowed pkg)))
284    (iterate-over-present-symbols pkg function)
285    (when used
286      (if shadowed
287        (flet ((ignore-shadowed-conflicts (var)
288                 (unless (%name-present-in-package-p (symbol-name var) pkg)
289                   (funcall function var))))
290          (declare (dynamic-extent #'ignore-shadowed-conflicts))
291          (dolist (u used) (iterate-over-external-symbols u #'ignore-shadowed-conflicts)))
292        (dolist (u used) (iterate-over-external-symbols u function))))))
293
294(defun iterate-over-all-symbols (function)
295  (dolist (pkg %all-packages%)
296    (iterate-over-present-symbols pkg function)))         
297
298
299
300;;;Eval definitions for things open-coded by the compiler.
301;;;Don't use DEFUN since it should be illegal to DEFUN compiler special forms...
302;;;Of course, these aren't special forms.
303(macrolet ((%eval-redef (name vars &rest body)
304             (when (null body) (setq body `((,name ,@vars))))
305             `(setf (symbol-function ',name)
306                    (qlfun ,name ,vars ,@body))))
307  (declare (optimize (speed 1) (safety 1)))
308  (%eval-redef %ilsl (n x))
309  (%eval-redef %ilsr (n x))
310  (%eval-redef neq (x y))
311  (%eval-redef not (x))
312  (%eval-redef null (x))
313  (%eval-redef rplaca (x y))
314  (%eval-redef rplacd (x y))
315  (%eval-redef set-car (x y))
316  (%eval-redef set-cdr (x y))
317  (%eval-redef int>0-p (x))
318  (%eval-redef %get-byte (ptr &optional (offset 0)) (%get-byte ptr offset))
319  (%eval-redef %get-word (ptr &optional (offset 0)) (%get-word ptr offset))
320  (%eval-redef %get-signed-byte (ptr &optional (offset 0)) (%get-signed-byte ptr offset))
321  (%eval-redef %get-signed-word (ptr &optional (offset 0)) (%get-signed-word ptr offset))
322  (%eval-redef %get-long (ptr &optional (offset 0)) (%get-long ptr offset))
323  (%eval-redef %get-fixnum (ptr &optional (offset 0)) (%get-fixnum ptr offset))
324  (%eval-redef %get-signed-long (ptr &optional (offset 0)) (%get-signed-long ptr offset))
325  (%eval-redef %get-unsigned-long (ptr &optional (offset 0)) (%get-unsigned-long ptr offset))
326  (%eval-redef %get-ptr (ptr &optional (offset 0)) (%get-ptr ptr offset))
327  (%eval-redef %get-full-long (ptr &optional (offset 0)) (%get-full-long ptr offset))
328  (%eval-redef %int-to-ptr (int))
329  (%eval-redef %ptr-to-int (ptr))
330  (%eval-redef %ptr-eql (ptr1 ptr2))
331  (%eval-redef %setf-macptr (ptr1 ptr2))
332  (%eval-redef %null-ptr-p (ptr))
333
334
335  (%eval-redef %iasr (x y))
336
337 
338  (%eval-redef %set-byte (p o &optional (new (prog1 o (setq o 0))))
339               (%set-byte p o new))
340  (%eval-redef %set-unsigned-byte (p o &optional (new (prog1 o (setq o 0))))
341               (%set-unsigned-byte p o new))
342  (%eval-redef %set-word (p o &optional (new (prog1 o (setq o 0))))
343               (%set-word p o new))
344  (%eval-redef %set-unsigned-word (p o &optional (new (prog1 o (setq o 0))))
345               (%set-unsigned-word p o new))
346  (%eval-redef %set-long (p o &optional (new (prog1 o (setq o 0))))
347               (%set-long p o new))
348  (%eval-redef %set-unsigned-long (p o &optional (new (prog1 o (setq o 0))))
349               (%set-unsigned-long p o new))
350  (%eval-redef %set-ptr (p o &optional (new (prog1 o (setq o 0))))
351               (%set-ptr p o new))
352
353 
354  (%eval-redef %word-to-int (word))
355  (%eval-redef %inc-ptr (ptr &optional (by 1)) (%inc-ptr ptr by))
356 
357  (%eval-redef char-code (x))
358  (%eval-redef code-char (x))
359  (%eval-redef 1- (n))
360  (%eval-redef 1+ (n))
361
362  (%eval-redef uvref (x y))
363  (%eval-redef uvset (x y z))
364  (%eval-redef uvsize (x))
365
366  (%eval-redef svref (x y))
367  (%eval-redef svset (x y z))
368 
369 
370 
371  (%eval-redef car (x))
372  (%eval-redef cdr (x))
373  (%eval-redef cons (x y))
374  (%eval-redef endp (x))
375
376  (progn
377    (%eval-redef typecode (x))
378    (%eval-redef lisptag (x))
379    (%eval-redef fulltag (x))
380    (%eval-redef %unbound-marker ())
381    (%eval-redef %slot-unbound-marker ())
382    (%eval-redef %slot-ref (v i))
383    (%eval-redef %alloc-misc (count subtag &optional (initial nil initial-p))
384                 (if initial-p
385                   (%alloc-misc count subtag initial)
386                   (%alloc-misc count subtag)))
387    (%eval-redef %setf-double-float (x y))
388    (%eval-redef %lisp-word-ref (x y))
389    (%eval-redef %temp-cons (x y))
390    (%eval-redef require-fixnum (x))
391    (%eval-redef require-symbol (x))
392    (%eval-redef require-list (x))
393    (%eval-redef require-real (x))
394    (%eval-redef require-simple-string (x))
395    (%eval-redef require-simple-vector (x))
396    (%eval-redef require-character (x))
397    (%eval-redef require-number (x))
398    (%eval-redef require-integer (x))
399    (%eval-redef require-s8 (x))
400    (%eval-redef require-u8 (x))
401    (%eval-redef require-s16 (x))
402    (%eval-redef require-u16 (x))
403    (%eval-redef require-s32 (x))
404    (%eval-redef require-u32 (x))
405    (%eval-redef require-s64 (x))
406    (%eval-redef require-u64 (x))
407    (%eval-redef %reference-external-entry-point (x))
408    )
409 
410  (%eval-redef %get-bit (ptr offset))
411  (%eval-redef %set-bit (ptr offset val))
412  (%eval-redef %get-double-float (ptr &optional (offset 0))
413               (%get-double-float ptr offset))
414  (%eval-redef %get-single-float (ptr &optional (offset 0))
415               (%get-single-float ptr offset))
416  (%eval-redef %set-double-float (p o &optional (new (prog1 o (setq o 0))))
417               (%set-double-float p o new))
418  (%eval-redef %set-single-float (p o &optional (new (prog1 o (setq o 0))))
419               (%set-single-float p o new))
420  (%eval-redef assq (item list))
421)
422
423; In the spirit of eval-redef ...
424
425
426;; pointer hacking stuff
427;
428;
429
430
431
432;;; I'd guess that the majority of bitfields in the world whose width is
433;;; greater than 1 have a width of two.  If that's true, this is probably
434;;; faster than trying to be more clever about it would be.
435(defun %get-bitfield (ptr start-bit width)
436  (declare (fixnum start-bit width))
437  (do* ((bit #+big-endian-target start-bit
438             #+little-endian-target (the fixnum (1- (the fixnum (+ start-bit width))))
439             #+big-endian-target (1+ bit)
440             #+little-endian-target (1- bit))
441        (i 0 (1+ i))
442        (val 0))
443       ((= i width) val)
444    (declare (fixnum val i bit))
445    (setq val (logior (ash val 1) (%get-bit ptr bit)))))
446
447(defun %set-bitfield (ptr start width val)
448  (declare (fixnum val start width))
449  (do* ((v val (ash v -1))
450        (bit #+big-endian-target (1- (+ start width))
451             #+little-endian-target start
452             #+big-endian-target (1- bit)
453             #+little-endian-target (1+ bit))
454        (i 0 (1+ i)))
455       ((= i width) val)
456    (declare (fixnum v bit i))
457    (setf (%get-bit ptr bit) (logand v 1))))
458
459; expands into compiler stuff
460
461(setf (symbol-function '%get-unsigned-byte) (symbol-function '%get-byte))
462(setf (symbol-function '%get-unsigned-word) (symbol-function '%get-word))
463(setf (symbol-function '%get-signed-long) (symbol-function '%get-long))
464
465(defun decompose-record-accessor (accessor &aux ret)
466  (do* ((str (symbol-name accessor) (%substr str (+ i 1) len))
467        (len (length str) (length str))
468        (i (%str-member #\. str) (%str-member #\. str))
469        (field (%substr str 0 (or i len)) (%substr str 0 (or i len))))
470       ((not i) (nreverse (cons (make-keyword field) ret)))
471    (push (make-keyword field) ret)))
472
473
474
475
476(provide 'level-2)
477
478       
479
480
481;; end of level-2.lisp
482
Note: See TracBrowser for help on using the repository browser.