Skip to content
Snippets Groups Projects
Commit cc2cdf06 authored by wlott's avatar wlott
Browse files

Initial CMU version.

parent bce4c047
No related branches found
No related tags found
No related merge requests found
;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-
;;; ;;;
;;; ************************************************************************* ;;; *************************************************************************
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; Copyright (c) 1985, 1986, 1987, 1988 Xerox Corporation.
;;; All rights reserved. ;;; All rights reserved.
;;; ;;;
;;; Use and copying of this software and preparation of derivative works ;;; Use and copying of this software and preparation of derivative works
...@@ -33,27 +33,49 @@ ...@@ -33,27 +33,49 @@
;;;;;; Cache No's ;;;;;; Cache No's
;; ;;
;;; Abuse the type declaration, but it generates great code. (proclaim '(inline object-cache-no))
;(defun symbol-cache-no (symbol mask)
; (logand (the fixnum (system:%primitive lisp::make-immediate-type
; symbol
; system::%+-fixnum-type))
; (the fixnum mask)))
;
;(clc::deftransform symbol-cache-no symbol-cache-no-transform (symbol mask)
; `(logand (the fixnum (system:%primitive lisp::make-immediate-type
; ,symbol
; system::%+-fixnum-type))
; (the fixnum ,mask)))
(defun object-cache-no (symbol mask) (defun object-cache-no (symbol mask)
(logand (the fixnum (system:%primitive lisp::make-immediate-type (logand (ext:truly-the fixnum (system:%primitive make-fixnum symbol))
symbol
system::%+-fixnum-type))
(the fixnum mask))) (the fixnum mask)))
(clc::deftransform object-cache-no object-cache-no-transform (symbol mask)
`(logand (the fixnum (system:%primitive lisp::make-immediate-type
,symbol (defun function-arglist (fcn)
system::%+-fixnum-type)) "Returns the argument list of a compiled function, if possible."
(cond ((symbolp fcn)
(when (fboundp fcn)
(function-arglist (symbol-function fcn))))
((eval:interpreted-function-p fcn)
(eval:interpreted-function-name fcn))
((functionp fcn)
(let ((lambda-expr (function-lambda-expression fcn)))
(if lambda-expr
(cadr lambda-expr)
(let ((function (kernel:%closure-function fcn)))
(values (read-from-string
(kernel:%function-header-arglist function)))))))))
;;; We have this here and in fin.lisp, 'cause PCL wants to compile this
;;; file first.
;;;
(defsetf funcallable-instance-name set-funcallable-instance-name)
(defun set-function-name (fcn new-name)
"Set the name of a compiled function object."
(cond ((symbolp fcn)
(set-function-name (symbol-function fcn) new-name))
((funcallable-instance-p fcn)
(setf (funcallable-instance-name fcn) new-name)
fcn)
(t
(let ((header (kernel:%closure-function fcn)))
(system:%primitive c::set-function-name header
(if (symbolp new-name)
new-name
(let ((*package* *the-pcl-package*)
(*print-case* :upcase)
(*print-gensym* 't))
(prin1-to-string new-name)))))
fcn)))
...@@ -269,7 +269,7 @@ and load your system with: ...@@ -269,7 +269,7 @@ and load your system with:
#+(and Lucid MIPS) ("lisp" . "mbin") #+(and Lucid MIPS) ("lisp" . "mbin")
#+(and Lucid PRISM) ("lisp" . "abin") #+(and Lucid PRISM) ("lisp" . "abin")
#+excl ("cl" . "fasl") #+excl ("cl" . "fasl")
#+:CMU ("slisp" . "sfasl") #+:CMU ("lisp" . #+pmax "mips-fasl" #-(or pmax) "fasl")
#+HP ("l" . "b") #+HP ("l" . "b")
#+TI ("lisp" . #.(string (si::local-binary-file-type))) #+TI ("lisp" . #.(string (si::local-binary-file-type)))
#+:gclisp ("LSP" . "F2S") #+:gclisp ("LSP" . "F2S")
...@@ -395,7 +395,8 @@ and load your system with: ...@@ -395,7 +395,8 @@ and load your system with:
(let ((*system-directory* (funcall (car system))) (let ((*system-directory* (funcall (car system)))
(modules (cadr system)) (modules (cadr system))
(transformations ())) (transformations ()))
(labels ((load-source (name pathname) (labels (#+nil ;; This isn't used?
(load-source (name pathname)
(format t "~&Loading source of ~A..." name) (format t "~&Loading source of ~A..." name)
(or print-only (load pathname))) (or print-only (load pathname)))
(load-binary (name pathname) (load-binary (name pathname)
...@@ -557,11 +558,7 @@ and load your system with: ...@@ -557,11 +558,7 @@ and load your system with:
;; ;;
#+LUCID (or lucid::*source-pathname* (bad-time)))) #+LUCID (or lucid::*source-pathname* (bad-time))))
(defvar *pcl-directory* (defvar *pcl-directory* (pathname "pcl:"))
(or (load-truename t)
(error "Because load-truename is not implemented in this port~%~
of PCL, you must manually edit the definition of the~%~
variable *pcl-directory* in the file defsys.lisp.")))
(defsystem pcl (defsystem pcl
......
...@@ -106,12 +106,16 @@ explicitly marked saying who wrote it. ...@@ -106,12 +106,16 @@ explicitly marked saying who wrote it.
;;; This must be SETF'able. ;;; This must be SETF'able.
;;; ;;;
(eval-when (compile eval load)
(defconstant funcallable-instance-data (defconstant funcallable-instance-data
'(wrapper slots) '(wrapper slots)
"These are the 'data-slots' which funcallable instances have so that "These are the 'data-slots' which funcallable instances have so that
the meta-class funcallable-standard-class can store class, and static the meta-class funcallable-standard-class can store class, and static
slots in them.") slots in them.")
); eval-when (compile eval load)
(defmacro funcallable-instance-data-position (data) (defmacro funcallable-instance-data-position (data)
(if (and (consp data) (if (and (consp data)
(eq (car data) 'quote) (eq (car data) 'quote)
...@@ -965,44 +969,61 @@ explicitly marked saying who wrote it. ...@@ -965,44 +969,61 @@ explicitly marked saying who wrote it.
;;; Implementation of funcallable instances for CMU Common Lisp. ;;; Implementation of funcallable instances for CMU Common Lisp.
;;; ;;;
;;; Similiar to the code for VAXLISP implementation.
#+:CMU #+:CMU
(progn (progn
(defstruct funcallable-instance-info
(function #'(lambda (&rest args) (declare (ignore args))
(called-fin-without-function))
:type function)
(name "Unnamed funcallable instance")
. #.funcallable-instance-data)
(proclaim '(inline funcallable-instance-info funcallable-instance-p))
(defun funcallable-instance-info (fin)
(system:find-if-in-closure #'funcallable-instance-info-p fin))
(defun allocate-funcallable-instance-1 () (defun allocate-funcallable-instance-1 ()
`(lisp::%compiled-closure% (let ((info (make-funcallable-instance-info)))
() #'(lambda (&rest args)
,#'(lambda (&rest args) (apply (funcallable-instance-info-function info) args))))
(declare (ignore args))
(called-fin-without-function))
,(make-array (length funcallable-instance-data))))
(proclaim '(inline funcallable-instance-p))
(defun funcallable-instance-p (x)
(and (consp x)
(eq (car x) 'lisp::%compiled-closure%)
(not (null (cdddr x)))))
(defun set-funcallable-instance-function (fin func) (defun funcallable-instance-p (thing)
(cond ((not (funcallable-instance-p fin)) (and (functionp thing)
(error "~S is not a funcallable-instance" fin)) (= (kernel:get-type thing) vm:closure-header-type)
((not (functionp func)) (funcallable-instance-info thing)
(error "~S is not a function" func)) t))
((and (consp func) (eq (car func) 'lisp::%compiled-closure%))
(setf (cadr fin) (cadr func)
(caddr fin) (caddr func)))
(t (set-funcallable-instance-function fin
(make-trampoline func)))))
(defun make-trampoline (function)
#'(lambda (&rest args)
(apply function args)))
(eval-when (eval) (compile 'make-trampoline)) (defun set-funcallable-instance-function (fin new-value)
(setf (funcallable-instance-info-function (funcallable-instance-info fin))
new-value))
(defun funcallable-instance-name (fin)
(funcallable-instance-info-name (funcallable-instance-info fin)))
(defun set-funcallable-instance-name (fin new-value)
(setf (funcallable-instance-info-name (funcallable-instance-info fin))
new-value))
(defsetf funcallable-instance-name set-funcallable-instance-name)
(defmacro funcallable-instance-data-1 (fin slot)
(unless (and (listp slot) (eq (car slot) 'quote))
(error "Non-constant name for funcallable-instance-data-1: ~S" slot))
`(,(intern (concatenate 'simple-string
"FUNCALLABLE-INSTANCE-INFO-"
(string (cadr slot)))
*the-pcl-package*)
(funcallable-instance-info ,fin)))
(defmacro funcallable-instance-data-1 (instance data)
`(svref (cadddr ,instance)
(funcallable-instance-data-position ,data)))
); End of :CMU ); End of :CMU
......
...@@ -40,6 +40,10 @@ ...@@ -40,6 +40,10 @@
defmethod) defmethod)
*the-pcl-package*) *the-pcl-package*)
#+CMU
(shadow '(destructuring-bind)
*the-pcl-package*)
#+GCLisp #+GCLisp
(shadow '(string-append memq assq delq neq make-instance) (shadow '(string-append memq assq delq neq make-instance)
*the-pcl-package*) *the-pcl-package*)
...@@ -117,7 +121,7 @@ ...@@ -117,7 +121,7 @@
);eval-when );eval-when
#-(or KCL IBCL) #-(or KCL IBCL)
(export *exports* *the-pcl-package*) (export '#.*exports* *the-pcl-package*)
#+(or KCL IBCL) #+(or KCL IBCL)
(mapc 'export (list *exports*) (list *the-pcl-package*)) (mapc 'export (list *exports*) (list *the-pcl-package*))
......
...@@ -805,6 +805,57 @@ ...@@ -805,6 +805,57 @@
);#+gclisp );#+gclisp
;;;; CMU Common Lisp version of environment frobbing stuff.
;;; In CMU Common Lisp, the environment (well, the function/macro part of
;;; the environment) is represented as a list of entries, with each entry
;;; being of the form (name type . fn) where type is either macro or
;;; function.
#+:CMU
(progn
(defmacro with-augmented-environment
((new-env old-env &key functions macros) &body body)
`(let ((,new-env (with-augmented-environment-internal ,old-env
,functions
,macros)))
,@body))
(defun with-augmented-environment-internal (env functions macros)
;; Note: In order to record the correct function definition, we would
;; have to create an interpreted closure, but the with-new-definition
;; macro down below makes no distinction between flet and labels, so
;; we have no idea what to use for the environment. So we just blow it
;; off, 'cause anything real we do would be wrong. We still have to
;; make an entry so we can tell functions from macros.
(let ((c::*lexical-environment* (or env (c::make-null-environment))))
(c::make-lexenv
:functions
(append (mapcar #'(lambda (f)
(list (car f) 'function))
functions)
(mapcar #'(lambda (m)
(list* (car m) 'lisp::macro (cadr m)))
macros)))))
(defun environment-function (env fn)
(when env
(let ((entry (assoc fn (c::lexenv-functions env) :test #'eq)))
(and entry
(eq (cadr entry) 'function)
(cddr entry)))))
(defun environment-macro (env macro)
(when env
(let ((entry (assoc macro (c::lexenv-functions env) :test #'eq)))
(and entry
(eq (cadr entry) 'lisp::macro)
(cddr entry)))))
); end of #+:CMU
(defmacro with-new-definition-in-environment (defmacro with-new-definition-in-environment
...@@ -946,9 +997,7 @@ ...@@ -946,9 +997,7 @@
#+(and dec vax common) (get symbol 'system::globally-special) #+(and dec vax common) (get symbol 'system::globally-special)
#+(or KCL IBCL) (si:specialp symbol) #+(or KCL IBCL) (si:specialp symbol)
#+excl (get symbol 'excl::.globally-special.) #+excl (get symbol 'excl::.globally-special.)
#+:CMU (or (get symbol 'lisp::globally-special) #+:CMU (eq (ext:info variable kind symbol) :special)
(get symbol
'clc::globally-special-in-compiler))
#+HP-HPLabs (member (get symbol 'impl:vartype) #+HP-HPLabs (member (get symbol 'impl:vartype)
'(impl:fluid impl:global) '(impl:fluid impl:global)
:test #'eq) :test #'eq)
...@@ -1260,7 +1309,11 @@ ...@@ -1260,7 +1309,11 @@
(SET (SET
(walk-form-internal form :SET env)) (walk-form-internal form :SET env))
((LAMBDA CALL) ((LAMBDA CALL)
(cond ((symbolp form) form) (cond ((or (symbolp form)
(and (listp form)
(= (length form) 2)
(eq (car form) 'setf)))
form)
#+Lispm #+Lispm
((sys:validate-function-spec form) form) ((sys:validate-function-spec form) form)
(t (walk-form-internal form context env))))) (t (walk-form-internal form context env)))))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment