forked from franzinc/clim2
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathclos-patches.lisp
154 lines (132 loc) · 6.23 KB
/
clos-patches.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
;; See the file LICENSE for the full license governing this code.
;;
(in-package :clim-utils)
;;;"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved."
;;; This file contains various patches to get around current deficiencies
;;; in various CLOS implementations
#+Lucid
;; In Lucid 4.0, JonL advises that this is needed because we haven't explicitly
;; provided for anonymous classes, and thus some level of error checking will
;; gratuitously slap your hand.
(lucid-common-lisp:defadvice (clos::find-class-set allow-nil)
(new-value symbol &optional errorp)
(if (null symbol) nil (lucid-common-lisp:advice-continue new-value symbol errorp)))
#+Lucid
;; I can't figure out how to do this, so for now we will not try to keep the
;; compilation and run-time environments properly separated.
(defun-inline compile-file-environment-p (environment)
(declare (ignore environment))
nil)
#+allegro
(defun-inline compile-file-environment-p (environment)
#-(version>= 7 0)
(or (eq environment 'compile-file) excl::*compiler-environment*)
#+(version>= 7 0)
(or (and sys::*compile-file-environment*
(excl::compilation-environment-p environment)
environment)
sys::*compile-file-environment*))
#+(and allegro never-in-a-million-years)
(eval-when (compile)
(warn "~S hacked for lack of environment support in 4.1" 'compile-file-environment-p))
#+CCL-2
(defun-inline compile-file-environment-p (environment)
(if (eq environment 'compile-file)
t
(ccl::compile-file-environment-p environment)))
#+(and allegro (not (version>= 4 1)))
(defgeneric make-load-form (object))
#+(and allegro (not (version>= 4 1 40))) ; 40 is arbitrary, I mean > beta. ;; Allegro CL doesn't have MAKE-LOAD-FORM, so add it (with advice from Foderaro)
(excl:defadvice comp::wfasl-lispobj (implement-make-load-form :before)
(let ((object (first excl:arglist)))
(when (typep object 'standard-object)
(multiple-value-bind (form1 form2)
(make-load-form object)
(when form2
(error "MAKE-LOAD-FORM with two values is not supported yet.~@
(MAKE-LOAD-FORM ~S) => ~S ~S"
object form1 form2))
(return
(apply #'comp::wfasl-lispobj
(cons compiler::*eval-when-load-marker* form1)
(rest excl:arglist)))))))
#+(and allegro (not (version>= 4 1 40)))
(excl:compile-advice 'comp::wfasl-lispobj)
#+Lucid
;; Work around a Lucid 4.0 bug in anonymous classes
;; JonL suggests that a better way might be to leave CLASS-NAME = NIL
;; and store that information in our own private slot, then we won't
;; trigger this bug by having a non-symbol in the NAME slot
(lucid-common-lisp:defadvice (lucid:class-or-class-name-p fix-list-named-class)
(&rest args)
(let ((answer (lucid-common-lisp:apply-advice-continue args)))
(if (consp answer)
(first args) ;return the class
answer)))
#+(and allegro (not (version>= 4 0)))
;;; This is needed to prevent a MAKE-LOAD-FORM form from being evaluated before
;;; an earlier top-level form, says Foderaro. Even the forward reference allowed
;;; by load-reference-to-presentation-type-class isn't sufficient without this,
;;; because a MAKE-LOAD-FORM form for a presentatation type class could be evaluated
;;; before a superclass has been defined.
(eval-when (compile load eval)
(setq compiler::.random-forms-max. 0))
;;; Go through this rigamarole because WITH-SLOTS doesn't accept declarations
;;; on old versions of Lucid and Franz Allegro
#+(and allegro (not (version>= 4 1)))
(lisp:defun slot-value-alist (body)
(declare (values real-body alist))
(let ((alist nil))
(do* ((real-body body (cdr real-body))
(form (car real-body) (car real-body)))
((or (null real-body)
(not (and (consp form)
(eq (first form) 'declare))))
(values real-body alist))
(dolist (spec (rest form))
(let ((type (if (eq (first spec) 'type) (second spec) (first spec)))
(vars (if (eq (first spec) 'type) (cddr spec) (cdr spec))))
(dolist (var vars)
(push (cons var type) alist)))))))
#+(and allegro (not (version>= 4 1)))
(defparameter *with-slots*
#+PCL 'pcl::with-slots
#+(and allegro (not (version>= 4 1))) 'clos::with-slots
#-(or (and allegro (not (version>= 4 1))) PCL) 'clos:with-slots)
#+(and allegro (not (version>= 4 1)))
(defparameter *slot-value*
#+PCL 'pcl::slot-value
#+(and allegro (not (version>= 4 1))) 'clos::slot-value
#-(or (and allegro (not (version>= 4 1))) PCL) 'clos:slot-value)
#+(and allegro (not (version>= 4 1)))
(defmacro with-slots (slot-entries instance-form &body body &environment environment)
(multiple-value-bind (real-body alist) (slot-value-alist body)
(let ((expansion (macroexpand `(,*with-slots* ,slot-entries ,instance-form
,@real-body)
environment)))
(lisp:labels
((fix-tree (tree &optional first)
(typecase tree
(cons
(when (and first
(eq (car tree) *slot-value*)
(consp (cdr tree))
(consp (cddr tree))
(null (cdddr tree)))
(let ((third (third tree)))
(when (and (consp third)
(eq (car third) 'quote)
(consp (cdr third))
(null (cddr third)))
(let ((slot-name (second third)))
(when (symbolp slot-name)
(let ((type (cdr (assoc slot-name alist))))
(when type
(return-from fix-tree
`(the ,type (,*slot-value* ,(fix-tree (second tree) t)
',slot-name))))))))))
(cons (fix-tree (car tree) t)
(fix-tree (cdr tree) nil)))
(otherwise tree))))
(fix-tree expansion)))))