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
|
;;; -*- Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
;;; All rights reserved.
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted. Any distribution of this
;;; software or derivative works must comply with all applicable United
;;; States export control laws.
;;;
;;; This software is made available AS IS, and Xerox Corporation makes no
;;; warranty about the software, its performance or its conformity to any
;;; specification.
;;;
;;; Any person obtaining a copy of this software is requested to send their
;;; name and post office or electronic mail address to:
;;; CommonLoops Coordinator
;;; Xerox PARC
;;; 3333 Coyote Hill Rd.
;;; Palo Alto, CA 94304
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
;;;
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************
;;;
;;; This is the EXCL (Franz) lisp version of the file portable-low.
;;;
;;; This is for version 1.1.2. Many of the special symbols now in the lisp
;;; package (e.g. lisp::pointer-to-fixnum) will be in some other package in
;;; a later release so this will need to be changed.
;;;
(in-package 'pcl)
(defmacro without-interrupts (&body body)
`(let ((outer-interrupts excl::*without-interrupts*)
(excl::*without-interrupts* 0))
(macrolet ((interrupts-on ()
'(unless outer-interrupts
(setq excl::*without-interrupts* nil)))
(interrupts-off ()
'(setq excl::*without-interrupts* 0)))
,.body)))
(eval-when (compile load eval)
(unless (fboundp 'excl::sy_hash)
(setf (symbol-function 'excl::sy_hash)
(symbol-function 'excl::_sy_hash-value)))
)
(defmacro memq (item list)
(let ((list-var (gensym))
(item-var (gensym)))
`(prog ((,list-var ,list)
(,item-var ,item))
start
(cond ((null ,list-var)
(return nil))
((eq (car ,list-var) ,item-var)
(return ,list-var))
(t
(pop ,list-var)
(go start))))))
(defun std-instance-p (x)
(and (excl::structurep x)
(locally
(declare #.*optimize-speed*)
(eq (svref x 0) 'std-instance))))
(excl::defcmacro std-instance-p (x)
(once-only (x)
`(and (excl::structurep ,x)
(locally
(declare #.*optimize-speed*)
(eq (svref ,x 0) 'std-instance)))))
(excl::defcmacro fast-method-call-p (x)
(once-only (x)
`(and (excl::structurep ,x)
(locally
(declare #.*optimize-speed*)
(eq (svref ,x 0) 'fast-method-call)))))
(defmacro %std-instance-wrapper (x)
`(svref ,x 1))
(defmacro %std-instance-slots (x)
`(svref ,x 2))
(defun printing-random-thing-internal (thing stream)
(format stream "~O" (excl::pointer-to-fixnum thing)))
#-vax
(defun set-function-name-1 (fn new-name ignore)
(declare (ignore ignore))
(cond ((excl::function-object-p fn)
(setf (excl::fn_symdef fn) new-name))
(t nil))
fn)
(defun function-arglist (f)
(excl::arglist f))
(defun symbol-append (sym1 sym2 &optional (package *package*))
;; This is a version of symbol-append from macros.cl
;; It insures that all created symbols are of one case and that
;; case is the current prefered case.
;; This special version of symbol-append is not necessary if all you
;; want to do is compile and run pcl in a case-insensitive-upper
;; version of cl.
;;
(let ((string (string-append sym1 sym2)))
(case excl::*current-case-mode*
((:case-insensitive-lower :case-sensitive-lower)
(setq string (string-downcase string)))
((:case-insensitive-upper :case-sensitive-upper)
(setq string (string-upcase string))))
(intern string package)))
;;; Define inspector hooks for PCL object instances.
(defun (:property pcl::std-instance :inspector-function) (object)
(let ((class (class-of object)))
(cons (inspect::make-field-def "class" #'class-of :lisp)
(mapcar #'(lambda (slot)
(inspect::make-field-def
(string (slot-definition-name slot))
#'(lambda (x)
(slot-value-using-class class x slot))
:lisp))
(slots-to-inspect class object)))))
(defun (:property pcl::std-instance :inspector-type-function) (x)
(class-name (class-of x)))
|
