1
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: ZL-USER; Base: 10; Patch-File: T -*-
3
;=====================================
4
(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
5
(SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:l-COMPILER;OPTIMIZE.LISP.179")
6
(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
7
"-*- Mode: Lisp; Package: Compiler; Lowercase: T; Base: 8 -*-")
9
;;; Does simple constant folding. This works for everything that doesn't have
11
;;; ALL operands must be constant.
12
;;; Note that commutative-constant-folder can hack this case perfectly well
13
;;; by himself for the functions he handles.
14
(defun constant-fold-optimizer (form)
15
(let ((eval-when-load-p nil))
16
(flet ((constant-form-p (x)
17
(when (constant-form-p x)
21
(eq (caadr x) eval-at-load-time-marker))
22
(setq eval-when-load-p t)
25
(if (every (cdr form) #'constant-form-p)
28
(list* eval-at-load-time-marker
30
(mapcar #'constant-form-p (cdr form))))
31
(condition-case (error-object)
32
(multiple-value-call #'(lambda (&rest values)
33
(if (= (length values) 1)
35
`(values ,@(mapcar #'(lambda (x) `',x)
39
(phase-1-warning "Constant form left unoptimized: ~S~%because: ~~A~"
45
;=====================================
46
(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
47
(SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:L-COMPILER;COMFILE.LISP.85")
48
(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
49
"-*- Mode: Lisp; Package: Compiler; Lowercase: T; Base: 8 -*-")
52
;;; The damn compiler doesn't compile random forms that appear at top level.
53
;;; Its difficult to do because you have to get an associated function spec
54
;;; to go with those forms. This handles that by defining a special form,
55
;;; top-level-form that compiles its body. It takes a list of eval-when
56
;;; times just like eval when does. It also takes a name which it uses
57
;;; to construct a function spec for the top-level-form function it has
62
;(defvar *top-level-form-fdefinitions* (cl:make-hash-table :test #'equal))
65
;(define-function-spec-handler pcl::top-level-form
66
; (operation fspec &optional arg1 arg2)
67
; (let ((name (cadr fspec)))
69
; (validate-function-spec (and (= (length fspec) 2)
73
; (setf (gethash name *top-level-form-fdefinitions*) arg1))
74
; ((fdefinition fdefinedp)
75
; (gethash name *top-level-form-fdefinitions*))
76
; (fdefinition-location
77
; (ferror "It is not possible to get the fdefinition-location of ~s."
79
; (fundefine (remhash name *top-level-form-fdefinitions*))
80
; (otherwise (function-spec-default-handler operation fspec arg1 arg2)))))
83
;;; This is basically stolen from PROGN (surprised?)
85
;(si:define-special-form pcl::top-level-form (name times
88
; (declare lt:(arg-template . body) (ignore name))
89
; (si:check-eval-when-times times)
90
; (when (member 'eval times) (si:eval-body body env)))
92
;(defun (:property pcl::top-level-form lt:mapforms) (original-form form usage)
93
; (lt::mapforms-list original-form form (cddr form) 'eval usage))
95
;;; This is the normal function for looking at each form read from the file and calling
96
;;; *COMPILE-FORM-FUNCTION* on the sub-forms of it.
97
;;; COMPILE-TIME-TOO means override the normal cases that eval at compile time. It is
98
;;; used for recursive calls under (EVAL-WHEN (COMPILE LOAD) ...).
99
;(DEFUN COMPILE-FROM-STREAM-1 (FORM &OPTIONAL (COMPILE-TIME-TOO NIL))
100
; (CATCH-ERROR-RESTART
101
; (SYS:ERROR "Skip compiling form ~2,2\COMPILER:SHORT-S-FORMAT\" FORM)
102
; (LET ((DEFAULT-CONS-AREA (FUNCALL *COMPILE-FUNCTION* ':CONS-AREA)))
103
; (LET ((ERROR-MESSAGE-HOOK
105
; (DECLARE (SYS:DOWNWARD-FUNCTION))
106
; (FORMAT T "~&While processing ~V,V\COMPILER:SHORT-S-FORMAT\"
107
; DBG:*ERROR-MESSAGE-PRINLEVEL*
108
; DBG:*ERROR-MESSAGE-PRINLENGTH*
110
; (SETQ FORM (FUNCALL *COMPILE-FUNCTION* ':MACRO-EXPAND FORM)))
111
; (WHEN (LISTP FORM) ;Ignore atoms at top-level
112
; (LET ((FUNCTION (FIRST FORM)))
114
; ((QUOTE)) ;and quoted constants e.g. 'COMPILE
116
; (DOLIST (FORM (CDR FORM))
117
; (COMPILE-FROM-STREAM-1 FORM COMPILE-TIME-TOO)))
119
; (SI:CHECK-EVAL-WHEN-TIMES (CADR FORM))
120
; (LET ((COMPILE-P (OR (MEMQ 'COMPILE (CADR FORM))
121
; (AND COMPILE-TIME-TOO (MEMQ 'EVAL (CADR FORM)))))
122
; (LOAD-P (OR (MEMQ 'LOAD (CADR FORM)) (MEMQ 'CL:LOAD (CADR FORM))))
123
; (FORMS (CDDR FORM)))
125
; (DOLIST (FORM FORMS)
126
; (COMPILE-FROM-STREAM-1 FORM (AND COMPILE-P ':FORCE))))
128
; (DOLIST (FORM FORMS)
129
; (FUNCALL *COMPILE-FORM-FUNCTION* FORM ':FORCE NIL))))))
131
; (LET ((TEM (DEFUN-COMPATIBILITY (CDR FORM) :WARN-IF-OBSOLETE T)))
132
; (IF (EQ (CDR TEM) (CDR FORM))
133
; (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T)
134
; (COMPILE-FROM-STREAM-1 TEM COMPILE-TIME-TOO))))
136
; (FUNCALL *COMPILE-FORM-FUNCTION* FORM (OR COMPILE-TIME-TOO T) T))
138
; (DOLIST (FORM (CDR FORM))
139
; (FUNCALL *COMPILE-FORM-FUNCTION* FORM (OR COMPILE-TIME-TOO T)
140
; ;; (DECLARE (SPECIAL ... has load-time action as well.
141
; ;; All other DECLARE's do not.
142
; (MEMQ (CAR FORM) '(SPECIAL ZL:UNSPECIAL)))))
144
; (COMPILER-LET-INTERNAL (CADR FORM) (CDDR FORM)
145
; #'COMPILE-FROM-STREAM-1 COMPILE-TIME-TOO))
146
; ((SI:DEFINE-SPECIAL-FORM)
147
; (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T))
148
; ((MULTIPLE-DEFINITION)
149
; (DESTRUCTURING-BIND (NAME TYPE . BODY) (CDR FORM)
150
; (LET ((NAME-VALID (AND (NOT (NULL NAME))
152
; (AND (LISTP NAME) (NEQ (CAR NAME) 'QUOTE)))))
153
; (TYPE-VALID (AND (NOT (NULL TYPE)) (SYMBOLP TYPE))))
154
; (UNLESS (AND NAME-VALID TYPE-VALID)
155
; (WARN "(~S ~S ~S ...) is invalid because~@
156
; ~:[~S is not valid as a definition name~;~*~]~
157
; ~:[~&~S is not valid as a definition type~;~*~]"
158
; 'MULTIPLE-DEFINITION NAME TYPE NAME-VALID NAME TYPE-VALID TYPE)))
159
; (LET* ((COMPILED-BODY NIL)
160
; (COMPILE-FUNCTION *COMPILE-FUNCTION*)
161
; (*COMPILE-FUNCTION*
162
; (LAMBDA (OPERATION &REST ARGS)
163
; (DECLARE (SYS:DOWNWARD-FUNCTION))
166
; (PUSH (FUNCALL COMPILE-FUNCTION :OPTIMIZE-TOP-LEVEL-FORM
169
; (:INSTALL-DEFINITION
170
; (PUSH (FORM-FOR-DEFINE *COMPILER* (FIRST ARGS) (SECOND ARGS))
172
; (OTHERWISE (CL:APPLY COMPILE-FUNCTION OPERATION ARGS)))))
173
; (LOCAL-DECLARATIONS `((FUNCTION-PARENT ,NAME ,TYPE)
174
; ,@LOCAL-DECLARATIONS)))
175
; (DOLIST (FORM BODY)
176
; (COMPILE-FROM-STREAM-1 FORM COMPILE-TIME-TOO))
177
; (FUNCALL COMPILE-FUNCTION :DUMP-FORM
178
; `(LOAD-MULTIPLE-DEFINITION
179
; ',NAME ',TYPE ',(NREVERSE COMPILED-BODY) NIL)))))
180
; ((pcl::top-level-form)
181
; (destructuring-bind (name times . body)
183
; (si:check-eval-when-times times)
184
; (let ((compile-p (or (memq 'compile times)
185
; (and compile-time-too (memq 'eval times))))
186
; (load-p (or (memq 'load times)
187
; (memq 'cl:load times)))
188
; (fspec `(pcl::top-level-form ,name)))
190
; (compile-from-stream-1
191
; `(progn (defun ,fspec () . ,body)
192
; (funcall (function ,fspec)))
193
; (and compile-p ':force)))
196
; (funcall *compile-form-function* form ':force nil)))))))
198
; (LET ((TEM (AND (SYMBOLP FUNCTION) (GET FUNCTION 'TOP-LEVEL-FORM))))
200
; (FUNCALL *COMPILE-FORM-FUNCTION* (FUNCALL TEM FORM) COMPILE-TIME-TOO T)
201
; (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T))))))))))
207
(defun symbol-flavor-or-cl-type (symbol)
208
(declare (values flavor defstruct-p deftype-fun typep-fun atomic-subtype-parent
210
(multiple-value-bind (result foundp)
211
(gethash symbol *flavor-or-cl-type-cache*)
214
(setf (gethash symbol *flavor-or-cl-type-cache*)
215
(or (get symbol 'flavor:flavor)
216
(let ((class (get symbol 'clos-internals::class-for-name)))
218
(not (typep class 'clos:built-in-class)))
220
(not (null (defstruct-type-p symbol)))
221
(let* ((deftype (get symbol 'deftype))
222
(descriptor (symbol-presentation-type-descriptor symbol))
224
(unless (and descriptor
225
(presentation-type-explicit-type-function
227
;; Don't override the one defined in the presentation-type.
228
(get symbol 'typep)))
229
(atomic-subtype-parent (find-atomic-subtype-parent symbol))
231
(when (and (not descriptor) deftype)
232
(not (member (first (type-arglist symbol))
233
'(&rest &key &optional))))))
234
(if (or typep (not (atom deftype))
236
;; deftype overrides atomic-subtype-parent.
237
(and (not deftype) atomic-subtype-parent))
238
(list-in-area *handler-dynamic-area*
239
deftype typep atomic-subtype-parent
242
(locally (declare (inline compiled-function-p))
244
(array (values frob))
245
(instance (values frob))
247
((member t) (values nil t))
248
(compiled-function (values nil nil frob))
249
(lexical-closure (values nil nil frob))
250
(list (destructuring-bind (deftype typep atomic-subtype-parent non-atomic-deftype)
252
(values nil nil deftype typep atomic-subtype-parent non-atomic-deftype)))
253
(symbol (values nil nil nil nil frob)))))))
added
removed
pcl/impl/symbolics/rel-8-patches.lisp
