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
;;; This is the Lucid lisp version of the file portable-low.
29
;;; Lucid: (415)329-8400
34
;;; First, import some necessary "internal" or Lucid-specific symbols
36
(eval-when (eval compile load)
38
(#-LCL3.0 progn #+LCL3.0 lcl:handler-bind
39
#+LCL3.0 ((lcl:warning #'(lambda (condition)
40
(declare (ignore condition))
41
(lcl:muffle-warning))))
43
#+LCL3.0 #'sys:import-from-lucid-pkg
44
#-LCL3.0 (let ((x (find-symbol "IMPORT-FROM-LUCID-PKG" "LUCID")))
45
(if (and x (fboundp x))
47
;; Only the #'(lambda (x) ...) below is really needed,
48
;; but when available, the "internal" function
49
;; 'import-from-lucid-pkg' provides better checking.
51
(import (intern name "LUCID")))))))
53
;; We need the following "internal", undocumented Lucid goodies:
54
(mapc importer '("%POINTER" "DEFSTRUCT-SIMPLE-PREDICATE"
55
#-LCL3.0 "LOGAND&" "%LOGAND&" #+VAX "LOGAND&-VARIABLE"))
58
;; For without-interrupts.
61
(mapc importer '("*SCHEDULER-WAKEUP*" "MAYBE-CALL-SCHEDULER"))
64
;; We import the following symbols, because in 2.1 Lisps they have to be
65
;; accessed as SYS:<foo>, whereas in 3.0 lisps, they are homed in the
66
;; LUCID-COMMON-LISP package.
67
(mapc importer '("ARGLIST" "NAMED-LAMBDA" "*PRINT-STRUCTURE*"))
69
;; We import the following symbols, because in 2.1 Lisps they have to be
70
;; accessed as LUCID::<foo>, whereas in 3.0 lisps, they have to be
71
;; accessed as SYS:<foo>
73
"NEW-STRUCTURE" "STRUCTURE-REF"
74
"STRUCTUREP" "STRUCTURE-TYPE" "STRUCTURE-LENGTH"
75
"PROCEDUREP" "PROCEDURE-SYMBOL"
76
"PROCEDURE-REF" "SET-PROCEDURE-REF"
79
; ;; The following is for the "patch" to the general defstruct printer.
81
; "OUTPUT-STRUCTURE" "DEFSTRUCT-INFO"
82
; "OUTPUT-TERSE-OBJECT" "DEFAULT-STRUCTURE-PRINT"
83
; "STRUCTURE-TYPE" "*PRINT-OUTPUT*"
86
;; The following is for a "patch" affecting compilation of %logand&.
87
;; On APOLLO, Domain/CommonLISP 2.10 does not include %logand& whereas
88
;; Domain/CommonLISP 2.20 does; Domain/CommonLISP 2.20 includes :DOMAIN/OS
89
;; on *FEATURES*, so this conditionalizes correctly for APOLLO.
90
#-(or (and APOLLO DOMAIN/OS) LCL3.0 VAX)
91
(mapc importer '("COPY-STRUCTURE" "GET-FDESC" "SET-FDESC"))
101
;;; Patch up for the fact that the PCL package creation in defsys.lisp
102
;;; will probably have an explicit :use list ??
104
;;; #+LCL3.0 (use-package *default-make-package-use-list*)
112
(defvar *saved-compilation-speed* 3)
114
; the production compiler sometimes
115
; screws up vars within labels
117
(defmacro dont-use-production-compiler ()
118
'(eval-when (compile)
119
(setq *saved-compilation-speed* (if LUCID:*USE-SFC* 3 0))
120
(proclaim '(optimize (compilation-speed 3)))))
122
(defmacro use-previous-compiler ()
123
`(eval-when (compile)
124
(proclaim '(optimize (compilation-speed ,*saved-compilation-speed*)))))
128
(defmacro %logand (x y)
129
#-VAX `(%logand& ,x ,y)
130
#+VAX `(logand&-variable ,x ,y))
134
(defun logand&-variable (x y)
135
(logand&-variable x y))
137
;;; Fix for other LCLs
138
#-(or (and APOLLO DOMAIN/OS) LCL3.0 VAX)
139
(eval-when (compile load eval)
141
(let* ((logand&-fdesc (get-fdesc 'logand&))
142
(%logand&-fdesc (copy-structure logand&-fdesc)))
143
(setf (structure-ref %logand&-fdesc 0 t) '%logand&)
144
(setf (structure-ref %logand&-fdesc 7 t) nil)
145
(setf (structure-ref %logand&-fdesc 8 t) nil)
146
(set-fdesc '%logand& %logand&-fdesc))
149
(defun %logand& (x y) (%logand& x y)))
152
(compile '%logand& '(lambda (x y) (%logand& x y))))
154
);#-(or LCL3.0 (and APOLLO DOMAIN/OS) VAX)
158
;;; Date: November 28th, 1988
160
;;; Here's a better attempt to do the without-interrupts macro for LCL3.0.
161
;;; For the 2.1 release, maybe you should just ignore it (i.e, turn it
162
;;; into a PROGN and "take your chances") since there isn't a uniform way
163
;;; to do inhibition. 2.1 has interrupts, but no multiprocessing.
165
;;; The best bet for protecting the cache is merely to inhibit the
166
;;; scheduler, since asynchronous interrupts are only run when "scheduled".
167
;;; Of course, there may be other interrupts, which can cons and which
168
;;; could cause a GC; but at least they wouldn't be running PCL type code.
170
;;; Note that INTERRUPTS-ON shouldn't arbitrarily enable scheduling again,
171
;;; but rather simply restore it to the state outside the scope of the call
172
;;; to WITHOUT-INTERRUPTS. Note also that an explicit call to
173
;;; MAYBE-CALL-SHEDULER must be done when "turning interrupts back on", if
174
;;; there are any interrupts/schedulings pending; at least the test to see
175
;;; if any are pending is very fast.
178
(defmacro without-interrupts (&body body)
179
`(macrolet ((interrupts-on ()
180
`(when (null outer-scheduling-state)
181
(setq lcl:*inhibit-scheduling* nil)
182
(when *scheduler-wakeup* (maybe-call-scheduler))))
184
'(setq lcl:*inhibit-scheduling* t)))
185
(let ((outer-scheduling-state lcl:*inhibit-scheduling*))
186
(prog1 (let ((lcl:*inhibit-scheduling* t)) . ,body)
187
(when (and (null outer-scheduling-state) *scheduler-wakeup*)
188
(maybe-call-scheduler))))))
191
;;; The following should override the definitions provided by lucid-low.
193
#+(or LCL3.0 (and APOLLO DOMAIN/OS))
195
(defstruct-simple-predicate std-instance std-instance-p)
196
(defstruct-simple-predicate fast-method-call fast-method-call-p)
197
(defstruct-simple-predicate method-call method-call-p)
202
(defun set-function-name-1 (fn new-name ignore)
203
(declare (ignore ignore))
204
(if (not (procedurep fn))
205
(error "~S is not a procedure." fn)
206
(if (compiled-function-p fn)
208
;; compiled-function, funcallable-instance, compiled-closure
210
;; So just go ahead and set its name.
211
;; Only change the name when necessary: maybe it is read-only.
212
(unless (eq new-name (procedure-ref fn procedure-symbol))
213
(set-procedure-ref fn procedure-symbol new-name))
214
;; This is an interpreted function.
215
;; Seems like any number of different things can happen depending
216
;; vaguely on what release you are running. Try to do something
218
(let ((symbol (procedure-ref fn procedure-symbol)))
219
(cond ((symbolp symbol)
220
;; In fact, this is the name of the procedure.
222
(set-procedure-ref fn procedure-symbol new-name))
224
(eq (car symbol) 'lambda))
225
(setf (car symbol) 'named-lambda
226
(cdr symbol) (cons new-name (cdr symbol))))
227
((eq (car symbol) 'named-lambda)
228
(setf (cadr symbol) new-name))))))
231
(defun function-arglist (fn)
235
;;;;;; printing-random-thing-internal
237
(defun printing-random-thing-internal (thing stream)
238
(format stream "~O" (%pointer thing)))
242
;;; 16-Feb-90 Jon L White
244
;;; A Patch provide specifically for the benefit of PCL, in the Lucid 3.0
245
;;; release environment. This adds type optimizers for FUNCALL so that
248
;;; (FUNCALL (THE PROCEDURE F) ...)
252
;;; (LET ((F (Frobulate)))
253
;;; (DECLARE (TYPE COMPILED-FUNCTION F))
256
;;; will just jump directly to the procedure code, rather than waste time
257
;;; trying to coerce the functional argument into a procedure.
264
;;; (DECLARE-MACHINE-CLASS COMMON)
265
(set-up-compiler-target 'common)
268
(set-function-descriptor 'FUNCALL
272
:OPTIMIZER #'(lambda (form &optional environment)
273
(declare (ignore form environment))
274
(let* ((fun (second form))
275
(lambdap (and (consp fun)
276
(eq (car fun) 'function)
278
(memq (car (second fun))
279
'(lambda internal-lambda)))))
283
(cons (second fun) (cddr form)) environment))))
284
:FUNCTIONTYPE '(function (function &rest t) (values &rest t))
285
:TYPE-DISPATCH `(((PROCEDURE &REST T) (VALUES &REST T)
286
,#'(lambda (anode fun &rest args)
287
(declare (ignore anode fun args))
288
`(FAST-FUNCALL ,fun ,@args)))
289
((COMPILED-FUNCTION &REST T) (VALUES &REST T)
290
,#'(lambda (anode fun &rest args)
291
(declare (ignore anode fun args))
292
`(FAST-FUNCALL ,fun ,@args))))
293
:LAMBDALIST '(FN &REST ARGUMENTS)
298
(def-compiler-macro fast-funcall (&rest args &environment env)
299
(if (COMPILER-OPTION-SET-P :READ-SAFETY ENV)
300
`(FUNCALL-SUBR . ,args)
301
`(&FUNCALL . ,args)))
305
(setf (symbol-function 'funcall-subr) #'funcall)
308
;;; (UNDECLARE-MACHINE-CLASS)
309
(restore-compiler-params)
314
(pushnew :structure-wrapper *features*)
316
(defun structure-functions-exist-p ()
319
(defun structure-instance-p (x)
321
(not (eq 'std-instance (structure-type x)))))
323
(defvar *structure-type* nil)
324
(defvar *structure-length* nil)
326
(defun structure-type-p (type)
327
(declare (special lucid::*defstructs*))
328
(let ((s-data (gethash type lucid::*defstructs*)))
330
(eq 'structure (structure-ref s-data 1 'defstruct))) ; type - Fix this
331
(and type (eq *structure-type* type)))))
333
(defun structure-type-included-type-name (type)
334
(declare (special lucid::*defstructs*))
335
(let ((s-data (gethash type lucid::*defstructs*)))
336
(and s-data (structure-ref s-data 6 'defstruct)))) ; include - Fix this
338
(defun structure-type-slot-description-list (type)
339
(declare (special lucid::*defstructs*))
340
(let ((s-data (gethash type lucid::*defstructs*)))
342
(nthcdr (let ((include (structure-ref s-data 6 'defstruct)))
344
(let ((inc-s-data (gethash include lucid::*defstructs*)))
346
(length (structure-ref inc-s-data 7 'defstruct))
351
(let* ((ds 'lucid::defstruct-slot)
352
(slot-name (system:structure-ref slotd 0 ds))
353
(position (system:structure-ref slotd 1 ds))
354
(accessor (system:structure-ref slotd 2 ds))
355
(read-only-p (system:structure-ref slotd 5 ds)))
356
(list slot-name accessor
358
(system:structure-ref x position type))
361
(setf (system:structure-ref x position type)
363
(structure-ref s-data 7 'defstruct))) ; slots - Fix this
364
(let ((result (make-list *structure-length*)))
365
(dotimes (i *structure-length* result)
366
(let* ((name (format nil "SLOT~D" i))
367
(slot-name (intern name (or (symbol-package type) *package*)))
369
(setf (elt result i) (list slot-name nil
371
(system:structure-ref x i type))
374
(defun structure-slotd-name (slotd)
377
(defun structure-slotd-accessor-symbol (slotd)
380
(defun structure-slotd-reader-function (slotd)
383
(defun structure-slotd-writer-function (slotd)
added
removed
pcl/impl/lucid/lucid-low.lisp
