1
;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*-
3
;;; *************************************************************************
4
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
5
;;; All rights reserved.
7
;;; Use and copying of this software and preparation of derivative works
8
;;; based upon this software are permitted. Any distribution of this
9
;;; software or derivative works must comply with all applicable United
10
;;; States export control laws.
12
;;; This software is made available AS IS, and Xerox Corporation makes no
13
;;; warranty about the software, its performance or its conformity to any
16
;;; Any person obtaining a copy of this software is requested to send their
17
;;; name and post office or electronic mail address to:
18
;;; CommonLoops Coordinator
20
;;; 3333 Coyote Hill Rd.
21
;;; Palo Alto, CA 94304
22
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
24
;;; Suggestions, comments and requests for improvements are also welcome.
25
;;; *************************************************************************
27
;;; The version of low for Kyoto Common Lisp (KCL)
29
(export '(%structure-name
30
%compiled-function-name
31
%set-compiled-function-name
36
(shadow 'lisp:dotimes)
38
(defmacro dotimes ((var form &optional (val nil)) &rest body &environment env)
39
(multiple-value-bind (doc decls bod)
40
(extract-declarations body env)
41
(declare (ignore doc))
42
(let ((limit (gensym))
46
(declare (fixnum ,limit ,var))
51
(when (>= ,var ,limit) (return-from nil ,val))
53
(setq ,var (the fixnum (1+ ,var)))
56
(defun memq (item list) (member item list :test #'eq))
57
(defun assq (item list) (assoc item list :test #'eq))
58
(defun posq (item list) (position item list :test #'eq))
60
(si:define-compiler-macro memq (item list)
64
(loop (unless ,var (return nil))
65
(when (eq ,item (car ,var))
67
(setq ,var (cdr ,var)))))))
69
(si:define-compiler-macro assq (item list)
72
`(dolist (,var ,list nil)
73
(when (eq ,item (car ,var))
76
(si:define-compiler-macro posq (item list)
77
(let ((var (gensym)) (index (gensym)))
79
`(let ((,var ,list) (,index 0))
80
(declare (fixnum ,index))
81
(dolist (,var ,list nil)
86
(defun printing-random-thing-internal (thing stream)
87
(format stream "~X" (si:address thing)))
89
(defmacro %svref (vector index)
90
`(svref (the simple-vector ,vector) (the fixnum ,index)))
92
(defsetf %svref (vector index) (new-value)
93
`(setf (svref (the simple-vector ,vector) (the fixnum ,index))
101
(si:define-compiler-macro std-instance-p (x)
103
`(and (si:structurep ,x)
104
(eq (si:%structure-name ,x) 'std-instance))))
110
;; declare that std-instance-p may be computed simply, and will not change.
111
(si::freeze-defstruct 'std-instance)
113
(si::freeze-defstruct 'method-call)
114
(si::freeze-defstruct 'fast-method-call)
116
(defvar *pcl-funcall*
119
"{object _funobj = " loc ";"
120
"if(Rset&&type_of(_funobj)!=t_symbol)funcall_no_event(_funobj);
121
else super_funcall(_funobj);}")))
123
(setq compiler::*super-funcall* *pcl-funcall*)
125
(defmacro fmc-funcall (fn pv-cell next-method-call &rest args)
126
`(funcall ,fn ,pv-cell ,next-method-call ,@args))
131
;;; turbo-closure patch. See the file kcl-mods.text for details.
133
#-turbo-closure-env-size
135
object cclosure_env_nthcdr (n,cc)
139
if(type_of(cc)!=t_cclosure)return Cnil;
142
{if(type_of(env)!=t_cons)return Cnil;
147
#+turbo-closure-env-size
149
object cclosure_env_nthcdr (n,cc)
153
if(type_of(cc)!=t_cclosure)return Cnil;
154
if((turbo=cc->cc.cc_turbo)==NULL)
157
{if(type_of(env)!=t_cons)return Cnil;
161
{if(n>=fix(*(turbo-1)))return Cnil;
165
;; This is the completely safe version.
166
(defentry cclosure-env-nthcdr (int object) (object cclosure_env_nthcdr))
167
;; This is the unsafe but fast version.
168
(defentry %cclosure-env-nthcdr (int object) (object cclosure_env_nthcdr))
170
;;; #+akcl means this is an AKCL newer than 5/11/89 (structures changed)
171
(eval-when (compile load eval)
176
(defun instance-ref (slots index)
177
(si:structure-ref1 slots index))
179
(defun set-instance-ref (slots index value)
180
(si:structure-set1 slots index value))
182
(defsetf instance-ref set-instance-ref)
183
(defsetf %instance-ref %set-instance-ref)
186
(defsetf structure-def set-structure-def)
188
;;((name args-type result-type side-effect-p new-object-p c-expression) ...)
189
(defparameter *kcl-function-inlines*
190
'((%fboundp (t) compiler::boolean nil nil "(#0)->s.s_gfdef!=OBJNULL")
191
(%symbol-function (t) t nil nil "(#0)->s.s_gfdef")
192
#-akcl (si:structurep (t) compiler::boolean nil nil "type_of(#0)==t_structure")
193
#-akcl (si:%structure-name (t) t nil nil "(#0)->str.str_name")
194
#+akcl (si:%structure-name (t) t nil nil "(#0)->str.str_def->str.str_self[0]")
196
(si:%instance-ref (t t) t nil nil "(#0)->str.str_self[fix(#1)]")
198
(si:%set-instance-ref (t t t) t t nil "(#0)->str.str_self[fix(#1)]=(#2)")
199
(si:%compiled-function-name (t) t nil nil "(#0)->cf.cf_name")
200
(si:%set-compiled-function-name (t t) t t nil "((#0)->cf.cf_name)=(#1)")
201
(cclosurep (t) compiler::boolean nil nil "type_of(#0)==t_cclosure")
202
#+akcl (sfun-p (t) compiler::boolean nil nil "type_of(#0)==t_sfun")
203
(%cclosure-env (t) t nil nil "(#0)->cc.cc_env")
204
(%set-cclosure-env (t t) t t nil "((#0)->cc.cc_env)=(#1)")
206
(%cclosure-env-nthcdr (fixnum t) t nil nil "(#1)->cc.cc_turbo[#0]")
208
(logxor (fixnum fixnum) fixnum nil nil "((#0) ^ (#1))")))
210
(defun make-function-inline (inline)
211
(setf (get (car inline) 'compiler::inline-always)
212
(list (if (fboundp 'compiler::flags)
213
(let ((opt (cdr inline)))
214
(list (first opt) (second opt)
215
(logior (if (fourth opt) 1 0) ; allocates-new-storage
216
(if (third opt) 2 0) ; side-effect
217
(if nil 4 0) ; constantp
218
(if (eq (car inline) 'logxor)
219
8 0)) ;result type from args
223
(defmacro define-inlines ()
225
,@(mapcan #'(lambda (inline)
226
(let* ((*package* *the-pcl-package*)
227
(name (intern (format nil "~S inline" (car inline))))
228
(vars (mapcar #'(lambda (type)
229
(declare (ignore type))
232
`((make-function-inline ',(cons name (cdr inline)))
233
,@(when (or (every #'(lambda (type) (eq type 't))
235
(char= #\% (aref (symbol-name (car inline)) 0)))
236
`((defun ,(car inline) ,vars
237
,@(mapcan #'(lambda (var var-type)
238
(unless (eq var-type 't)
239
`((declare (type ,var-type ,var)))))
242
(make-function-inline ',inline))))))
243
*kcl-function-inlines*)))
248
(defsetf si:%compiled-function-name si:%set-compiled-function-name)
249
(defsetf %cclosure-env %set-cclosure-env)
251
(defun set-function-name-1 (fn new-name ignore)
252
(declare (ignore ignore))
253
(cond ((compiled-function-p fn)
254
(si::turbo-closure fn)
255
;;(when (symbolp new-name) (proclaim-defgeneric new-name nil))
256
(setf (si:%compiled-function-name fn) new-name))
258
(eq (car fn) 'lambda-block))
259
(setf (cadr fn) new-name))
261
(eq (car fn) 'lambda))
262
(setf (car fn) 'lambda-block
263
(cdr fn) (cons new-name (cdr fn)))))
267
#+akcl (clines "#define AKCL206")
274
object set_cclosure (result_cc,value_cc,available_size)
275
object result_cc,value_cc; int available_size;
277
object result_env_tail,value_env_tail; int i;
279
/* If we are currently using fast linking, */
280
/* make sure to remove the link for result_cc. */
281
use_fast_links(3,Cnil,result_cc);
283
result_env_tail=result_cc->cc.cc_env;
284
value_env_tail=value_cc->cc.cc_env;
285
for(i=available_size;
286
result_env_tail!=Cnil && i>0;
287
result_env_tail=CMPcdr(result_env_tail), value_env_tail=CMPcdr(value_env_tail))
288
CMPcar(result_env_tail)=CMPcar(value_env_tail), i--;
289
result_cc->cc.cc_self=value_cc->cc.cc_self;
290
result_cc->cc.cc_data=value_cc->cc.cc_data;
292
result_cc->cc.cc_start=value_cc->cc.cc_start;
293
result_cc->cc.cc_size=value_cc->cc.cc_size;
298
(defentry %set-cclosure (object object int) (object set_cclosure))
301
(defun structure-functions-exist-p ()
304
(si:define-compiler-macro structure-instance-p (x)
306
`(and (si:structurep ,x)
307
(not (eq (si:%structure-name ,x) 'std-instance)))))
309
(defun structure-type (x)
310
(and (si:structurep x)
311
(si:%structure-name x)))
313
(si:define-compiler-macro structure-type (x)
315
`(and (si:structurep ,x)
316
(si:%structure-name ,x))))
318
(defun structure-type-p (type)
319
(or (not (null (gethash type *structure-table*)))
320
(let (#+akcl(s-data nil))
322
#+akcl (setq s-data (get type 'si::s-data))
323
#-akcl (get type 'si::is-a-structure)
324
(null #+akcl (si::s-data-type s-data)
325
#-akcl (get type 'si::structure-type))))))
327
(defun structure-type-included-type-name (type)
328
(or (car (gethash type *structure-table*))
329
#+akcl (let ((includes (si::s-data-includes (get type 'si::s-data))))
331
(si::s-data-name includes)))
332
#-akcl (get type 'si::structure-include)))
334
(defun structure-type-internal-slotds (type)
335
#+akcl (si::s-data-slot-descriptions (get type 'si::s-data))
336
#-akcl (get type 'si::structure-slot-descriptions))
338
(defun structure-type-slot-description-list (type)
339
(or (cdr (gethash type *structure-table*))
340
(mapcan #'(lambda (slotd)
342
(when (and slotd (car slotd))
343
(let ((offset (fifth slotd)))
344
(let ((reader #'(lambda (x)
345
#+akcl (si:structure-ref1 x offset)
346
#-akcl (si:structure-ref x type offset)))
347
(writer #'(lambda (v x)
348
(si:structure-set x type offset v))))
349
#+turbo-closure (si:turbo-closure reader)
350
#+turbo-closure (si:turbo-closure writer)
352
(let ((*package* *the-pcl-package*))
353
(intern (format nil "~s SLOT~D" type offset))))
354
(writer-sym (get-setf-function-name reader-sym))
355
(slot-name (first slotd))
356
(read-only-p (fourth slotd)))
357
(setf (symbol-function reader-sym) reader)
358
(setf (symbol-function writer-sym) writer)
359
(do-standard-defsetf-1 reader-sym)
360
(list (list slot-name
363
(and (not read-only-p) writer)))))))
366
(let ((slotds (structure-type-internal-slotds type))
367
(inc (structure-type-included-type-name type)))
369
(nthcdr (length (structure-type-internal-slotds inc))
374
(defun si::slot-reader-function (slot)
375
(let ((offset (si::slot-offset slot)))
376
(si:turbo-closure #'(lambda (x)
377
(si::structure-ref1 x offset)))))
380
(defun si::slot-writer-function (slot)
381
(let ((offset (si::slot-offset slot)))
382
(si:turbo-closure #'(lambda (x)
383
(si::structure-set1 x offset)))))
385
(mapcar #'(lambda (fname value)
386
(setf (symbol-function fname) (symbol-function value)))
387
'(structure-slotd-name
388
structure-slotd-accessor-symbol
389
structure-slotd-reader-function
390
structure-slotd-writer-function
392
structure-slotd-init-form)
394
'(first second third fourth function-returning-nil function-returning-nil)
396
'(si::slot-name si::slot-accessor-name
397
si::slot-reader-function si::slot-writer-function
398
si::slot-type si::slot-default-init))
401
;; Construct files sys-proclaim.lisp and sys-package.lisp
402
;; The file sys-package.lisp must be loaded first, since the
403
;; package sys-proclaim.lisp will refer to symbols and they must
404
;; be in the right packages. sys-proclaim.lisp contains function
405
;; declarations and declarations that certain things are closures.
407
(defun renew-sys-files()
409
(compiler::get-packages "sys-package.lisp")
410
(with-open-file (st "sys-package.lisp"
413
(format st "(in-package 'SI)
414
(export '(%structure-name
415
%compiled-function-name
416
%set-compiled-function-name))
421
(compiler::make-all-proclaims "*.fn")
422
(let ((*package* (find-package 'user)))
423
(with-open-file (st "sys-proclaim.lisp"
426
;;(format st "~%(IN-PACKAGE \"PCL\")~%")
430
(sloop::sloop for v in-package "PCL"
431
when (get v 'compiler::proclaimed-closure)
433
(setf (get v 'compiler::proclaimed-closure) t))
added
removed
pcl/impl/kcl/kcl-low.lisp
