From b2d32f3de0383fbf3739c1c34930807798d33717 Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Mon, 9 Nov 1992 15:21:43 +0000 Subject: [PATCH] Initial revision --- pcl/bench.lisp | 448 ++++++++ pcl/dlisp.lisp | 410 +++++++ pcl/dlisp2.lisp | 175 +++ pcl/fast-init.lisp | 895 +++++++++++++++ pcl/inline.lisp | 263 +++++ pcl/misc-kcl-patches.text | 340 ++++++ pcl/new-kcl-wrapper.text | 2157 +++++++++++++++++++++++++++++++++++++ pcl/slots-boot.lisp | 396 +++++++ 8 files changed, 5084 insertions(+) create mode 100644 pcl/bench.lisp create mode 100644 pcl/dlisp.lisp create mode 100644 pcl/dlisp2.lisp create mode 100644 pcl/fast-init.lisp create mode 100644 pcl/inline.lisp create mode 100644 pcl/misc-kcl-patches.text create mode 100644 pcl/new-kcl-wrapper.text create mode 100644 pcl/slots-boot.lisp diff --git a/pcl/bench.lisp b/pcl/bench.lisp new file mode 100644 index 000000000..3b0273f20 --- /dev/null +++ b/pcl/bench.lisp @@ -0,0 +1,448 @@ +;;;-*- Mode: Lisp; Syntax: Common-lisp; Package: user -*- + +(in-package :bench :use '(:lisp :pcl)) + +;;;Here are a few homebrew benchmarks for testing out Lisp performance. +;;; BENCH-THIS-LISP: benchmarks for common lisp. +;;; BENCH-THIS-CLOS: benchmarks for CLOS. +;;; BENCH-FLAVORS: ditto for Symbolics flavors. +;;; BE SURE TO CHANGE THE PACKAGE DEFINITION TO GET THE CLOS + LISP YOU WANT TO TEST. +;;; +;;;Each benchmark is reported as operations per second. Without-interrupts is used, +;;; so the scheduler isn't supposed to get in the way. Accuracy is generally +;;; between one and five percent. +;;; +;;;Elapsed time is measured using get-internal-run-time. Because the accuracy of +;;; this number is fairly crude, it is important to use a large number of +;;; iterations to get an accurate benchmark. The function median-time may +;;; complain to you if you didn't pick enough iterations. +;;; +;;;July 1992. Watch out! In some cases the instruction being timed will be +;;; optimized away by a clever compiler. Beware of benchmarks that are +;;; nearly as fast as *speed-of-empty-loop*. +;;; +;;;Thanks to Ken Anderson for much of this code. +;;; +;;; jeff morrill +;;; jmorrill@bbn.com + +#+Genera +(eval-when (compile load eval) + (import '(clos-internals::allocate-instance))) + +(proclaim '(optimize (speed 3) (safety 1) (space 0) #+lucid (compilation-speed 0))) + +;;;********************************************************************* + +(defvar *min-time* (/ 500 (float internal-time-units-per-second)) + "At least 2 orders of magnitude larger than our time resolution.") + +(defmacro elapsed-time (form) + "Returns (1) the result of form and (2) the time (seconds) it takes to evaluate form." + ;; Note that this function is completely portable. + (let ((start-time (gensym)) (end-time (gensym))) + `(let ((,start-time (get-internal-run-time))) + (values ,form + (let ((,end-time (get-internal-run-time))) + (/ (abs (- ,end-time ,start-time)) + ,(float internal-time-units-per-second))))))) + +(defmacro without-interruption (&body forms) + #+genera `(scl:without-interrupts ,@forms) + #+lucid `(lcl::with-scheduling-inhibited ,@forms) + #+allegro `(excl:without-interrupts ,@forms) + #+(and (not genera) (not lucid) (not allegro)) `(progn ,@forms)) + +(defmacro median-time (form &optional (I 5)) + "Return the median time it takes to evaluate form." + ;; I: number of samples to take. + `(without-interruption + (let ((results nil)) + (dotimes (ignore ,I) + (multiple-value-bind (ignore time) (elapsed-time ,form) + (declare (ignore ignore)) + (if (< time *min-time*) + (format t "~% Warning. Evaluating ~S took only ~S seconds.~ + ~% You should probably use more iterations." ',form time)) + (push time results))) + (nth ,(truncate I 2) (sort results #'<))))) + +#+debug +(defun test () (median-time (sleep 1.0))) + +;;;********************************************************************* + +;;;OPERATIONS-PER-SECOND actually does the work of computing a benchmark. The amount +;;; of time it takes to execute the form N times is recorded, minus the time it +;;; takes to execute the empty loop. OP/S = N/time. This quantity is recomputed +;;; five times and the median value is returned. Variance in the numbers increases +;;; when memory is being allocated (cons, make-instance, etc). + +(defmacro repeat (form N) + ;; Minimal loop + (let ((count (gensym)) (result (gensym))) + `(let ((,count ,N) ,result) + (loop + ;; If you don't use the setq, the compiler may decide that since the + ;; result is ignored, FORM can be "compiled out" of the loop. + (setq ,result ,form) + (if (zerop (decf ,count)) (return ,result)))))) + +(defun nempty (N) + "The empty loop." + (repeat nil N)) + +(defun empty-speed (N) (median-time (nempty N))) + +(defun compute-empty-iterations (&optional (default 1000000)) + (format t "~%Computing speed of empty loop...") + (let ((time nil)) + (loop + (setq time (empty-speed default)) + (if (< time *min-time*) (setq default (* default 10)) (return))) + (format t "done.") + default)) + +(defvar *empty-iterations*) +(defvar *speed-of-empty-loop*) + +(eval-when (load eval) + (setq *empty-iterations* (compute-empty-iterations)) + (setq *speed-of-empty-loop* (/ (empty-speed *empty-iterations*) + (float *empty-iterations*)))) + +(defmacro operations-per-second (form N &optional (I 5)) + "Return the number of times FORM can evaluate in one second." + `(let ((time (median-time (repeat ,form ,N) ,I))) + (/ (float ,N) (- time (* *speed-of-empty-loop* N))))) + +(defmacro bench (pretty-name name N &optional (stream t)) + `(format ,stream "~%~A: ~30T~S" ,pretty-name (,name ,N))) + +;;;**************************************************************************** + +;;;BENCH-THIS-LISP + +(defun Nmult (N) + (let ((a 2.1)) + (operations-per-second (* a a) N))) + +(defun Nadd (N) + (let ((a 2.1)) + (operations-per-second (+ a a) N))) + +(defun square (x) (* x x)) + +(defun funcall-1 (N) + ;; inlined + (let ((x 2.1)) + (operations-per-second (funcall #'(lambda (a) (* a a)) x) N))) + +(defun f1 (n) n) + +(defun funcall-2 (N) + (let ((f #'f1) + (x 2.1)) + (operations-per-second (funcall f x) N))) + +(defun funcall-3 (N) + (let ((x 2.1)) + (operations-per-second (f1 x) N))) + +(defun funcall-4 (N) + (let ((x 2.1)) + (operations-per-second (funcall #'square x) N))) + +(defun funcall-5 (N) + (let ((x 2.1) + (f #'square)) + (let ((g #'(lambda (x) + (operations-per-second (funcall f x) N)))) + (funcall g x)))) + +(defun Nsetf (N) + (let ((array (make-array 15))) + (operations-per-second (setf (aref array 5) t) N))) + +(defun Nsymeval (N) (operations-per-second (eval T) N)) + +(defun Repeatuations (N) (operations-per-second (eval '(* 2.1 2.1)) N)) + +(defun n-cons (N) (let ((a 1)) (operations-per-second (cons a a) N))) + +(defvar *object* t) +(Defun nspecial (N) (operations-per-second (null *object*) N)) + +(defun nlexical (N) + (let ((o t)) + (operations-per-second (null o) N))) + +(defun nfree (N) + (let ((o t)) + (let ((g #'(lambda () + #+genera (declare (sys:downward-function)) + (operations-per-second (null o) N)))) + (funcall g)))) + +(defun nfree2 (N) + (let ((o t)) + (let ((g #'(lambda () + (let ((f #'(lambda () + #+genera (declare (sys:downward-function)) + (operations-per-second (null o) N)))) + (funcall f))))) + (funcall g)))) + +(defun ncompilations (N) + (let ((lambda-expression + '(lambda (bar) (let ((baz t)) (if baz (cons bar nil)))))) + (operations-per-second (compile 'bob lambda-expression) N))) + +(defun bench-this-lisp () + (let ((N (/ *empty-iterations* 10))) + (bench "(* 2.1 2.1)" nmult N) + (bench "(+ 2.1 2.1)" nadd N) + (bench "funcall & (* 2.1 2.1)" funcall-3 N) + (bench "special reference" nspecial *empty-iterations*) + (bench "lexical reference" nlexical *empty-iterations*) + ;; (bench "ivar reference" n-ivar-ref N) + (bench "(setf (aref array 5) t)" nsetf N) + (bench "(funcall lexical-f x)" funcall-2 N) + (bench "(f x)" funcall-3 N) + ;; (Bench "(eval t)" nsymeval 10000) + ;; (bench "(eval '(* 2.1 2.1))" repeatuations 10000) + ;; (bench "(cons 1 2)" n-cons 100000) + ;; (bench "compile simple function" ncompilations 50) + )) + +;(bench-this-lisp) + +;;;************************************************************** + +#+genera +(progn + +(scl:defflavor bar (a b) () + :initable-instance-variables + :writable-instance-variables) + +(scl:defflavor frob (c) (bar) + :initable-instance-variables + :writable-instance-variables) + +(scl:defmethod (hop bar) () + a) + +(scl:defmethod (set-hop bar) (n) + (setq a n)) + +(scl:defmethod (nohop bar) () + 5) + +(defun n-ivar-ref (N) + (let ((i (scl:make-instance 'bar :a 0 :b 0))) + (ivar-ref i N))) + +(scl:defmethod (ivar-ref bar) (N) + (operations-per-second b N)) + + +(defun Ninstances (N) (operations-per-second (flavor:make-instance 'bar) N)) + +(defun n-svref (N) + (let ((instance (flavor:make-instance 'bar :a 1))) + (operations-per-second (scl:symbol-value-in-instance instance 'a) N))) +(defun n-hop (N) + (let ((instance (flavor:make-instance 'bar :a 1))) + (operations-per-second (hop instance) n))) +(defun n-gf (N) + (let ((instance (flavor:make-instance 'bar :a 1))) + (operations-per-second (nohop instance) n))) +(defun n-set-hop (N) + (let ((instance (flavor:make-instance 'bar :a 1))) + (operations-per-second (set-hop instance) n))) +(defun n-type-of (N) + (let ((instance (flavor:make-instance 'bar))) + (operations-per-second (flavor::%instance-flavor instance) N))) + +(defun n-bar-b (N) + (let ((instance (flavor:make-instance 'bar :a 0 :b 0))) + (operations-per-second (bar-b instance) N))) + +(defun n-frob-bar-b (N) + (let ((instance (flavor:make-instance 'frob :a 0 :b 0))) + (operations-per-second (bar-b instance) N))) + +(defun bench-flavors () + (bench "flavor:make-instance (2 slots)" ninstances 5000) + (bench "flavor:symbol-value-in-instance" n-svref 100000) + (bench "1 method, 1 dispatch" n-gf 100000) + (bench "slot symbol in method (access)" n-hop 100000) + (bench "slot symbol in method (modify)" n-hop 100000) + (bench "slot accessor bar" n-bar-b 100000) + (bench "slot accessor frob" n-frob-bar-b 100000) + (bench "instance-flavor" n-type-of 500000)) + +) ; end of #+genera + +;;;************************************************************** + +;;;BENCH-THIS-CLOS +;;; (evolved from Ken Anderson's tests of Symbolics CLOS) + +(defmethod strange ((x t)) t) ; default method +(defmethod area ((x number)) 'green) ; builtin class + +(defclass point + () + ((x :initform 0 :accessor x :initarg :x) + (y :initform 0 :accessor y :initarg :y))) + +(defmethod color ((thing point)) 'red) +(defmethod address ((thing point)) 'boston) +(defmethod area ((thing point)) 0) +(defmethod move-to ((p1 point) (p2 point)) 0) + +(defmethod x-offset ((thing point)) + (with-slots (x y) thing x)) + +(defmethod set-x-offset ((thing point) new-x) + (with-slots (x y) thing (setq x new-x))) + +(defclass box + (point) + ((width :initform 10 :accessor width :initarg :width) + (height :initform 10 :accessor height :initarg :height))) + +(defmethod area ((thing box)) 0) +(defmethod move-to ((box box) (point point)) 0) +(defmethod address :around ((thing box)) (call-next-method)) + +(defvar p (make-instance 'point)) +(defvar b (make-instance 'box)) + +(defun n-strange (N) (operations-per-second (strange 5) N)) +(defun n-accesses (N) + (let ((instance p)) + (operations-per-second (x instance) N))) +(defun n-color (N) + (let ((instance p)) + (operations-per-second (color instance) n))) +(defun n-call-next-method (N) + (let ((instance b)) + (operations-per-second (address instance) n))) +(defun n-area-1 (N) + (let ((instance p)) + (operations-per-second (area instance) n))) +(defun n-area-2 (N) + (operations-per-second (area 5) n)) +(defun n-move-1 (N) + (let ((instance p)) + (operations-per-second (move-to instance instance) n))) +(defun n-move-2 (N) + (let ((x p) (y b)) + (operations-per-second (move-to x y) n))) +(defun n-off (N) + (let ((instance p)) + (operations-per-second (x-offset instance) n))) +(defun n-setoff (N) + (let ((instance p)) + (operations-per-second (set-x-offset instance 500) n))) +(defun n-slot-value (N) + (let ((instance p)) + (operations-per-second (slot-value instance 'x) n))) + +(defun n-class-of-1 (N) + (let ((instance p)) + (operations-per-second (class-of instance) n))) +(defun n-class-of-2 (N) + (operations-per-second (class-of 5) n)) + +(defun n-alloc (N) + (let ((c (find-class 'point))) + (operations-per-second (allocate-instance c) n))) + +(defun n-make (N) + (operations-per-second (make-instance 'point) n)) + +(defun n-make-initargs (N) + ;; Much slower than n-make! + (operations-per-second (make-instance 'point :x 0 :y 5) n)) + +(defun n-make-variable-initargs (N) + ;; Much slower than n-make! + (let ((x 0) + (y 5)) + (operations-per-second (make-instance 'point :x x :y y) n))) + +(pcl::expanding-make-instance-top-level + +(defun n-make1 (N) + (operations-per-second (make-instance 'point) n)) + +(defun n-make-initargs1 (N) + ;; Much slower than n-make! + (operations-per-second (make-instance 'point :x 0 :y 5) n)) + +(defun n-make-variable-initargs1 (N) + ;; Much slower than n-make! + (let ((x 0) + (y 5)) + (operations-per-second (make-instance 'point :x x :y y) n))) + +) + +(pcl::precompile-random-code-segments) + +(defun bench-this-clos () + (let ((N (/ *empty-iterations* 10))) + (bench "1 default method" n-strange N) + (bench "1 dispatch, 1 method" n-color N) + (bench "1 dispatch, :around + primary" n-call-next-method N) + (bench "1 dispatch, 3 methods, instance" n-area-1 N) + (bench "1 dispatch, 3 methods, noninstance" n-area-2 N) + (bench "2 dispatch, 2 methods" n-move-1 N) + (bench "slot reader method" n-accesses N) + (bench "with-slots (1 access)" n-off N) + (bench "with-slots (1 modify)" n-setoff N) + (bench "naked slot-value" n-slot-value N) + (bench "class-of instance" n-class-of-1 N) + (bench "class-of noninstance" n-class-of-2 N) + (bench "allocate-instance (2 slots)" n-alloc + #+pcl 5000 + #+allegro 100000 + #+(and Genera (not pcl)) 100000 + #+(and Lucid (not pcl)) 10000) + (bench "make-instance (2 slots)" n-make + #+pcl 5000 + #+allegro 100000 + #+(and Genera (not pcl)) 100000 + #+(and Lucid (not pcl)) 10000) + (bench "make-instance (2 constant initargs)" n-make-initargs + #+pcl 1000 + #+allegro 100000 + #+(and Genera (not pcl)) 100000 + #+(and Lucid (not pcl)) 10000) + (bench "make-instance (2 variable initargs)" n-make-variable-initargs + #+pcl 1000 + #+allegro 100000 + #+(and Genera (not pcl)) 100000 + #+(and Lucid (not pcl)) 10000) + + (bench "make-instance (2 slots)" n-make1 + #+pcl 5000 + #+allegro 100000 + #+(and Genera (not pcl)) 100000 + #+(and Lucid (not pcl)) 10000) + (bench "make-instance (2 constant initargs)" n-make-initargs1 + #+pcl 1000 + #+allegro 100000 + #+(and Genera (not pcl)) 100000 + #+(and Lucid (not pcl)) 10000) + (bench "make-instance (2 variable initargs)" n-make-variable-initargs1 + #+pcl 1000 + #+allegro 100000 + #+(and Genera (not pcl)) 100000 + #+(and Lucid (not pcl)) 10000)) ) + +;(bench-this-clos) diff --git a/pcl/dlisp.lisp b/pcl/dlisp.lisp new file mode 100644 index 000000000..da9c8a261 --- /dev/null +++ b/pcl/dlisp.lisp @@ -0,0 +1,410 @@ +;;;-*-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. +;;; ************************************************************************* +;;; + +(in-package 'pcl) + +;;; This file is (almost) functionally equivalent to dlap.lisp, +;;; but easier to read. + +;;; Might generate faster code, too, depending on the compiler and +;;; whether an implementation-specific lap assembler was used. + +(defun emit-one-class-reader (class-slot-p) + (emit-reader/writer :reader 1 class-slot-p)) + +(defun emit-one-class-writer (class-slot-p) + (emit-reader/writer :writer 1 class-slot-p)) + +(defun emit-two-class-reader (class-slot-p) + (emit-reader/writer :reader 2 class-slot-p)) + +(defun emit-two-class-writer (class-slot-p) + (emit-reader/writer :writer 2 class-slot-p)) + +;;; -------------------------------- + +(defun emit-one-index-readers (class-slot-p) + (emit-one-or-n-index-reader/writer :reader nil class-slot-p)) + +(defun emit-one-index-writers (class-slot-p) + (emit-one-or-n-index-reader/writer :writer nil class-slot-p)) + +(defun emit-n-n-readers () + (emit-one-or-n-index-reader/writer :reader t nil)) + +(defun emit-n-n-writers () + (emit-one-or-n-index-reader/writer :writer t nil)) + +;;; -------------------------------- + +(defun emit-checking (metatypes applyp) + (emit-checking-or-caching nil nil metatypes applyp)) + +(defun emit-caching (metatypes applyp) + (emit-checking-or-caching t nil metatypes applyp)) + +(defun emit-in-checking-cache-p (metatypes) + (emit-checking-or-caching nil t metatypes nil)) + +(defun emit-constant-value (metatypes) + (emit-checking-or-caching t t metatypes nil)) + +;;; -------------------------------- + +(defvar *precompiling-lap* nil) +(defvar *emit-function-p* t) + +(defun emit-default-only (metatypes applyp) + (when (and (null *precompiling-lap*) *emit-function-p*) + (return-from emit-default-only + (emit-default-only-function metatypes applyp))) + (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)) + (args (remove '&rest dlap-lambda-list)) + (restl (when applyp '(.lap-rest-arg.)))) + (generating-lisp '(emf) + dlap-lambda-list + `(invoke-effective-method-function emf ,applyp ,@args ,@restl)))) + +(defmacro emit-default-only-macro (metatypes applyp) + (let ((*emit-function-p* nil) + (*precompiling-lap* t)) + (values + (emit-default-only metatypes applyp)))) + +;;; -------------------------------- + +(defun generating-lisp (closure-variables args form) + (let* ((rest (memq '&rest args)) + (ldiff (and rest (ldiff args rest))) + (args (if rest (append ldiff '(&rest .lap-rest-arg.)) args)) + (lambda `(lambda ,closure-variables + ,@(when (member 'miss-fn closure-variables) + `((declare (type function miss-fn)))) + #'(lambda ,args + (let () + (declare #.*optimize-speed*) + ,form))))) + (values (if *precompiling-lap* + `#',lambda + (compile-lambda lambda)) + nil))) + +(defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p) + (when (and (null *precompiling-lap*) *emit-function-p*) + (return-from emit-reader/writer + (emit-reader/writer-function reader/writer 1-or-2-class class-slot-p))) + (let ((instance nil) + (arglist ()) + (closure-variables ()) + (field (first-wrapper-cache-number-index)) + (readp (eq reader/writer :reader)) + (read-form (emit-slot-read-form class-slot-p 'index 'slots))) + ;;we need some field to do the fast obsolete check + (ecase reader/writer + (:reader (setq instance (dfun-arg-symbol 0) + arglist (list instance))) + (:writer (setq instance (dfun-arg-symbol 1) + arglist (list (dfun-arg-symbol 0) instance)))) + (ecase 1-or-2-class + (1 (setq closure-variables '(wrapper-0 index miss-fn))) + (2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn)))) + (generating-lisp closure-variables + arglist + `(let* (,@(unless class-slot-p `((slots nil))) + (wrapper (cond ((std-instance-p ,instance) + ,@(unless class-slot-p + `((setq slots (std-instance-slots ,instance)))) + (std-instance-wrapper ,instance)) + ((fsc-instance-p ,instance) + ,@(unless class-slot-p + `((setq slots (fsc-instance-slots ,instance)))) + (fsc-instance-wrapper ,instance)))) + ,@(when readp '(value))) + (if (or (null wrapper) + (zerop (wrapper-cache-number-vector-ref wrapper ,field)) + (not (or (eq wrapper wrapper-0) + ,@(when (eql 2 1-or-2-class) + `((eq wrapper wrapper-1))))) + ,@(when readp `((eq *slot-unbound* (setq value ,read-form))))) + (funcall miss-fn ,@arglist) + ,(if readp + 'value + `(setf ,read-form ,(car arglist)))))))) + +(defun emit-slot-read-form (class-slot-p index slots) + (if class-slot-p + `(cdr ,index) + `(%instance-ref ,slots ,index))) + +(defun emit-boundp-check (value-form miss-fn arglist) + `(let ((value ,value-form)) + (if (eq value *slot-unbound*) + (funcall ,miss-fn ,@arglist) + value))) + +(defun emit-slot-access (reader/writer class-slot-p slots index miss-fn arglist) + (let ((read-form (emit-slot-read-form class-slot-p index slots))) + (ecase reader/writer + (:reader (emit-boundp-check read-form miss-fn arglist)) + (:writer `(setf ,read-form ,(car arglist)))))) + +(defmacro emit-reader/writer-macro (reader/writer 1-or-2-class class-slot-p) + (let ((*emit-function-p* nil) + (*precompiling-lap* t)) + (values + (emit-reader/writer reader/writer 1-or-2-class class-slot-p)))) + +(defun emit-one-or-n-index-reader/writer (reader/writer cached-index-p class-slot-p) + (when (and (null *precompiling-lap*) *emit-function-p*) + (return-from emit-one-or-n-index-reader/writer + (emit-one-or-n-index-reader/writer-function + reader/writer cached-index-p class-slot-p))) + (multiple-value-bind (arglist metatypes) + (ecase reader/writer + (:reader (values (list (dfun-arg-symbol 0)) + '(standard-instance))) + (:writer (values (list (dfun-arg-symbol 0) (dfun-arg-symbol 1)) + '(t standard-instance)))) + (generating-lisp `(cache ,@(unless cached-index-p '(index)) miss-fn) + arglist + `(let (,@(unless class-slot-p '(slots)) + ,@(when cached-index-p '(index))) + ,(emit-dlap arglist metatypes + (emit-slot-access reader/writer class-slot-p + 'slots 'index 'miss-fn arglist) + `(funcall miss-fn ,@arglist) + (when cached-index-p 'index) + (unless class-slot-p '(slots))))))) + +(defmacro emit-one-or-n-index-reader/writer-macro + (reader/writer cached-index-p class-slot-p) + (let ((*emit-function-p* nil) + (*precompiling-lap* t)) + (values + (emit-one-or-n-index-reader/writer reader/writer cached-index-p class-slot-p)))) + +(defun emit-miss (miss-fn args &optional applyp) + (let ((restl (when applyp '(.lap-rest-arg.)))) + (if restl + `(apply ,miss-fn ,@args ,@restl) + `(funcall ,miss-fn ,@args ,@restl)))) + +(defun emit-checking-or-caching (cached-emf-p return-value-p metatypes applyp) + (when (and (null *precompiling-lap*) *emit-function-p*) + (return-from emit-checking-or-caching + (emit-checking-or-caching-function + cached-emf-p return-value-p metatypes applyp))) + (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)) + (args (remove '&rest dlap-lambda-list)) + (restl (when applyp '(.lap-rest-arg.)))) + (generating-lisp `(cache ,@(unless cached-emf-p '(emf)) miss-fn) + dlap-lambda-list + `(let (,@(when cached-emf-p '(emf))) + ,(emit-dlap args + metatypes + (if return-value-p + (if cached-emf-p 'emf t) + `(invoke-effective-method-function emf ,applyp + ,@args ,@restl)) + (emit-miss 'miss-fn args applyp) + (when cached-emf-p 'emf)))))) + +(defmacro emit-checking-or-caching-macro (cached-emf-p return-value-p metatypes applyp) + (let ((*emit-function-p* nil) + (*precompiling-lap* t)) + (values + (emit-checking-or-caching cached-emf-p return-value-p metatypes applyp)))) + +(defun emit-dlap (args metatypes hit miss value-reg &optional slot-regs) + (let* ((index -1) + (wrapper-bindings (mapcan #'(lambda (arg mt) + (unless (eq mt 't) + (incf index) + `((,(intern (format nil "WRAPPER-~D" index) + *the-pcl-package*) + ,(emit-fetch-wrapper mt arg 'miss + (pop slot-regs)))))) + args metatypes)) + (wrappers (mapcar #'car wrapper-bindings))) + (declare (fixnum index)) + (unless wrappers (error "Every metatype is T.")) + `(block dfun + (tagbody + (let ((field (cache-field cache)) + (cache-vector (cache-vector cache)) + (mask (cache-mask cache)) + (size (cache-size cache)) + (overflow (cache-overflow cache)) + ,@wrapper-bindings) + (declare (fixnum size field mask)) + ,(cond ((cdr wrappers) + (emit-greater-than-1-dlap wrappers 'miss value-reg)) + (value-reg + (emit-1-t-dlap (car wrappers) 'miss value-reg)) + (t + (emit-1-nil-dlap (car wrappers) 'miss))) + (return-from dfun ,hit)) + miss + (return-from dfun ,miss))))) + +(defun emit-1-nil-dlap (wrapper miss-label) + `(let* ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper miss-label)) + (location primary)) + (declare (fixnum primary location)) + (block search + (loop (when (eq ,wrapper (cache-vector-ref cache-vector location)) + (return-from search nil)) + (setq location (the fixnum (+ location 1))) + (when (= location size) + (setq location 0)) + (when (= location primary) + (dolist (entry overflow) + (when (eq (car entry) ,wrapper) + (return-from search nil))) + (go ,miss-label)))))) + +(defmacro get-cache-vector-lock-count (cache-vector) + `(let ((lock-count (cache-vector-lock-count ,cache-vector))) + (unless (typep lock-count 'fixnum) + (error "my cache got freed somehow")) + (the fixnum lock-count))) + +(defun emit-1-t-dlap (wrapper miss-label value) + `(let ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper miss-label)) + (initial-lock-count (get-cache-vector-lock-count cache-vector))) + (declare (fixnum primary initial-lock-count)) + (let ((location primary)) + (declare (fixnum location)) + (block search + (loop (when (eq ,wrapper (cache-vector-ref cache-vector location)) + (setq ,value (cache-vector-ref cache-vector (1+ location))) + (return-from search nil)) + (setq location (the fixnum (+ location 2))) + (when (= location size) + (setq location 0)) + (when (= location primary) + (dolist (entry overflow) + (when (eq (car entry) ,wrapper) + (setq ,value (cdr entry)) + (return-from search nil))) + (go ,miss-label)))) + (unless (= initial-lock-count + (get-cache-vector-lock-count cache-vector)) + (go ,miss-label))))) + +(defun emit-greater-than-1-dlap (wrappers miss-label value) + (declare (type list wrappers)) + (let ((cache-line-size (compute-line-size (+ (length wrappers) (if value 1 0))))) + `(let ((primary 0) (size-1 (the fixnum (- size 1)))) + (declare (fixnum primary size-1)) + ,(emit-n-wrapper-compute-primary-cache-location wrappers miss-label) + (let ((initial-lock-count (get-cache-vector-lock-count cache-vector))) + (declare (fixnum initial-lock-count)) + (let ((location primary) (next-location 0)) + (declare (fixnum location next-location)) + (block search + (loop (setq next-location (the fixnum (+ location ,cache-line-size))) + (when (and ,@(mapcar + #'(lambda (wrapper) + `(eq ,wrapper + (cache-vector-ref cache-vector + (setq location + (the fixnum (+ location 1)))))) + wrappers)) + ,@(when value + `((setq location (the fixnum (+ location 1))) + (setq ,value (cache-vector-ref cache-vector location)))) + (return-from search nil)) + (setq location next-location) + (when (= location size-1) + (setq location 0)) + (when (= location primary) + (dolist (entry overflow) + (let ((entry-wrappers (car entry))) + (when (and ,@(mapcar #'(lambda (wrapper) + `(eq ,wrapper (pop entry-wrappers))) + wrappers)) + ,@(when value + `((setq ,value (cdr entry)))) + (return-from search nil)))) + (go ,miss-label)))) + (unless (= initial-lock-count + (get-cache-vector-lock-count cache-vector)) + (go ,miss-label))))))) + +(defun emit-1-wrapper-compute-primary-cache-location (wrapper miss-label) + `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref ,wrapper field))) + (declare (fixnum wrapper-cache-no)) + (when (zerop wrapper-cache-no) (go ,miss-label)) + ,(let ((form `(#+lucid %logand #-lucid logand + mask wrapper-cache-no))) + #+lucid form + #-lucid `(the fixnum ,form)))) + +(defun emit-n-wrapper-compute-primary-cache-location (wrappers miss-label) + (declare (type list wrappers)) + ;; this returns 1 less that the actual location + `(progn + ,@(let ((adds 0) (len (length wrappers))) + (declare (fixnum adds len)) + (mapcar #'(lambda (wrapper) + `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref + ,wrapper field))) + (declare (fixnum wrapper-cache-no)) + (when (zerop wrapper-cache-no) (go ,miss-label)) + (setq primary (the fixnum (+ primary wrapper-cache-no))) + ,@(progn + (incf adds) + (when (or (zerop (mod adds wrapper-cache-number-adds-ok)) + (eql adds len)) + `((setq primary + ,(let ((form `(#+lucid %logand #-lucid logand + primary mask))) + #+lucid form + #-lucid `(the fixnum ,form)))))))) + wrappers)))) + +(defun emit-fetch-wrapper (metatype argument miss-label &optional slot) + (ecase metatype + ((standard-instance #+new-kcl-wrapper structure-instance) + `(cond ((std-instance-p ,argument) + ,@(when slot `((setq ,slot (std-instance-slots ,argument)))) + (std-instance-wrapper ,argument)) + ((fsc-instance-p ,argument) + ,@(when slot `((setq ,slot (fsc-instance-slots ,argument)))) + (fsc-instance-wrapper ,argument)) + (t + (go ,miss-label)))) + (class + (when slot (error "Can't do a slot reg for this metatype.")) + `(wrapper-of-macro ,argument)) + ((built-in-instance #-new-kcl-wrapper structure-instance) + (when slot (error "Can't do a slot reg for this metatype.")) + `(#+new-kcl-wrapper built-in-wrapper-of + #-new-kcl-wrapper built-in-or-structure-wrapper + ,argument)))) + diff --git a/pcl/dlisp2.lisp b/pcl/dlisp2.lisp new file mode 100644 index 000000000..7bff7953e --- /dev/null +++ b/pcl/dlisp2.lisp @@ -0,0 +1,175 @@ +;;;-*-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. +;;; ************************************************************************* +;;; + +(in-package 'pcl) + +(defun emit-reader/writer-function (reader/writer 1-or-2-class class-slot-p) + (values + (ecase reader/writer + (:reader (ecase 1-or-2-class + (1 (if class-slot-p + (emit-reader/writer-macro :reader 1 t) + (emit-reader/writer-macro :reader 1 nil))) + (2 (if class-slot-p + (emit-reader/writer-macro :reader 2 t) + (emit-reader/writer-macro :reader 2 nil))))) + (:writer (ecase 1-or-2-class + (1 (if class-slot-p + (emit-reader/writer-macro :writer 1 t) + (emit-reader/writer-macro :writer 1 nil))) + (2 (if class-slot-p + (emit-reader/writer-macro :writer 2 t) + (emit-reader/writer-macro :writer 2 nil)))))) + nil)) + +(defun emit-one-or-n-index-reader/writer-function + (reader/writer cached-index-p class-slot-p) + (values + (ecase reader/writer + (:reader (if cached-index-p + (if class-slot-p + (emit-one-or-n-index-reader/writer-macro :reader t t) + (emit-one-or-n-index-reader/writer-macro :reader t nil)) + (if class-slot-p + (emit-one-or-n-index-reader/writer-macro :reader nil t) + (emit-one-or-n-index-reader/writer-macro :reader nil nil)))) + (:writer (if cached-index-p + (if class-slot-p + (emit-one-or-n-index-reader/writer-macro :writer t t) + (emit-one-or-n-index-reader/writer-macro :writer t nil)) + (if class-slot-p + (emit-one-or-n-index-reader/writer-macro :writer nil t) + (emit-one-or-n-index-reader/writer-macro :writer nil nil))))) + nil)) + +(eval-when (compile load eval) +(defparameter checking-or-caching-list + '() + #|| + '((T NIL (CLASS) NIL) + (T NIL (CLASS CLASS) NIL) + (T NIL (CLASS CLASS CLASS) NIL) + (T NIL (CLASS CLASS T) NIL) + (T NIL (CLASS CLASS T T) NIL) + (T NIL (CLASS CLASS T T T) NIL) + (T NIL (CLASS T) NIL) + (T NIL (CLASS T T) NIL) + (T NIL (CLASS T T T) NIL) + (T NIL (CLASS T T T T) NIL) + (T NIL (CLASS T T T T T) NIL) + (T NIL (CLASS T T T T T T) NIL) + (T NIL (T CLASS) NIL) + (T NIL (T CLASS T) NIL) + (T NIL (T T CLASS) NIL) + (T NIL (CLASS) T) + (T NIL (CLASS CLASS) T) + (T NIL (CLASS T) T) + (T NIL (CLASS T T) T) + (T NIL (CLASS T T T) T) + (T NIL (T CLASS) T) + (T T (CLASS) NIL) + (T T (CLASS CLASS) NIL) + (T T (CLASS CLASS CLASS) NIL) + (NIL NIL (CLASS) NIL) + (NIL NIL (CLASS CLASS) NIL) + (NIL NIL (CLASS CLASS T) NIL) + (NIL NIL (CLASS CLASS T T) NIL) + (NIL NIL (CLASS T) NIL) + (NIL NIL (T CLASS T) NIL) + (NIL NIL (CLASS) T) + (NIL NIL (CLASS CLASS) T)) ||# )) + +(defmacro make-checking-or-caching-function-list () + `(list ,@(mapcar #'(lambda (key) + `(cons ',key (emit-checking-or-caching-macro ,@key))) + checking-or-caching-list))) + +(defvar checking-or-caching-function-list) + +(defun initialize-checking-or-caching-function-list () + (setq checking-or-caching-function-list + (make-checking-or-caching-function-list))) + +(initialize-checking-or-caching-function-list) + +(defmacro emit-checking-or-caching-function-precompiled () + `(cdr (assoc (list cached-emf-p return-value-p metatypes applyp) + checking-or-caching-function-list + :test #'equal))) + +(defun emit-checking-or-caching-function (cached-emf-p return-value-p metatypes applyp) + (let ((fn (emit-checking-or-caching-function-precompiled))) + (if fn + (values fn nil) + (values (emit-checking-or-caching-function-preliminary + cached-emf-p return-value-p metatypes applyp) + t)))) + +(defvar not-in-cache (make-symbol "not in cache")) + +(defun emit-checking-or-caching-function-preliminary + (cached-emf-p return-value-p metatypes applyp) + (declare (ignore applyp)) + (if cached-emf-p + #'(lambda (cache miss-fn) + #'(lambda (&rest args) + (declare #.*optimize-speed*) + (with-dfun-wrappers (args metatypes) + (dfun-wrappers invalid-wrapper-p) + (apply miss-fn args) + (if invalid-wrapper-p + (apply miss-fn args) + (let ((emf (probe-cache cache dfun-wrappers not-in-cache))) + (if (eq emf not-in-cache) + (apply miss-fn args) + (if return-value-p + emf + (invoke-emf emf args)))))))) + #'(lambda (cache emf miss-fn) + #'(lambda (&rest args) + (declare #.*optimize-speed*) + (with-dfun-wrappers (args metatypes) + (dfun-wrappers invalid-wrapper-p) + (apply miss-fn args) + (if invalid-wrapper-p + (apply miss-fn args) + (let ((found-p (not (eq not-in-cache + (probe-cache cache dfun-wrappers + not-in-cache))))) + (if found-p + (invoke-emf emf args) + (if return-value-p + t + (apply miss-fn args)))))))))) + + +(defun emit-default-only-function (metatypes applyp) + (declare (ignore metatypes applyp)) + (values #'(lambda (emf) + #'(lambda (&rest args) + (invoke-emf emf args))) + t)) diff --git a/pcl/fast-init.lisp b/pcl/fast-init.lisp new file mode 100644 index 000000000..a083f5c25 --- /dev/null +++ b/pcl/fast-init.lisp @@ -0,0 +1,895 @@ +;;;-*-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 file defines the optimized make-instance functions. +;;; + +(in-package 'pcl) + +;make-instance-functions take up more space when compiled. +(defvar *inhibit-compile-make-instance-functions-p* nil) + +(defvar *compile-make-instance-functions-p* nil) ; this gets bound to t below + +(defvar *make-instance-function-table* (make-hash-table :test 'equal)) + +(defvar gmif-class nil) + +(defun update-make-instance-function-table (&optional (gmif-class *the-class-t*)) + (when (symbolp gmif-class) (setq gmif-class (find-class gmif-class))) + (let ((class gmif-class)) + (when (eq class *the-class-t*) (setq class *the-class-slot-object*)) + (when (memq *the-class-slot-object* (class-precedence-list class)) + (map-all-classes #'reset-class-initialize-info class))) + (maphash #'get-make-instance-function *make-instance-function-table*)) + +(defun get-make-instance-function-key (class initargs) + (let ((keys nil)(allow-other-keys-p nil) key value) + (when initargs + (let ((initargs-tail initargs)) + (setq key (pop initargs-tail) value (pop initargs-tail)) + (when (eq key ':allow-other-keys) + (setq allow-other-keys-p value)) + (setq keys (cons key nil)) + (when initargs-tail + (let ((keys-tail keys)) + (loop (setq key (pop initargs-tail) value (pop initargs-tail)) + (when (eq key ':allow-other-keys) + (setq allow-other-keys-p value)) + (if keys-tail + (setf (cdr keys-tail) (cons key nil) + keys-tail (cdr keys-tail)) + (setf keys-tail (setf keys (cons key nil)))) + (when (null initargs-tail) (return nil))))))) + (list class keys allow-other-keys-p))) + +(defmacro %get-make-instance-function (class initargs) + `(let ((key (get-make-instance-function-key ,class ,initargs))) + (or (car (gethash key *make-instance-function-table*)) + (get-make-instance-function key)))) + +(defun constant-symbol-p (form) + (and (constantp form) (symbolp (eval form)))) + +(defvar *make-instance-function-keys* nil) +(defvar *skip-boundp-check* nil) + +(defun expand-make-instance-form (form &optional + (skip-boundp-check *skip-boundp-check*)) + (let ((class (cadr form)) (initargs (cddr form)) + (keys nil)(allow-other-keys-p nil) key value) + (when (and (constant-symbol-p class) + (let ((initargs-tail initargs)) + (loop (when (null initargs-tail) (return t)) + (unless (constant-symbol-p (car initargs-tail)) + (return nil)) + (setq key (eval (pop initargs-tail))) + (setq value (pop initargs-tail)) + (when (eq ':allow-other-keys key) + (setq allow-other-keys-p value)) + (push key keys)))) + (let* ((class (eval class)) + (keys (nreverse keys)) + (key (list class keys allow-other-keys-p)) + (sym (make-instance-function-symbol key))) + (push key *make-instance-function-keys*) + (if (and sym skip-boundp-check) + `(,sym ',class (list ,@initargs)) + `(funcall ,(if sym + `(if (#-akcl fboundp #+akcl %fboundp ',sym) + (#-akcl symbol-function #+akcl %symbol-function ',sym) + (get-make-instance-function ',key)) + `(get-make-instance-function ',key)) + ',class (list ,@initargs))))))) + +(defmacro expanding-make-instance-top-level (&rest forms &environment env) + (let* ((*make-instance-function-keys* nil) + (*skip-boundp-check* t) + (form (macroexpand `(expanding-make-instance ,@forms) env))) + `(progn + ,@(when *make-instance-function-keys* + `((get-make-instance-functions ',*make-instance-function-keys*))) + ,form))) + +(defmacro expanding-make-instance (&rest forms &environment env) + `(progn + ,@(mapcar #'(lambda (form) + (walk-form form env + #'(lambda (subform context env) + (declare (ignore env)) + (or (and (eq context ':eval) + (consp subform) + (eq (car subform) 'make-instance) + (expand-make-instance-form subform)) + subform)))) + forms))) + +(defmacro defconstructor + (name class lambda-list &rest initialization-arguments) + `(expanding-make-instance-top-level + (defun ,name ,lambda-list + (make-instance ',class ,@initialization-arguments)))) + +(defun get-make-instance-functions (key-list &optional compile-p) + (let ((*compile-make-instance-functions-p* compile-p)) + (dolist (key key-list) + (if compile-p + (get-make-instance-function key) + (set-make-instance-function (make-instance-function-symbol key) + key + (make-lazy-get-make-instance-function key) + nil))))) + +(defun make-instance-function-symbol (key) + (let ((class (car key))) + (when (or (symbolp class) (classp class)) + (let* ((class-name (if (symbolp class) class (class-name class))) + (keys (cadr key)) + (allow-other-keys-p (caddr key))) + (let ((*package* *the-pcl-package*) + (*print-length* nil) (*print-level* nil) + (*print-circle* nil) (*print-case* :upcase) + (*print-pretty* nil)) + (intern (format nil "MAKE-INSTANCE ~S ~S ~S" + class-name keys allow-other-keys-p))))))) + +(defun make-lazy-get-make-instance-function (key) + #'(lambda (class initargs) + (if (eq *boot-state* 'complete) + (funcall (get-make-instance-function key) class initargs) + (apply #'make-instance class initargs)))) + +(defun get-make-instance-function (key &optional (value (list nil nil))) + (let* ((class (car key)) + (keys (cadr key)) + (gmif-class-1 gmif-class) (gmif-class nil) + name) + (flet ((return-function (function) + (return-from get-make-instance-function + (set-make-instance-function name key function nil)))) + (unless (eq *boot-state* 'complete) + (return-function (make-lazy-get-make-instance-function key))) + (when (symbolp class) + (let ((real-class (find-class class nil))) + (unless real-class + (if gmif-class-1 + (return-function (make-lazy-get-make-instance-function key)) + (error "class ~S not found" class))) + (setq class real-class))) + (when (classp class) + (unless (class-finalized-p class) (finalize-inheritance class)) + (when (and gmif-class-1 + (not (member gmif-class-1 (class-precedence-list class)))) + (return-from get-make-instance-function nil)) + (setq name (make-instance-function-symbol key)) + (when (and gmif-class-1 (not *compile-make-instance-functions-p*)) + (return-function + #'(lambda (class initargs) + (funcall (get-make-instance-function key) class initargs))))) + (let* ((initargs (mapcan #'(lambda (key) (list key nil)) keys)) + (class-and-initargs (list* class initargs)) + (make-instance (gdefinition 'make-instance)) + (make-instance-methods + (compute-applicable-methods make-instance class-and-initargs)) + (std-mi-meth (find-standard-ii-method make-instance-methods 'class)) + (class+initargs (list class initargs)) + (default-initargs (gdefinition 'default-initargs)) + (default-initargs-methods + (compute-applicable-methods default-initargs class+initargs)) + (proto (and (classp class) (class-prototype class))) + (initialize-instance-methods + (when proto + (compute-applicable-methods (gdefinition 'initialize-instance) + (list* proto initargs)))) + (shared-initialize-methods + (when proto + (compute-applicable-methods (gdefinition 'shared-initialize) + (list* proto t initargs))))) + (when (null make-instance-methods) + (return-function + #'(lambda (class initargs) + (apply #'no-applicable-method make-instance class initargs)))) + (unless (and (null (cdr make-instance-methods)) + (eq (car make-instance-methods) std-mi-meth) + (null (cdr default-initargs-methods)) + (eq (car (method-specializers (car default-initargs-methods))) + *the-class-slot-class*) + (flet ((check-meth (meth) + (let ((quals (method-qualifiers meth))) + (if (null quals) + (eq (car (method-specializers meth)) + *the-class-slot-object*) + (and (null (cdr quals)) + (or (eq (car quals) ':before) + (eq (car quals) ':after))))))) + (and (every #'check-meth initialize-instance-methods) + (every #'check-meth shared-initialize-methods)))) + (return-function + #'(lambda (class initargs) + (apply #'make-instance class initargs)))) + (get-make-instance-function-internal + class key (default-initargs class initargs) + initialize-instance-methods shared-initialize-methods + name + (or (cadr value) + (and *compile-make-instance-functions-p* + (not *inhibit-compile-make-instance-functions-p*)))))))) + +(defun get-make-instance-function-internal (class key initargs + initialize-instance-methods + shared-initialize-methods + &optional (name nil name-p) + compile-p) + (let* ((*compile-make-instance-functions-p* compile-p) + (keys (cadr key)) + (allow-other-keys-p (caddr key)) + (allocate-instance-methods + (compute-applicable-methods (gdefinition 'allocate-instance) + (list* class initargs)))) + (unless allow-other-keys-p + (unless (check-initargs-1 + class initargs + (append allocate-instance-methods + initialize-instance-methods + shared-initialize-methods) + t nil) + (return-from get-make-instance-function-internal + (make-lazy-get-make-instance-function key)))) + (let ((function (if (or (cdr allocate-instance-methods) + (some #'complicated-instance-creation-method + initialize-instance-methods) + (some #'complicated-instance-creation-method + shared-initialize-methods)) + (make-instance-function-complex + key class keys + initialize-instance-methods shared-initialize-methods) + (make-instance-function-simple + key class keys + initialize-instance-methods shared-initialize-methods)))) + (when name-p (set-make-instance-function name key function compile-p)) + function))) + +(defun set-make-instance-function (name key function compile-p) + #-cmu (set-function-name function name) + (when name (setf (symbol-function name) function)) + (setf (gethash key *make-instance-function-table*) + (list function compile-p)) + function) + +(defun complicated-instance-creation-method (m) + (let ((qual (method-qualifiers m))) + (if qual + (not (and (null (cdr qual)) (eq (car qual) ':after))) + (let ((specl (car (method-specializers m)))) + (or (not (classp specl)) + (not (eq 'slot-object (class-name specl)))))))) + +(defun find-standard-ii-method (methods class-names) + (dolist (m methods) + (when (null (method-qualifiers m)) + (let ((specl (car (method-specializers m)))) + (when (and (classp specl) + (if (listp class-names) + (member (class-name specl) class-names) + (eq (class-name specl) class-names))) + (return m)))))) + +(defmacro call-initialize-function (initialize-function instance initargs) + `(let ((.function. ,initialize-function)) + (if (and (consp .function.) + (eq (car .function.) 'call-initialize-instance-simple)) + (initialize-instance-simple (cadr .function.) (caddr .function.) + ,instance ,initargs) + (funcall .function. ,instance ,initargs)))) + +(defun make-instance-function-simple (key class keys + initialize-instance-methods + shared-initialize-methods) + (multiple-value-bind (initialize-function constants) + (get-simple-initialization-function class keys (caddr key)) + (let* ((wrapper (class-wrapper class)) + (lwrapper (list wrapper)) + (allocate-function + (cond ((structure-class-p class) + #'allocate-structure-instance) + ((standard-class-p class) + #'allocate-standard-instance) + ((funcallable-standard-class-p class) + #'allocate-funcallable-instance) + (t + (error "error in make-instance-function-simple")))) + (std-si-meth (find-standard-ii-method shared-initialize-methods + 'slot-object)) + (shared-initfns + (nreverse (mapcar #'(lambda (method) + (make-effective-method-function + #'shared-initialize + `(call-method ,method nil) + nil lwrapper)) + (remove std-si-meth shared-initialize-methods)))) + (std-ii-meth (find-standard-ii-method initialize-instance-methods + 'slot-object)) + (initialize-initfns + (nreverse (mapcar #'(lambda (method) + (make-effective-method-function + #'initialize-instance + `(call-method ,method nil) + nil lwrapper)) + (remove std-ii-meth + initialize-instance-methods))))) + #'(lambda (class1 initargs) + (declare (ignore class1)) + (if (not (eq wrapper (class-wrapper class))) + (funcall (get-make-instance-function key) class initargs) + (let* ((instance (funcall allocate-function wrapper constants)) + (initargs (call-initialize-function initialize-function + instance initargs))) + (dolist (fn shared-initfns) + (invoke-effective-method-function fn t instance t initargs)) + (dolist (fn initialize-initfns) + (invoke-effective-method-function fn t instance initargs)) + instance)))))) + +(defun make-instance-function-complex (key class keys + initialize-instance-methods + shared-initialize-methods) + (multiple-value-bind (initargs-function initialize-function) + (get-complex-initialization-functions class keys (caddr key)) + (let* ((wrapper (class-wrapper class)) + (shared-initialize + (get-secondary-dispatch-function + #'shared-initialize shared-initialize-methods + `((class-eq ,class) t t) + `((,(find-standard-ii-method shared-initialize-methods 'slot-object) + ,#'(lambda (instance init-type &rest initargs) + (declare (ignore init-type)) + (call-initialize-function initialize-function + instance initargs) + instance))) + (list wrapper *the-wrapper-of-t* *the-wrapper-of-t*))) + (initialize-instance + (get-secondary-dispatch-function + #'initialize-instance initialize-instance-methods + `((class-eq ,class) t) + `((,(find-standard-ii-method initialize-instance-methods 'slot-object) + ,#'(lambda (instance &rest initargs) + (invoke-effective-method-function + shared-initialize t instance t initargs)))) + (list wrapper *the-wrapper-of-t*)))) + #'(lambda (class1 initargs) + (declare (ignore class1)) + (if (not (eq wrapper (class-wrapper class))) + (funcall (get-make-instance-function key) class initargs) + (let* ((initargs (call-initialize-function initargs-function + nil initargs)) + (instance (apply #'allocate-instance class initargs))) + (invoke-effective-method-function + initialize-instance t instance initargs) + instance)))))) + +(defmacro define-cached-reader (type name trap) + (let ((reader-name (intern (format nil "~A-~A" type name))) + (cached-name (intern (format nil "~A-CACHED-~A" type name)))) + `(defmacro ,reader-name (info) + `(let ((value (,',cached-name ,info))) + (if (eq value ':unknown) + (progn + (,',trap ,info ',',name) + (,',cached-name ,info)) + value))))) + +(eval-when (compile load eval) +(defparameter initialize-info-cached-slots + '(valid-p ; t or (:invalid key) + ri-valid-p + initargs-form-list + new-keys + default-initargs-function + shared-initialize-t-function + shared-initialize-nil-function + constants + combined-initialize-function))) + +(defmacro define-initialize-info () + (flet ((cached-slot-name (name) + (intern (format nil "CACHED-~A" name))) + (cached-name (name) + (intern (format nil "~A-CACHED-~A" 'initialize-info name)))) + `(progn + (defstruct initialize-info + key wrapper + ,@(mapcar #'cached-slot-name initialize-info-cached-slots)) + (defun reset-initialize-info (info) + ,@(mapcar #'(lambda (name) + `(setf (,(cached-name name) info) ':unknown)) + initialize-info-cached-slots) + info) + ,@(mapcar #'(lambda (name) + `(define-cached-reader initialize-info ,name + update-initialize-info-internal)) + initialize-info-cached-slots)))) + +(define-initialize-info) + +(defvar *initialize-info-cache-class* nil) +(defvar *initialize-info-cache-initargs* nil) +(defvar *initialize-info-cache-info* nil) + +(defun reset-class-initialize-info (class) + (reset-class-initialize-info-1 (class-initialize-info class))) + +(defun reset-class-initialize-info-1 (cell) + (when (consp cell) + (when (car cell) + (setf (initialize-info-wrapper (car cell)) nil)) + (let ((alist (cdr cell))) + (dolist (a alist) + (reset-class-initialize-info-1 (cdr a)))))) + +(defun initialize-info (class initargs &optional (plist-p t) allow-other-keys-arg) + (let ((info nil)) + (if (and (eq *initialize-info-cache-class* class) + (eq *initialize-info-cache-initargs* initargs)) + (setq info *initialize-info-cache-info*) + (let ((initargs-tail initargs) + (cell (or (class-initialize-info class) + (setf (class-initialize-info class) (cons nil nil))))) + (loop (when (null initargs-tail) (return nil)) + (let ((keyword (pop initargs-tail)) + (alist-cell cell)) + (when plist-p + (if (eq keyword :allow-other-keys) + (setq allow-other-keys-arg (pop initargs-tail)) + (pop initargs-tail))) + (loop (let ((alist (cdr alist-cell))) + (when (null alist) + (setq cell (cons nil nil)) + (setf (cdr alist-cell) (list (cons keyword cell))) + (return nil)) + (when (eql keyword (caar alist)) + (setq cell (cdar alist)) + (return nil)) + (setq alist-cell alist))))) + (setq info (or (car cell) + (setf (car cell) (make-initialize-info)))))) + (let ((wrapper (initialize-info-wrapper info))) + (unless (eq wrapper (class-wrapper class)) + (unless wrapper + (let* ((initargs-tail initargs) + (klist-cell (list nil)) + (klist-tail klist-cell)) + (loop (when (null initargs-tail) (return nil)) + (let ((key (pop initargs-tail))) + (setf (cdr klist-tail) (list key))) + (setf klist-tail (cdr klist-tail)) + (when plist-p (pop initargs-tail))) + (setf (initialize-info-key info) + (list class (cdr klist-cell) allow-other-keys-arg)))) + (update-initialize-info info))) + (setq *initialize-info-cache-class* class) + (setq *initialize-info-cache-initargs* initargs) + (setq *initialize-info-cache-info* info) + info)) + +(defun update-initialize-info (info) + (let* ((key (initialize-info-key info)) + (class (car key))) + (setf (initialize-info-wrapper info) (class-wrapper class)) + (reset-initialize-info info) + info)) + +(defun update-initialize-info-internal (info name) + (let* ((key (initialize-info-key info)) + (class (car key)) + (keys (cadr key)) + (allow-other-keys-arg (caddr key))) + (ecase name + ((initargs-form-list new-keys) + (multiple-value-bind (initargs-form-list new-keys) + (make-default-initargs-form-list class keys) + (setf (initialize-info-cached-initargs-form-list info) initargs-form-list) + (setf (initialize-info-cached-new-keys info) new-keys))) + ((default-initargs-function) + (let ((initargs-form-list (initialize-info-initargs-form-list info))) + (setf (initialize-info-cached-default-initargs-function info) + (initialize-instance-simple-function class initargs-form-list)))) + ((valid-p ri-valid-p) + (flet ((compute-valid-p (methods) + (or (not (null allow-other-keys-arg)) + (multiple-value-bind (legal allow-other-keys) + (check-initargs-values class methods) + (or (not (null allow-other-keys)) + (dolist (key keys t) + (unless (member key legal) + (return (cons :invalid key))))))))) + (let ((proto (class-prototype class))) + (setf (initialize-info-cached-valid-p info) + (compute-valid-p (list (list* 'allocate-instance class nil) + (list* 'initialize-instance proto nil) + (list* 'shared-initialize proto t nil)))) + (setf (initialize-info-cached-ri-valid-p info) + (compute-valid-p (list (list* 'reinitialize-instance proto nil) + (list* 'shared-initialize proto nil nil))))))) + ((shared-initialize-t-function) + (multiple-value-bind (initialize-form-list ignore) + (make-shared-initialize-form-list class keys t nil) + (declare (ignore ignore)) + (setf (initialize-info-cached-shared-initialize-t-function info) + (initialize-instance-simple-function class initialize-form-list)))) + ((shared-initialize-nil-function) + (multiple-value-bind (initialize-form-list ignore) + (make-shared-initialize-form-list class keys nil nil) + (declare (ignore ignore)) + (setf (initialize-info-cached-shared-initialize-nil-function info) + (initialize-instance-simple-function class initialize-form-list)))) + ((constants combined-initialize-function) + (let ((initargs-form-list (initialize-info-initargs-form-list info)) + (new-keys (initialize-info-new-keys info))) + (multiple-value-bind (initialize-form-list constants) + (make-shared-initialize-form-list class new-keys t t) + (setf (initialize-info-cached-constants info) constants) + (setf (initialize-info-cached-combined-initialize-function info) + (initialize-instance-simple-function + class (append initargs-form-list initialize-form-list)))))))) + info) + +(defun get-simple-initialization-function (class keys &optional allow-other-keys-arg) + (let ((info (initialize-info class keys nil allow-other-keys-arg))) + (values (initialize-info-combined-initialize-function info) + (initialize-info-constants info)))) + +(defun get-complex-initialization-functions (class keys &optional allow-other-keys-arg + separate-p) + (let* ((info (initialize-info class keys nil allow-other-keys-arg)) + (default-initargs-function (initialize-info-default-initargs-function info))) + (if separate-p + (values default-initargs-function + (initialize-info-shared-initialize-t-function info)) + (values default-initargs-function + (initialize-info-shared-initialize-t-function + (initialize-info class (initialize-info-new-keys info) + nil allow-other-keys-arg)))))) + +(defun add-forms (forms forms-list) + (when forms + (setq forms (copy-list forms)) + (if (null (car forms-list)) + (setf (car forms-list) forms) + (setf (cddr forms-list) forms)) + (setf (cdr forms-list) (last forms))) + (car forms-list)) + +(defun make-default-initargs-form-list (class keys &optional (separate-p t)) + (let ((initargs-form-list (cons nil nil)) + (default-initargs (class-default-initargs class)) + (nkeys keys)) + (dolist (default default-initargs) + (let ((key (car default)) + (function (cadr default))) + (unless (member key nkeys) + (add-forms `((funcall ,function) (push-initarg ,key)) + initargs-form-list) + (push key nkeys)))) + (when separate-p + (add-forms `((update-initialize-info-cache + ,class ,(initialize-info class nkeys nil))) + initargs-form-list)) + (add-forms `((finish-pushing-initargs)) + initargs-form-list) + (values (car initargs-form-list) nkeys))) + +(defun make-shared-initialize-form-list (class keys si-slot-names simple-p) + (let* ((initialize-form-list (cons nil nil)) + (type (cond ((structure-class-p class) + 'structure) + ((standard-class-p class) + 'standard) + ((funcallable-standard-class-p class) + 'funcallable) + (t (error "error in make-shared-initialize-form-list")))) + (wrapper (class-wrapper class)) + (constants (when simple-p + (make-list (wrapper-no-of-instance-slots wrapper) + ':initial-element *slot-unbound*))) + (slots (class-slots class)) + (slot-names (mapcar #'slot-definition-name slots)) + (slots-key (mapcar #'(lambda (slot) + (let ((index most-positive-fixnum)) + (dolist (key (slot-definition-initargs slot)) + (let ((pos (position key keys))) + (when pos (setq index (min index pos))))) + (cons slot index))) + slots)) + (slots (stable-sort slots-key #'< :key #'cdr))) + (let ((n-popped 0)) + (dolist (slot+index slots) + (let* ((slot (car slot+index)) + (name (slot-definition-name slot)) + (npop (1+ (- (cdr slot+index) n-popped)))) + (unless (eql (cdr slot+index) most-positive-fixnum) + (let* ((pv-offset (1+ (position name slot-names)))) + (add-forms `(,@(when (plusp npop) + `((pop-initargs ,(* 2 npop)))) + (instance-set ,pv-offset ,slot)) + initialize-form-list)) + (incf n-popped npop))))) + (dolist (slot+index slots) + (let* ((slot (car slot+index)) + (name (slot-definition-name slot))) + (when (and (eql (cdr slot+index) most-positive-fixnum) + (or (eq si-slot-names 't) + (member name si-slot-names))) + (let* ((initform (slot-definition-initform slot)) + (initfunction (slot-definition-initfunction slot)) + (location (unless (eq type 'structure) + (slot-definition-location slot))) + (pv-offset (1+ (position name slot-names))) + (forms (cond ((null initfunction) + nil) + ((constantp initform) + (let ((value (funcall initfunction))) + (if (and simple-p (integerp location)) + (progn (setf (nth location constants) value) + nil) + `((const ,value) + (instance-set ,pv-offset ,slot))))) + (t + `((funcall ,(slot-definition-initfunction slot)) + (instance-set ,pv-offset ,slot)))))) + (add-forms `(,@(unless (or simple-p (null forms)) + `((skip-when-instance-boundp ,pv-offset ,slot + ,(length forms)))) + ,@forms) + initialize-form-list))))) + (values (car initialize-form-list) constants))) + +(defvar *class-pv-table-table* (make-hash-table :test 'eq)) + +(defun get-pv-cell-for-class (class) + (let* ((slot-names (mapcar #'slot-definition-name (class-slots class))) + (slot-name-lists (list (cons nil slot-names))) + (pv-table (gethash class *class-pv-table-table*))) + (unless (and pv-table + (equal slot-name-lists (pv-table-slot-name-lists pv-table))) + (setq pv-table (intern-pv-table :slot-name-lists slot-name-lists)) + (setf (gethash class *class-pv-table-table*) pv-table)) + (pv-table-lookup pv-table (class-wrapper class)))) + +(defvar *initialize-instance-simple-alist* nil) +(defvar *note-iis-entry-p* nil) + +(defun initialize-instance-simple-function (class form-list) + (let ((pv-cell (get-pv-cell-for-class class))) + (if (and *compile-make-instance-functions-p* + (not *inhibit-compile-make-instance-functions-p*)) + (multiple-value-bind (form args) + (form-list-to-lisp pv-cell form-list) + (let ((entry (assoc form *initialize-instance-simple-alist* + :test #'equal))) + (unless entry + (setq entry (list form + (unless *note-iis-entry-p* (compile-lambda form)) + nil)) + (setq *initialize-instance-simple-alist* + (nconc *initialize-instance-simple-alist* + (list entry)))) + (if (cadr entry) + (apply (cadr entry) args) + `(call-initialize-instance-simple ,pv-cell ,form-list)))) + #|| + #'(lambda (instance initargs) + (initialize-instance-simple pv-cell form-list instance initargs)) + ||# + `(call-initialize-instance-simple ,pv-cell ,form-list)))) + +(defun load-precompiled-iis-entry (form function system) + (let ((entry (assoc form *initialize-instance-simple-alist* + :test #'equal))) + (unless entry + (setq entry (list form nil nil)) + (setq *initialize-instance-simple-alist* + (nconc *initialize-instance-simple-alist* + (list entry)))) + (setf (cadr entry) function) + (setf (caddr entry) system))) + +(defmacro precompile-iis-functions (&optional system) + (let ((index -1)) + `(progn + ,@(gathering1 (collecting) + (dolist (iis-entry *initialize-instance-simple-alist*) + (when (or (null (caddr iis-entry)) + (eq (caddr iis-entry) system)) + (when system (setf (caddr iis-entry) system)) + (gather1 + (make-top-level-form + `(precompile-initialize-instance-simple ,system ,(incf index)) + '(load) + `(load-precompiled-iis-entry + ',(car iis-entry) + #',(car iis-entry) + ',system))))))))) + +(defun compile-iis-functions (after-p) + (let ((*compile-make-instance-functions-p* t) + (*note-iis-entry-p* (not after-p))) + (declare (special *compile-make-instance-functions-p*)) + (when (eq *boot-state* 'complete) + (update-make-instance-function-table)))) + + +;(const const) +;(funcall function) +;(push-initarg const) +;(pop-supplied count) ; a positive odd number +;(instance-set pv-offset slotd) +;(skip-when-instance-boundp pv-offset slotd n) + +(defun initialize-instance-simple (pv-cell form-list instance initargs) + (let ((pv (car pv-cell)) + (initargs-tail initargs) + (slots (get-slots-or-nil instance)) + (class (class-of instance)) + value) + (loop (when (null form-list) (return nil)) + (let ((form (pop form-list))) + (ecase (car form) + (push-initarg + (push value initargs) + (push (cadr form) initargs)) + (const + (setq value (cadr form))) + (funcall + (setq value (funcall (cadr form)))) + (pop-initargs + (setq initargs-tail (nthcdr (1- (cadr form)) initargs-tail)) + (setq value (pop initargs-tail))) + (instance-set + (instance-write-internal + pv slots (cadr form) value + (setf (slot-value-using-class class instance (caddr form)) value))) + (skip-when-instance-boundp + (when (instance-boundp-internal + pv slots (cadr form) + (slot-boundp-using-class class instance (caddr form))) + (dotimes (i (cadddr form)) + (pop form-list)))) + (update-initialize-info-cache + (when (consp initargs) + (setq initargs (cons (car initargs) (cdr initargs)))) + (setq *initialize-info-cache-class* (cadr form)) + (setq *initialize-info-cache-initargs* initargs) + (setq *initialize-info-cache-info* (caddr form))) + (finish-pushing-initargs + (setq initargs-tail initargs))))) + initargs)) + +(defun add-to-cvector (cvector constant) + (or (position constant cvector) + (prog1 (fill-pointer cvector) + (vector-push-extend constant cvector)))) + +(defvar *inline-iis-instance-locations-p* t) + +(defun first-form-to-lisp (forms cvector pv) + (flet ((const (constant) + (cond ((or (numberp constant) (characterp constant)) + constant) + ((and (symbolp constant) (symbol-package constant)) + `',constant) + (t + `(svref cvector ,(add-to-cvector cvector constant)))))) + (let ((form (pop (car forms)))) + (ecase (car form) + (push-initarg + `((push value initargs) + (push ,(const (cadr form)) initargs))) + (const + `((setq value ,(const (cadr form))))) + (funcall + `((setq value (funcall (the function ,(const (cadr form))))))) + (pop-initargs + `((setq initargs-tail (,@(let ((pop (1- (cadr form)))) + (case pop + (1 `(cdr)) + (3 `(cdddr)) + (t `(nthcdr ,pop)))) + initargs-tail)) + (setq value (pop initargs-tail)))) + (instance-set + (let* ((pv-offset (cadr form)) + (location (pvref pv pv-offset)) + (default `(setf (slot-value-using-class class instance + ,(const (caddr form))) + value))) + (if *inline-iis-instance-locations-p* + (typecase location + (fixnum `((setf (%instance-ref slots ,(const location)) value))) + (cons `((setf (cdr ,(const location)) value))) + (t `(,default))) + `((instance-write-internal pv slots ,(const pv-offset) value + ,default + ,(typecase location + (fixnum ':instance) + (cons ':class) + (t ':default))))))) + (skip-when-instance-boundp + (let* ((pv-offset (cadr form)) + (location (pvref pv pv-offset)) + (default `(slot-boundp-using-class class instance + ,(const (caddr form))))) + `((unless ,(if *inline-iis-instance-locations-p* + (typecase location + (fixnum `(not (eq (%instance-ref slots ,(const location)) + ',*slot-unbound*))) + (cons `(not (eq (cdr ,(const location)) ',*slot-unbound*))) + (t default)) + `(instance-boundp-internal pv slots ,(const pv-offset) + ,default + ,(typecase (pvref pv pv-offset) + (fixnum ':instance) + (cons ':class) + (t ':default)))) + ,@(let ((sforms (cons nil nil))) + (dotimes (i (cadddr form) (car sforms)) + (add-forms (first-form-to-lisp forms cvector pv) sforms))))))) + (update-initialize-info-cache + `((when (consp initargs) + (setq initargs (cons (car initargs) (cdr initargs)))) + (setq *initialize-info-cache-class* ,(const (cadr form))) + (setq *initialize-info-cache-initargs* initargs) + (setq *initialize-info-cache-info* ,(const (caddr form))))) + (finish-pushing-initargs + `((setq initargs-tail initargs))))))) + +(defmacro iis-body (&body forms) + `(let ((initargs-tail initargs) + (slots (get-slots-or-nil instance)) + (class (class-of instance)) + (pv (car pv-cell)) + value) + initargs instance initargs-tail pv cvector slots class value + ,@forms)) + +(defun form-list-to-lisp (pv-cell form-list) + (let* ((forms (list form-list)) + (cvector (make-array (floor (length form-list) 2) + :fill-pointer 0 :adjustable t)) + (pv (car pv-cell)) + (body (let ((rforms (cons nil nil))) + (loop (when (null (car forms)) (return (car rforms))) + (add-forms (first-form-to-lisp forms cvector pv) + rforms)))) + (cvector-type `(simple-vector ,(length cvector)))) + (values + `(lambda (pv-cell cvector) + (declare (type ,cvector-type cvector)) + #'(lambda (instance initargs) + (declare #.*optimize-speed*) + (iis-body ,@body) + initargs)) + (list pv-cell (coerce cvector cvector-type))))) diff --git a/pcl/inline.lisp b/pcl/inline.lisp new file mode 100644 index 000000000..b884310ef --- /dev/null +++ b/pcl/inline.lisp @@ -0,0 +1,263 @@ +;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- + +(in-package :pcl) + +;; This file contains some of the things that will have to change to support +;; inlining of methods. + +(defun make-method-lambda-internal (method-lambda &optional env) + (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda)) + (error "The method-lambda argument to make-method-lambda, ~S,~ + is not a lambda form" method-lambda)) + (multiple-value-bind (documentation declarations real-body) + (extract-declarations (cddr method-lambda) env) + (let* ((name-decl (get-declaration 'method-name declarations)) + (sll-decl (get-declaration 'method-lambda-list declarations)) + (method-name (when (consp name-decl) (car name-decl))) + (generic-function-name (when method-name (car method-name))) + (specialized-lambda-list (or sll-decl (cadr method-lambda)))) + (multiple-value-bind (parameters lambda-list specializers) + (parse-specialized-lambda-list specialized-lambda-list) + (let* ((required-parameters + (mapcar #'(lambda (r s) (declare (ignore s)) r) + parameters + specializers)) + (slots (mapcar #'list required-parameters)) + (calls (list nil)) + (parameters-to-reference + (make-parameter-references specialized-lambda-list + required-parameters + declarations + method-name + specializers)) + (class-declarations + `(declare + ,@(remove nil + (mapcar #'(lambda (a s) (and (symbolp s) + (neq s 't) + `(class ,a ,s))) + parameters + specializers)))) + (method-lambda + ;; Remove the documentation string and insert the + ;; appropriate class declarations. The documentation + ;; string is removed to make it easy for us to insert + ;; new declarations later, they will just go after the + ;; cadr of the method lambda. The class declarations + ;; are inserted to communicate the class of the method's + ;; arguments to the code walk. + `(lambda ,lambda-list + ,class-declarations + ,@declarations + (progn ,@parameters-to-reference) + (block ,(if (listp generic-function-name) + (cadr generic-function-name) + generic-function-name) + ,@real-body))) + (constant-value-p (and (null (cdr real-body)) + (constantp (car real-body)))) + (constant-value (and constant-value-p + (eval (car real-body)))) + (plist (if (and constant-value-p + (or (typep constant-value '(or number character)) + (and (symbolp constant-value) + (symbol-package constant-value)))) + (list :constant-value constant-value) + ())) + (applyp (dolist (p lambda-list nil) + (cond ((memq p '(&optional &rest &key)) + (return t)) + ((eq p '&aux) + (return nil)))))) + (multiple-value-bind (walked-lambda call-next-method-p closurep + next-method-p-p) + (walk-method-lambda method-lambda required-parameters env + slots calls) + (multiple-value-bind (ignore walked-declarations walked-lambda-body) + (extract-declarations (cddr walked-lambda)) + (declare (ignore ignore)) + (when (or next-method-p-p call-next-method-p) + (setq plist (list* :needs-next-methods-p 't plist))) + (when (some #'cdr slots) + (multiple-value-bind (slot-name-lists call-list) + (slot-name-lists-from-slots slots calls) + (let ((pv-table-symbol (make-symbol "pv-table"))) + (setq plist + `(,@(when slot-name-lists + `(:slot-name-lists ,slot-name-lists)) + ,@(when call-list + `(:call-list ,call-list)) + :pv-table-symbol ,pv-table-symbol + ,@plist)) + (setq walked-lambda-body + `((pv-binding (,required-parameters ,slot-name-lists + ,pv-table-symbol) + ,@walked-lambda-body)))))) + (when (and (memq '&key lambda-list) + (not (memq '&allow-other-keys lambda-list))) + (let ((aux (memq '&aux lambda-list))) + (setq lambda-list (nconc (ldiff lambda-list aux) + (list '&allow-other-keys) + aux)))) + (values `(lambda (.method-args. .next-methods.) + (simple-lexical-method-functions + (,lambda-list .method-args. .next-methods. + :call-next-method-p ,call-next-method-p + :next-method-p-p ,next-method-p-p + :closurep ,closurep + :applyp ,applyp) + ,@walked-declarations + ,@walked-lambda-body)) + `(,@(when plist + `(:plist ,plist)) + ,@(when documentation + `(:documentation ,documentation))))))))))) + +(define-inline-function slot-value (instance slot-name) (form closure-p env) + :predicate (and (not closure-p) (constantp slot-name)) + :inline-arguments (required-parameters slots) + :inline (optimize-slot-value + slots + (can-optimize-access form required-parameters env) + form)) + +;collect information about: +; uses of the required-parameters +; uses of call-next-method and next-method-p: +; called-p +; apply-p +; arglist info +;optimize calls to slot-value, set-slot-value, slot-boundp +;optimize calls to find-class +;optimize generic-function calls +(defun make-walk-function (required-parameters info slots calls) + #'(lambda (form context env) + (cond ((not (eq context ':eval)) form) + ((not (listp form)) form) + ((eq (car form) 'call-next-method) + (setq call-next-method-p 't) + form) + ((eq (car form) 'next-method-p) + (setq next-method-p-p 't) + form) + ((and (eq (car form) 'function) + (cond ((eq (cadr form) 'call-next-method) + (setq call-next-method-p 't) + (setq closurep t) + form) + ((eq (cadr form) 'next-method-p) + (setq next-method-p-p 't) + (setq closurep t) + form) + (t nil)))) + ((and (or (eq (car form) 'slot-value) + (eq (car form) 'set-slot-value) + (eq (car form) 'slot-boundp)) + (constantp (caddr form))) + (let ((parameter + (can-optimize-access form + required-parameters env))) + (ecase (car form) + (slot-value + (optimize-slot-value slots parameter form)) + (set-slot-value + (optimize-set-slot-value slots parameter form)) + (slot-boundp + (optimize-slot-boundp slots parameter form))))) + ((and (or (symbolp (car form)) + (and (consp (car form)) + (eq (caar form) 'setf))) + (gboundp (car form)) + (if (eq *boot-state* 'complete) + (standard-generic-function-p (gdefinition (car form))) + (funcallable-instance-p (gdefinition (car form))))) + (optimize-generic-function-call + form required-parameters env slots calls)) + (t form)))) + +(defun walk-method-lambda (method-lambda required-parameters env slots calls) + (let* ((call-next-method-p nil) ;flag indicating that call-next-method + ;should be in the method definition + (closurep nil) ;flag indicating that #'call-next-method + ;was seen in the body of a method + (next-method-p-p nil) ;flag indicating that next-method-p + ;should be in the method definition + (walk-functions `((call-next-method-p + ,#'(lambda (form closure-p env) + (setq call-next-method-p 't) + (when closure-p + (setq closurep t)) + form)) + (next-method-p + ,#'(lambda (form closure-p env) + (setq next-method-p-p 't) + (when closure-p + (setq closurep t)) + form)) + ((slot-value set-slot-value slot-boundp) + ,#'(lambda (form closure-p env) + (if (and (not closure-p) + (constantp (caddr form))) + + (let ((walked-lambda (walk-form method-lambda env + (make-walk-function + `((call-next-method-p + ,#'(lambda (form closure-p env) + (setq call-next-method-p 't) + (when closure-p + (setq closurep t)) + form)) + (next-method-p + ,#'(lambda (form closure-p env) + (setq next-method-p-p 't) + (when closure-p + (setq closurep t)) + form)) + ((slot-value set-slot-value slot-boundp) + ,#'(lambda (form closure-p env) + ( + (values walked-lambda + call-next-method-p closurep next-method-p-p))))) + +(defun initialize-method-function (initargs &optional return-function-p method) + (let* ((mf (getf initargs ':function)) + (method-spec (getf initargs ':method-spec)) + (plist (getf initargs ':plist)) + (pv-table-symbol (getf plist ':pv-table-symbol)) + (pv-table nil) + (mff (getf initargs ':fast-function))) + (flet ((set-mf-property (p v) + (when mf + (setf (method-function-get mf p) v)) + (when mff + (setf (method-function-get mff p) v)))) + (when method-spec + (when mf + (setq mf (set-function-name mf method-spec))) + (when mff + (let ((name `(,(or (get (car method-spec) 'fast-sym) + (setf (get (car method-spec) 'fast-sym) + (intern (format nil "FAST-~A" + (car method-spec)) + *the-pcl-package*))) + ,@(cdr method-spec)))) + (set-function-name mff name) + (unless mf + (set-mf-property :name name))))) + (when plist + (let ((snl (getf plist :slot-name-lists)) + (cl (getf plist :call-list))) + (when (or snl cl) + (setq pv-table (intern-pv-table :slot-name-lists snl + :call-list cl)) + (when pv-table (set pv-table-symbol pv-table)) + (set-mf-property :pv-table pv-table))) + (loop (when (null plist) (return nil)) + (set-mf-property (pop plist) (pop plist))) + (when method + (set-mf-property :method method)) + (when return-function-p + (or mf (method-function-from-fast-function mff))))))) + + + diff --git a/pcl/misc-kcl-patches.text b/pcl/misc-kcl-patches.text new file mode 100644 index 000000000..54bb9c718 --- /dev/null +++ b/pcl/misc-kcl-patches.text @@ -0,0 +1,340 @@ +c/cmpaux.c +*** c/cmpaux.c Mon Jul 6 00:14:55 1992 +--- ../akcl-1-615/c/cmpaux.c Thu Jun 18 20:01:07 1992 +*************** +*** 229,239 **** + if (leng > 0 && leng < x->st.st_dim && x->st.st_self[leng]==0) + return x->st.st_self; + if (x->st.st_dim == leng + && ( leng % sizeof(object)) + ) +! { x->st.st_self[leng] = 0; + return x->st.st_self; + } + else + {char *res=malloc(leng+1); + bcopy(x->st.st_self,res,leng); +--- 229,240 ---- + if (leng > 0 && leng < x->st.st_dim && x->st.st_self[leng]==0) + return x->st.st_self; + if (x->st.st_dim == leng + && ( leng % sizeof(object)) + ) +! { if(x->st.st_self[leng] != 0) +! x->st.st_self[leng] = 0; + return x->st.st_self; + } + else + {char *res=malloc(leng+1); + bcopy(x->st.st_self,res,leng); +c/main.c +*** c/main.c Mon Jul 6 00:14:59 1992 +--- ../akcl-1-615/c/main.c Fri Jul 3 02:19:37 1992 +*************** +*** 611,621 **** + {catch_fatal = -1; + if (sgc_enabled) + { sgc_quit();} + if (sgc_enabled==0) + { install_segmentation_catcher() ;} +! FEerror("Caught fatal error [memory may be damaged]"); } + printf("\nUnrecoverable error: %s.\n", s); + fflush(stdout); + #ifdef UNIX + abort(); + #endif +--- 611,621 ---- + {catch_fatal = -1; + if (sgc_enabled) + { sgc_quit();} + if (sgc_enabled==0) + { install_segmentation_catcher() ;} +! FEerror("Caught fatal error [memory may be damaged] ~A",1,make_simple_string(s)); } + printf("\nUnrecoverable error: %s.\n", s); + fflush(stdout); + #ifdef UNIX + abort(); + #endif +*************** +*** 853,872 **** + + siLsave_system() + { + int i; + +- #ifdef HAVE_YP_UNBIND +- extern object truename(),namestring(); + check_arg(1); +! /* prevent subsequent consultation of yp by getting +! truename now*/ +! vs_base[0]=namestring(truename(vs_base[0])); +! {char name[200]; +! char *dom = name; +! if (0== getdomainname(dom,sizeof(name))) +! yp_unbind(dom);} + #endif + + saving_system = TRUE; + GBC(t_contiguous); + +--- 853,867 ---- + + siLsave_system() + { + int i; + + check_arg(1); +! #ifdef HAVE_YP_UNBIND +! /* see unixsave.c */ +! {char *dname; +! yp_get_default_domain(&dname);} + #endif + + saving_system = TRUE; + GBC(t_contiguous); + +c/num_log.c +*** c/num_log.c Mon Jul 6 00:15:00 1992 +--- ../akcl-1-615/c/num_log.c Mon Jun 15 21:15:59 1992 +*************** +*** 266,286 **** + return(~j); + } + + int + big_bitp(x, p) +! object x; +! int p; + { GEN u = MP(x); + int ans ; + int i = p /32; + if (signe(u) < 0) + { save_avma; + u = complementi(u); + restore_avma; + } +! if (i < lgef(u)) + { ans = ((MP_ITH_WORD(u,i,lgef(u))) & (1 << p%32));} + else if (big_sign(x) < 0) ans = 1; + else ans = 0; + return ans; + } +--- 266,286 ---- + return(~j); + } + + int + big_bitp(x, p) +! object x; +! int p; + { GEN u = MP(x); + int ans ; + int i = p /32; + if (signe(u) < 0) + { save_avma; + u = complementi(u); + restore_avma; + } +! if (i < lgef(u) -MP_CODE_WORDS) + { ans = ((MP_ITH_WORD(u,i,lgef(u))) & (1 << p%32));} + else if (big_sign(x) < 0) ans = 1; + else ans = 0; + return ans; + } +c/unixsave.c +*** c/unixsave.c Mon Jul 6 00:15:07 1992 +--- ../akcl-1-615/c/unixsave.c Fri Jul 3 02:52:36 1992 +*************** +*** 71,81 **** +--- 71,160 ---- + break; + } else + break; + } + ++ #include "page.h" + ++ /* string is aligned on a word boundary */ ++ int ++ find_string_in_memory(string,length,other_p,function) ++ char *string; ++ int length,other_p; ++ int *function(); ++ { ++ int *imem_first,*imem_last,*imem,word; ++ char *mem; ++ int len,page_first,page_last,i; ++ int maxpage = page(heap_end); ++ if(((int)string & 3) == 0 && length >= 4) /* just to be safe */ ++ {word=*(int *)string; ++ for (page_first = 0; page_first < maxpage; page_first++) ++ if ((enum type)type_map[page_first] != t_other) ++ break; ++ for (; page_first < maxpage; page_first++) ++ if (((enum type)type_map[page_first] == t_other)?other_p:!other_p) ++ {for (page_last = page_first+1; page_last < maxpage; page_last++) ++ if ( !(((enum type)type_map[page_last] == t_other)?other_p:!other_p) ) ++ break; ++ imem_first=(int *)pagetochar(page_first); ++ imem_last=(int *)( ( ((int)pagetochar(page_last)) - length) &~3 ); ++ for (imem = imem_first; imem <= imem_last; imem++) ++ if (*imem == word) ++ {mem=(char *)imem; ++ for(i=4; i<length && mem[i]==string[i]; i++); ++ if(i>=length) ++ if((*function)(mem)) ++ return TRUE;}}} ++ return FALSE; ++ } ++ ++ int ++ fsim_first(address) ++ char *address; ++ { ++ return TRUE; ++ } ++ ++ int ++ fsim_reset_pointer(address) ++ char **address; ++ { ++ *address = NULL; ++ return FALSE; ++ } ++ ++ #define t_other_PAGES TRUE ++ #define NOT_t_other_PAGES FALSE ++ ++ int ++ reset_other_pointers(address) ++ char *address; ++ { ++ int word=(int)address; ++ find_string_in_memory(&word,4,t_other_PAGES,fsim_reset_pointer); ++ } ++ ++ int ++ maybe_reset_pointers(address) ++ char *address; ++ { ++ int word=(int)address; ++ if(!find_string_in_memory(&word,4,NOT_t_other_PAGES,fsim_first)) ++ reset_other_pointers(address); ++ return FALSE; ++ } ++ ++ reset_other_pointers_to_string(string) ++ char *string; ++ { ++ int length=strlen(string)+1; ++ find_string_in_memory(string,length,t_other_PAGES,maybe_reset_pointers); ++ } ++ ++ bool saving_system; ++ + memory_save(original_file, save_file) + char *original_file, *save_file; + { MEM_SAVE_LOCALS; + char *data_begin, *data_end; + int original_data; +*************** +*** 100,110 **** +--- 179,206 ---- + n = open(save_file, O_CREAT|O_WRONLY, 0777); + if (n != 1 || (save = fdopen(n, "w")) != stdout) { + fprintf(stderr, "Can't open the save file.\n"); + exit(1); + } ++ + setbuf(save, stdout_buf); ++ ++ #ifdef HAVE_YP_UNBIND ++ /* yp_get_default_domain() caches the result of getdomainname() in ++ a malloc'ed block of memory; and gethostbyname saves the result of ++ yp_get_default_domain() in yet another chunk of memory. These ++ cached values will cause problems if the saved image is run on a ++ machine having a different local domainname. [When getdomainname ++ is called (by CLX, for example) KCL will wait forever.] There doesn't ++ seem to be any way to uncache these things (apparently yp_unbind does ++ not do this), nor any good way to find these blocks of memory. */ ++ ++ if(saving_system) ++ {char *dname; ++ yp_get_default_domain(&dname); ++ reset_other_pointers(dname);} ++ #endif + + READ_HEADER; + FILECPY_HEADER; + + for (n = header.a_data, p = data_begin; ; n -= BUFSIZ, p += BUFSIZ) +cmpnew/cmpcall.lsp +*** cmpnew/cmpcall.lsp Mon Jul 6 00:15:13 1992 +--- ../akcl-1-615/cmpnew/cmpcall.lsp Thu Jun 18 21:43:24 1992 +*************** +*** 118,127 **** +--- 118,128 ---- + ;;; responsible for maintaining this condition. + (let ((*vs* *vs*) (form (caddr funob))) + (declare (object form)) + (cond ((and (listp args) + *use-sfuncall* ++ (<= (length (cdr args)) 10) + ;;Determine if only one value at most is required: + (or + (eq *value-to-go* 'trash) + (and (consp *value-to-go*) + (eq (car *value-to-go*) 'var)) +lsp/autoload.lsp +*** lsp/autoload.lsp Mon Jul 6 00:15:27 1992 +--- ../akcl-1-615/lsp/autoload.lsp Tue Jun 16 02:36:45 1992 +*************** +*** 430,440 **** + '(cons + fixnum bignum ratio short-float long-float complex + character symbol package hash-table + array vector string bit-vector + structure stream random-state readtable pathname +! cfun cclosure sfun gfun cfdata spice fat-string )) + + (defun room (&optional x) + (let ((l (multiple-value-list (si:room-report))) + maxpage leftpage ncbpage maxcbpage ncb cbgbccount npage + rbused rbfree nrbpage +--- 430,440 ---- + '(cons + fixnum bignum ratio short-float long-float complex + character symbol package hash-table + array vector string bit-vector + structure stream random-state readtable pathname +! cfun cclosure sfun gfun vfun cfdata spice fat-string dclosure)) + + (defun room (&optional x) + (let ((l (multiple-value-list (si:room-report))) + maxpage leftpage ncbpage maxcbpage ncb cbgbccount npage + rbused rbfree nrbpage +lsp/cmpinit.lsp +*** lsp/cmpinit.lsp Mon Jul 6 00:15:28 1992 +--- ../akcl-1-615/lsp/cmpinit.lsp Mon Jun 22 17:11:11 1992 +*************** +*** 4,12 **** + (setq compiler::*eval-when-defaults* '(compile eval load)) + (or (fboundp 'si::get-&environment) (load "defmacro.lsp")) + ;(or (get 'si::s-data 'si::s-data) + ; (progn (load "../lsp/setf.lsp") (load "../lsp/defstruct.lsp"))) + (if (probe-file "sys-proclaim.lisp")(load "sys-proclaim.lisp")) +! +! + + ;;;;; +--- 4,13 ---- + (setq compiler::*eval-when-defaults* '(compile eval load)) + (or (fboundp 'si::get-&environment) (load "defmacro.lsp")) + ;(or (get 'si::s-data 'si::s-data) + ; (progn (load "../lsp/setf.lsp") (load "../lsp/defstruct.lsp"))) + (if (probe-file "sys-proclaim.lisp")(load "sys-proclaim.lisp")) +! (unless (get 'si::basic-wrapper 'si::s-data) +! (setf (get 'si::s-data 'si::s-data) nil) +! (load "../lsp/defstruct.lsp")) + + ;;;;; diff --git a/pcl/new-kcl-wrapper.text b/pcl/new-kcl-wrapper.text new file mode 100644 index 000000000..7f161a6c5 --- /dev/null +++ b/pcl/new-kcl-wrapper.text @@ -0,0 +1,2157 @@ +The new-kcl-wrapper modifications make the storage of standard-objects +and structure objects much more similar than before. These changes should +greatly speed up WRAPPER-OF for structure objects and should speed up +WRAPPER-OF for standard-instances also (but not funcallable instances). + +Look first at the defstructs defined here (scan this file for "(defstruct ("). +Then look at cache.lisp, at the "#+structure-wrapper" for the new definition of +the wrapper structure. Finally, look in low.lisp, at the +"#+new-structure-wrapper" for the definition of %allocate-instance--class. + +You need to have akcl-1-615 to use this file. + +This file contains new versions of the files V/c/structure.c and +V/lsp/defstruct.lsp, as well as small changes to the files c/gbc.c, c/sgbc.c, +cmpnew/cmpinit.lsp, lsp/cmpinit.lsp, and lsp/describe.lsp. + +-- The gbc changes allow the garbage collector to work correctly even when +structures which define other structures (ones which can be the value of +STRUCTURE-DEF) are not allocated in static storage. + + +c/gbc.c +*** c/gbc.c Tue Jun 30 04:11:00 1992 +--- ../akcl-1-615/c/gbc.c Tue Jun 30 02:48:04 1992 +*************** +*** 427,453 **** + break; + goto COPY_STRING; + + case t_structure: + mark_object(x->str.str_def); + p = x->str.str_self; + if (p == NULL) +! break; +! {object def=x->str.str_def; +! unsigned char * s_type = &SLOT_TYPE(def,0); +! unsigned short *s_pos= & SLOT_POS(def,0); +! for (i = 0, j = S_DATA(def)->length; i < j; i++) + if (s_type[i]==0) mark_object(STREF(object,x,s_pos[i])); + if ((int)what_to_collect >= (int)t_contiguous) { + if (inheap(x->str.str_self)) { + if (what_to_collect == t_contiguous) + mark_contblock((char *)p, +! S_DATA(def)->size); + + } else +! x->str.str_self = (object *) +! copy_relblock((char *)p, S_DATA(def)->size); + }} + break; + + case t_stream: + switch (x->sm.sm_mode) { +--- 427,461 ---- + break; + goto COPY_STRING; + + case t_structure: ++ x->d.m = 2; + mark_object(x->str.str_def); + p = x->str.str_self; + if (p == NULL) +! {x->d.m = TRUE; break;} +! {object def=x->str.str_def; +! struct s_data *sdef=S_DATA(def); +! unsigned char *s_type; +! unsigned short *s_pos; +! if((int)what_to_collect >= (int)t_contiguous && +! !inheap(sdef) && def->d.m==TRUE) +! sdef=(struct s_data *)(((char *)sdef)+(rb_start1-rb_start)); +! s_type = sdef->raw->ust.ust_self; +! s_pos = &USHORT(sdef->slot_position,0); +! for (i = 0, j = sdef->length; i < j; i++) + if (s_type[i]==0) mark_object(STREF(object,x,s_pos[i])); + if ((int)what_to_collect >= (int)t_contiguous) { + if (inheap(x->str.str_self)) { + if (what_to_collect == t_contiguous) + mark_contblock((char *)p, +! sdef->size); + + } else +! x->str.str_self = (object *) +! copy_relblock((char *)p, sdef->size); + }} ++ x->d.m = TRUE; + break; + + case t_stream: + switch (x->sm.sm_mode) { +*** c/sgbc.c Mon Jun 15 21:16:01 1992 +--- akcl-1-615/c/sgbc.c Wed Jul 1 18:37:24 1992 +*************** +*** 355,386 **** + if (cp == NULL) + break; + goto COPY_STRING; + + case t_structure: + sgc_mark_object(x->str.str_def); + p = x->str.str_self; + if (p == NULL) +! break; +! {object def=x->str.str_def; +! unsigned char * s_type = &SLOT_TYPE(def,0); +! unsigned short *s_pos= & SLOT_POS(def,0); +! for (i = 0, j = S_DATA(def)->length; i < j; i++) + if (s_type[i]==0 && + ON_WRITABLE_PAGE(& STREF(object,x,s_pos[i])) + ) + sgc_mark_object(STREF(object,x,s_pos[i])); + if ((int)what_to_collect >= (int)t_contiguous) { + if (inheap(x->str.str_self)) { + if (what_to_collect == t_contiguous) + mark_contblock((char *)p, +! S_DATA(def)->size); + + } else if(SGC_RELBLOCK_P(p)) + x->str.str_self = (object *) +! copy_relblock((char *)p, S_DATA(def)->size); + }} + break; + + case t_stream: + switch (x->sm.sm_mode) { + case smm_input: +--- 355,394 ---- + if (cp == NULL) + break; + goto COPY_STRING; + + case t_structure: ++ x->d.m = 2; + sgc_mark_object(x->str.str_def); + p = x->str.str_self; + if (p == NULL) +! {x->d.m = TRUE; break;} +! {object def=x->str.str_def; +! struct s_data *sdef=S_DATA(def); +! unsigned char *s_type; +! unsigned short *s_pos; +! if((int)what_to_collect >= (int)t_contiguous && +! !inheap(sdef) && def->d.m==TRUE) +! sdef=(struct s_data *)(((char *)sdef)+(rb_start1-rb_start)); +! s_type = sdef->raw->ust.ust_self; +! s_pos = &USHORT(sdef->slot_position,0); +! for (i = 0, j = sdef->length; i < j; i++) + if (s_type[i]==0 && + ON_WRITABLE_PAGE(& STREF(object,x,s_pos[i])) + ) + sgc_mark_object(STREF(object,x,s_pos[i])); + if ((int)what_to_collect >= (int)t_contiguous) { + if (inheap(x->str.str_self)) { + if (what_to_collect == t_contiguous) + mark_contblock((char *)p, +! sdef->size); + + } else if(SGC_RELBLOCK_P(p)) + x->str.str_self = (object *) +! copy_relblock((char *)p, sdef->size); + }} ++ x->d.m = TRUE; + break; + + case t_stream: + switch (x->sm.sm_mode) { + case smm_input: +cmpnew/cmpinit.lsp +*** cmpnew/cmpinit.lsp Tue Jun 30 04:11:13 1992 +--- ../akcl-1-615/cmpnew/cmpinit.lsp Mon Jun 22 18:41:51 1992 +*************** +*** 4,7 **** +--- 4,10 ---- + (load "sys-proclaim.lisp") + (setq compiler::*eval-when-defaults* '(compile eval load)) + + ;(dolist (v '( cmpeval cmpopt cmptype cmpbind cmpinline cmploc cmpvar cmptop cmplet cmpcall cmpmulti cmplam cmplabel cmpeval)) (load (format nil "~(~a~).lsp" v))) ++ (unless (get 'si::basic-wrapper 'si::s-data) ++ (setf (get 'si::s-data 'si::s-data) nil) ++ (load "../lsp/defstruct.lsp")) +lsp/cmpinit.lsp +*** lsp/cmpinit.lsp Tue Jun 30 04:11:26 1992 +--- ../akcl-1-615/lsp/cmpinit.lsp Mon Jun 22 17:11:11 1992 +*************** +*** 5,12 **** + (or (fboundp 'si::get-&environment) (load "defmacro.lsp")) + ;(or (get 'si::s-data 'si::s-data) + ; (progn (load "../lsp/setf.lsp") (load "../lsp/defstruct.lsp"))) + (if (probe-file "sys-proclaim.lisp")(load "sys-proclaim.lisp")) +! +! + + ;;;;; +--- 5,13 ---- + (or (fboundp 'si::get-&environment) (load "defmacro.lsp")) + ;(or (get 'si::s-data 'si::s-data) + ; (progn (load "../lsp/setf.lsp") (load "../lsp/defstruct.lsp"))) + (if (probe-file "sys-proclaim.lisp")(load "sys-proclaim.lisp")) +! (unless (get 'si::basic-wrapper 'si::s-data) +! (setf (get 'si::s-data 'si::s-data) nil) +! (load "../lsp/defstruct.lsp")) + + ;;;;; +lsp/describe.lsp +*** lsp/describe.lsp Tue Jun 30 04:11:27 1992 +--- ../akcl-1-615/lsp/describe.lsp Tue Jun 23 16:39:07 1992 +*************** +*** 266,282 **** + + (defun inspect-structure (x &aux name) + (format t "Structure of type ~a ~%Byte:[Slot Type]Slot Name :Slot Value" + (setq name (type-of x))) +! (let* ((sd (get name 'si::s-data)) + (spos (s-data-slot-position sd))) + (dolist (v (s-data-slot-descriptions sd)) + (format t "~%~4d:~@[[~s] ~]~20a:~s" +! (aref spos (nth 4 v)) +! (let ((type (nth 2 v))) + (if (eq t type) nil type)) +! (car v) +! (structure-ref1 x (nth 4 v)))))) + + + (defun inspect-object (object &aux (*inspect-level* *inspect-level*)) + (inspect-indent) +--- 266,282 ---- + + (defun inspect-structure (x &aux name) + (format t "Structure of type ~a ~%Byte:[Slot Type]Slot Name :Slot Value" + (setq name (type-of x))) +! (let* ((sd (structure-def x)) + (spos (s-data-slot-position sd))) + (dolist (v (s-data-slot-descriptions sd)) + (format t "~%~4d:~@[[~s] ~]~20a:~s" +! (aref spos (slot-offset v)) +! (let ((type (slot-type v))) + (if (eq t type) nil type)) +! (slot-name v) +! (structure-ref1 x (slot-offset v)))))) + + + (defun inspect-object (object &aux (*inspect-level* *inspect-level*)) + (inspect-indent) +============================================================================== +=============================== c/structure.c ================================ +Changes file for /kcl/c/structure.c +Usage \n@s[Original text\n@s|Replacement Text\n@s] +See the file rascal.ics.utexas.edu:/usr2/ftp/merge.c +for a program to merge change files. Anything not between + "\n@s[" and "\n@s]" is a simply a comment. +This file was constructed using emacs and merge.el + by (Bill Schelter) wfs@carl.ma.utexas.edu + + +****Change:(orig (15 17 d)) +@s[object siSstructure_print_function; +object siSstructure_slot_descriptions; +object siSstructure_include; + +@s| +@s] + + +****Change:(orig (18 18 a)) +@s[ + +@s| +#define COERCE_DEF(x) if (type_of(x)==t_symbol) \ + x=getf(x->s.s_plist,siLs_data,Cnil) + +#define check_type_structure(x) \ + if(type_of((x))!=t_structure) \ + FEwrong_type_argument(Sstructure,(x)) + + + +@s] + + +****Change:(orig (22 31 c)) +@s[{ + do { + if (type_of(x) != t_symbol) + return(FALSE); + +@s, } while (x != Cnil); + return(FALSE); +} + +@s|{ if (x==y) return 1; + if (type_of(x)!= t_structure + || type_of(y)!=t_structure) + FEerror("bad call to structure_subtypep",0); + {if (S_DATA(y)->included == Cnil) return 0; + while ((x=S_DATA(x)->includes) != Cnil) + { if (x==y) return 1;} + return 0; + }} + +@s] + + +****Change:(orig (32 32 a)) +@s[ + +@s| +static +bad_raw_type() +{ FEerror("Bad raw struct type",0);} + + + +@s] + + +****Change:(orig (34 34 c)) +@s[structure_ref(x, name, n) + +@s|structure_ref(x, name, i) + +@s] + + +****Change:(orig (36 38 c)) +@s[object x, name; +int n; +{ + int i; + +@s|object x, name; +int i; +{unsigned short *s_pos; + COERCE_DEF(name); + if (type_of(x) != t_structure || + (type_of(name)!=t_structure) || + !structure_subtypep(x->str.str_def, name)) + FEwrong_type_argument((type_of(name)==t_structure ? + S_DATA(name)->name : name), + x); + s_pos = &SLOT_POS(x->str.str_def,0); + switch((SLOT_TYPE(x->str.str_def,i))) + { + case aet_object: return(STREF(object,x,s_pos[i])); + case aet_fix: return(make_fixnum((STREF(int,x,s_pos[i])))); + case aet_ch: return(code_char(STREF(char,x,s_pos[i]))); + case aet_bit: + case aet_char: return(make_fixnum(STREF(char,x,s_pos[i]))); + case aet_sf: return(make_shortfloat(STREF(shortfloat,x,s_pos[i]))); + case aet_lf: return(make_longfloat(STREF(longfloat,x,s_pos[i]))); + case aet_uchar: return(make_fixnum(STREF(unsigned char,x,s_pos[i]))); + case aet_ushort: return(make_fixnum(STREF(unsigned short,x,s_pos[i]))); + case aet_short: return(make_fixnum(STREF(short,x,s_pos[i]))); + default: + bad_raw_type(); + return 0; + }} + +@s] + + +****Change:(orig (40 43 c)) +@s[ if (type_of(x) != t_structure || + !structure_subtypep(x->str.str_name, name)) + FEwrong_type_argument(name, x); + return(x->str.str_self[n]); + +@s| +void +siLstructure_ref1() +{object x=vs_base[0]; + int n=fix(vs_base[1]); + object def; + check_type_structure(x); + def=x->str.str_def; + if(n>= S_DATA(def)->length) + FEerror("Structure ref out of bounds",0); + vs_base[0]=structure_ref(x,x->str.str_def,n); + vs_top=vs_base+1; + +@s] + + +****Change:(orig (45 45 a)) +@s[} + + +@s|} + +void +siLstructure_set1() +{object x=vs_base[0]; + int n=fix(vs_base[1]); + object v=vs_base[2]; + object def; + check_type_structure(x); + def=x->str.str_def; + if(n>= S_DATA(def)->length) + FEerror("Structure ref out of bounds",0); + vs_base[0]=structure_set(x,x->str.str_def,n,v); + vs_top=vs_base+1; +} + + + +@s] + + +****Change:(orig (47 47 c)) +@s[structure_set(x, name, n, v) + +@s|structure_set(x, name, i, v) + +@s] + + +****Change:(orig (49 51 c)) +@s[object x, name, v; +int n; +{ + int i; + +@s|object x, name, v; +int i; +{unsigned short *s_pos; + + COERCE_DEF(name); + if (type_of(x) != t_structure || + type_of(name) != t_structure || + !structure_subtypep(x->str.str_def, name)) + FEwrong_type_argument((type_of(name)==t_structure ? + S_DATA(name)->name : name) + , x); + +@s] + + +****Change:(orig (53 57 c)) +@s[ if (type_of(x) != t_structure || + !structure_subtypep(x->str.str_name, name)) + FEwrong_type_argument(name, x); + x->str.str_self[n] = v; + +@s, return(v); + +@s|#ifdef SGC + /* make sure the structure header is on a writable page */ + if (x->d.m) FEerror("bad gc field",0); else x->d.m = 0; +#endif + + s_pos= & SLOT_POS(x->str.str_def,0); + switch(SLOT_TYPE(x->str.str_def,i)){ + + case aet_object: STREF(object,x,s_pos[i])=v; break; + case aet_fix: (STREF(int,x,s_pos[i]))=fix(v); break; + case aet_ch: STREF(char,x,s_pos[i])=char_code(v); break; + case aet_bit: + case aet_char: STREF(char,x,s_pos[i])=fix(v); break; + case aet_sf: STREF(shortfloat,x,s_pos[i])=sf(v); break; + case aet_lf: STREF(longfloat,x,s_pos[i])=lf(v); break; + case aet_uchar: STREF(unsigned char,x,s_pos[i])=fix(v); break; + case aet_ushort: STREF(unsigned short,x,s_pos[i])=fix(v); break; + case aet_short: STREF(short,x,s_pos[i])=fix(v); break; + default: + bad_raw_type(); + + } + return(v); + +@s] + + +****Change:(orig (59 59 a)) +@s[} + + +@s|} + +void +siLstructure_subtype_p() +{object x,y; + check_arg(2); + x=vs_base[0]; + y=vs_base[1]; + if (type_of(x)!=t_structure) + {vs_base[0]=Cnil; goto BOTTOM;} + x=x->str.str_def; + COERCE_DEF(y); + if (structure_subtypep(x,y)) vs_base[0]=Ct; + else vs_base[0]=Cnil; + BOTTOM: + vs_top=vs_base+1; +} + +static object +slot_name(x) + object x; +{ + if(type_of(x)==t_cons) + return car(x); + if(type_of(x)==t_structure) + return x->str.str_self[0]; + return Cnil; +} + + +@s] + + +****Change:(orig (64 64 a)) +@s[object x; +{ + object *p, s; + +@s|object x; +{ + object *p, s; + struct s_data *def=S_DATA(x->str.str_def); + +@s] + + +****Change:(orig (66 69 c)) +@s[ + s = getf(x->str.str_name->s.s_plist, + siSstructure_slot_descriptions, Cnil); + vs_push(x->str.str_name); + +@s| + s = def->slot_descriptions; + vs_push(def->name); + +@s] + + +****Change:(orig (72 73 c)) +@s[ for (i=0, n=x->str.str_length; !endp(s)&&i<n; s=s->c.c_cdr, i++) { + *p = make_cons(car(s->c.c_car), Cnil); + +@s| for (i=0, n=def->length; !endp(s)&&i<n; s=s->c.c_cdr, i++) { + *p = make_cons(slot_name(s->c.c_car), Cnil); + +@s] + + +****Change:(orig (75 75 c)) +@s[ *p = make_cons(x->str.str_self[i], Cnil); + +@s| *p = make_cons(structure_ref(x,x->str.str_def,i), Cnil); + +@s] + + +****Change:(orig (81 81 a)) +@s[ stack_cons(); + return(vs_pop); +} + + +@s| stack_cons(); + return(vs_pop); +} + +void + +@s] + + +****Change:(orig (84 85 c)) +@s[ object x; + int narg, i; + +@s| object x,name,*base; + struct s_data *def; + int narg, i,size; + base=vs_base; + if ((narg = vs_top - base) == 0) + too_few_arguments(); + x = alloc_object(t_structure); + name=base[0]; + COERCE_DEF(name); + if (type_of(name)!=t_structure || + (def=S_DATA(name))->length != --narg) + FEerror("Bad make_structure args for type ~a",1, + base[0]); + x->str.str_def = name; + x->str.str_self = NULL; + size=S_DATA(name)->size; + base[0] = x; + x->str.str_self = (object *) + (def->staticp == Cnil ? alloc_relblock(size) + : alloc_contblock(size)); + /* There may be holes in the structure. + We want them zero, so that equal can work better. + */ + if (S_DATA(name)->has_holes != Cnil) + bzero(x->str.str_self,size); + {unsigned char *s_type; + unsigned short *s_pos; + s_pos= (&SLOT_POS(x->str.str_def,0)); + s_type = (&(SLOT_TYPE(x->str.str_def,0))); + base=base+1; + for (i = 0; i < narg; i++) + {object v=base[i]; + switch(s_type[i]){ + + case aet_object: STREF(object,x,s_pos[i])=v; break; + case aet_fix: (STREF(int,x,s_pos[i]))=fix(v); break; + case aet_ch: STREF(char,x,s_pos[i])=char_code(v); break; + case aet_bit: + case aet_char: STREF(char,x,s_pos[i])=fix(v); break; + case aet_sf: STREF(shortfloat,x,s_pos[i])=sf(v); break; + case aet_lf: STREF(longfloat,x,s_pos[i])=lf(v); break; + case aet_uchar: STREF(unsigned char,x,s_pos[i])=fix(v); break; + case aet_ushort: STREF(unsigned short,x,s_pos[i])=fix(v); break; + case aet_short: STREF(short,x,s_pos[i])=fix(v); break; + default: + bad_raw_type(); + +@s] + + +****Change:(orig (87 97 c)) +@s[ if ((narg = vs_top - vs_base) == 0) + too_few_arguments(); + x = alloc_object(t_structure); + x->str.str_name = vs_base[0]; + +@s, x->str.str_self[i] = vs_top[i]; + +@s| }} + vs_top = base; + vs_base=base-1; + + } + +@s] + + +****Change:(orig (99 99 a)) +@s[} + + +@s|} + +void + +@s] + + +****Change:(orig (103 103 c)) +@s[ object x, y; + int i, j; + +@s| object x, y; + struct s_data *def; + +@s] + + +****Change:(orig (105 105 c)) +@s[ + check_arg(2); + +@s| + if (vs_top-vs_base < 1) too_few_arguments(); + +@s] + + +****Change:(orig (107 110 c)) +@s[ if (type_of(x) != t_structure || x->str.str_name != vs_base[1]) + FEwrong_type_argument(vs_base[1], x); + vs_base[1] = y = alloc_object(t_structure); + y->str.str_name = x->str.str_name; + +@s| check_type_structure(x); + vs_base[0] = y = alloc_object(t_structure); + def=S_DATA(y->str.str_def = x->str.str_def); + +@s] + + +****Change:(orig (112 116 c)) +@s[ y->str.str_length = j = x->str.str_length; + y->str.str_self = (object *)alloc_relblock(sizeof(object)*j); + for (i = 0; i < j; i++) + y->str.str_self[i] = x->str.str_self[i]; + +@s, vs_base++; + +@s| y->str.str_self = (object *)alloc_relblock(def->size); + bcopy(x->str.str_self,y->str.str_self,def->size); + vs_top=vs_base+1; + +@s] + + +****Change:(orig (118 118 a)) +@s[} + + +@s|} + +void +siLcopy_structure_header() +{ + object x, y; + + if (vs_top-vs_base < 1) too_few_arguments(); + x = vs_base[0]; + check_type_structure(x); + vs_base[0] = y = alloc_object(t_structure); + y->str.str_def = x->str.str_def; + y->str.str_self = x->str.str_self; + vs_top=vs_base+1; +} + + +void + +@s] + + +****Change:(orig (122 124 c)) +@s[ if (type_of(vs_base[0]) != t_structure) + FEwrong_type_argument(Sstructure, vs_base[0]); + vs_base[0] = vs_base[0]->str.str_name; + +@s| check_type_structure(vs_base[0]); + vs_base[0] = S_DATA(vs_base[0]->str.str_def)->name; + +@s] + + +****Change:(orig (127 127 c)) +@s[} + +siLstructure_ref() + +@s|} + +#define FIND_SLOT(str,name) ((type_of(name)==t_fixnum)?fix(name): \ + structure_slot_position(str,name)) + +object +structure_ref_new(x, name, i) + object x,name,i; + +@s] + + +****Change:(orig (129 131 c)) +@s[ object x; + int i; + check_arg(3); + +@s| return structure_ref(x,name,FIND_SLOT(x,i)); +} + +@s] + + +****Change:(orig (133 144 c)) +@s[ x = vs_base[0]; + if (type_of(x) != t_structure || + !structure_subtypep(x->str.str_name, vs_base[1])) + FEwrong_type_argument(vs_base[1], x); + +@s, vs_base[0] = x->str.str_self[i]; + vs_top = vs_base+1; + +@s|object +structure_set_new(x, name, i, v) + object x,name,i,v; +{ + return structure_set(x,name,FIND_SLOT(x,i),v); + +@s] + + +****Change:(orig (146 146 a)) +@s[} + + +@s|} + +void +siLstructure_ref() +{ + check_arg(3); + vs_base[0]=structure_ref_new(vs_base[0],vs_base[1],vs_base[2]); + vs_top=vs_base+1; +} + +void + +@s] + + +****Change:(orig (149 150 d)) +@s[siLstructure_set() +{ + object x; + int i; + +@s|siLstructure_set() +{ + +@s] + + +****Change:(orig (152 163 c)) +@s[ + x = vs_base[0]; + if (type_of(x) != t_structure || + !structure_subtypep(x->str.str_name, vs_base[1])) + +@s, x->str.str_self[i] = vs_base[3]; + +@s| structure_set_new(vs_base[0],vs_base[1],vs_base[2],vs_base[3]); + +@s] + + +****Change:(orig (166 166 a)) +@s[ vs_base = vs_top-1; +} + + +@s| vs_base = vs_top-1; +} + +void + +@s] + + +****Change:(orig (228 228 c)) +@s[init_structure_function() + +@s|void +siLmake_s_data_structure() +{object x,y,raw,*base; + int i; + check_arg(5); + x=vs_base[0]; + base=vs_base; + raw=vs_base[1]; + y=alloc_object(t_structure); + y->str.str_def=y; + y->str.str_self = (object *)( x->v.v_self); + S_DATA(y)->name =siLs_data; + S_DATA(y)->length=(raw->v.v_dim); + S_DATA(y)->raw =raw; + for(i=3; i<raw->v.v_dim; i++) + y->str.str_self[i]=Cnil; + S_DATA(y)->slot_position=base[2]; + S_DATA(y)->slot_descriptions=base[3]; + S_DATA(y)->staticp=base[4]; + S_DATA(y)->size = (raw->v.v_dim)*sizeof(object); + vs_base[0]=y; + vs_top=vs_base+1; +} + +object siSstructure_init,siSstructure_init_named; +object siSname,siSdefault_init; +object siSraw,siSslot_position,siSsize,siSstaticp,siSslot_descriptions; + +static object +slot_value(str,name) + object str,name; + +@s] + + +****Change:(orig (230 237 c)) +@s[ siSstructure_print_function + = make_si_ordinary("STRUCTURE-PRINT-FUNCTION"); + enter_mark_origin(&siSstructure_print_function); + siSstructure_slot_descriptions + +@s, enter_mark_origin(&siSstructure_include); + +@s| top: + if(type_of(str)==t_structure) + return structure_ref_new(str,str->str.str_def,name); + if(str->c.c_car==siSstructure_init_named) + {object new=get(str->c.c_cdr,siLs_data); + str->c.c_car=siSstructure_init; + str->c.c_cdr=(type_of(new)==t_structure)?new:cdr(new);} + if(siSstructure_init!=car(str)) + FEerror("Illegal call to SI:MAKE-STRUCTURES 1",0); + {object key=intern(coerce_to_string(name),keyword_package); + object value=getf(cdddr(str),key,NULL); + if(value!=NULL) + return value; + else + {object slots; + if(str==caddr(str)&&name==siSslot_descriptions) + FEerror("Illegal call to SI:MAKE-STRUCTURES 2",0); + slots=slot_value(caddr(str),siSslot_descriptions); + for(;!endp(slots);slots=cdr(slots)) + if(name==slot_value(car(slots),siSname)) + {object result,form=slot_value(car(slots),siSdefault_init); + object *old_vs_base=vs_base,*old_vs_top=vs_top; + vs_base=vs_top;vs_push(form);Leval();result=vs_base[0]; + vs_base=old_vs_base; vs_top=old_vs_top; + return result;} + FEerror("Illegal call to SI:MAKE-STRUCTURES 3",0);}} + return Cnil; +} + +@s] + + +****Change:(orig (238 238 a)) +@s[ + +@s| +int +structure_slot_position(str,name) + object str,name; +{ + if(type_of(name)==t_fixnum) + return fix(name); + else + {object slotd_list; + int pos; + check_type_structure(str); + slotd_list=S_DATA(str->str.str_def)->slot_descriptions; + for(pos=0; type_of(slotd_list)==t_cons; pos++,slotd_list=cdr(slotd_list)) + {object slotd=car(slotd_list); + if(name==((type_of(slotd)==t_structure)? + slotd->str.str_self[0]:slot_value(slotd,siSname))) + return pos;} + FEerror("Slot ~S not found in structure ~S",2,name,str); + return 0;} +} + +static object +make_structures_internal(value) + object value; +{ + object str,def; + int def_index,i,ind; + + switch(type_of(value)) + {case t_cons: + if(value->c.c_car==siSstructure_init_named) + {object new=get(value->c.c_cdr,siLs_data); + value->c.c_car=siSstructure_init; + value->c.c_cdr=(type_of(new)==t_structure)?new:cdr(new);} + if(car(value)!=siSstructure_init) + {value->c.c_car=make_structures_internal(value->c.c_car); + value->c.c_cdr=make_structures_internal(value->c.c_cdr); + break;} + if(type_of(cadr(value))==t_structure) + {value=value->c.c_cdr->c.c_car; + break;} + {object def=caddr(value),plist=cdddr(value),result; + object slots,slots_tail; + int size,staticp,len,i; + if(def!=value)def=make_structures_internal(def); + result=alloc_object(t_structure); + result->str.str_def=(def==value)?result:def; + result->str.str_self=NULL; + value->c.c_cdr->c.c_car=result; + size=fixint(slot_value(def,siSsize)); + staticp=Cnil!=slot_value(def,siSstaticp); + slots=slot_value(def,siSslot_descriptions); + len=length(slots); + result->str.str_self=(object *)(staticp?alloc_contblock(size): + alloc_relblock(size)); + bzero(result->str.str_self,size); + if(def==value) + {S_DATA(result)->raw=slot_value(def,siSraw); + S_DATA(result)->slot_position=slot_value(def,siSslot_position);} + for(i=0,slots_tail=slots; i<len; i++,slots_tail=cdr(slots_tail)) + {object svalue=slot_value(value,slot_value(car(slots_tail),siSname)); + structure_set(result,result->str.str_def,i,svalue);} + for(i=0,slots_tail=slots; i<len; i++,slots_tail=cdr(slots_tail)) + {object svalue=structure_ref(result,result->str.str_def,i); + svalue=make_structures_internal(svalue); + structure_set(result,result->str.str_def,i,svalue);} + value=result; + break;} + case t_vector: + if ((enum aelttype)value->v.v_elttype == aet_object) + {int i,len=value->v.v_dim; + for(i=0; i<len; i++) + value->v.v_self[i]=make_structures_internal(value->v.v_self[i]);} + break; + case t_symbol: + {object plist=value->s.s_plist,next; + for(;!endp(plist);plist=cddr(plist)) + {next=plist->c.c_cdr; + if(plist->c.c_car==siLs_data&& + type_of(next->c.c_car)==t_cons) + next->c.c_car=make_structures_internal(next->c.c_car);} + break;}} + return value; +} + +void +siLmake_structures() +{ + check_arg(1); + vs_base[0]=make_structures_internal(vs_base[0]); +} + +void +siLstructure_def() +{check_arg(1); + check_type_structure(vs_base[0]); + vs_base[0]=vs_base[0]->str.str_def; +} + +short aet_sizes [] = { +sizeof(object), /* aet_object t */ +sizeof(char), /* aet_ch string-char */ +sizeof(char), /* aet_bit bit */ +sizeof(fixnum), /* aet_fix fixnum */ +sizeof(float), /* aet_sf short-float */ +sizeof(double), /* aet_lf long-float */ +sizeof(char), /* aet_char signed char */ +sizeof(char), /* aet_uchar unsigned char */ +sizeof(short), /* aet_short signed short */ +sizeof(short) /* aet_ushort unsigned short */ +}; + + + + + +void +siLsize_of() +{ object x= vs_base[0]; + int i; + i= aet_sizes[get_aelttype(x)]; + vs_base[0]=make_fixnum(i); +} + +void +siLaet_type() +{vs_base[0]=make_fixnum(get_aelttype(vs_base[0]));} + + +/* Return N such that something of type ARG can be aligned on + an address which is a multiple of N */ + + +void +siLalignment() +{struct {double x; int y; double z; + float x1; int y1; float z1;} + joe; + joe.z=3.0; + + if (vs_base[0]==Slong_float) + {vs_base[0]=make_fixnum((int)&joe.z- (int)&joe.y); return;} + else + if (vs_base[0]==Sshort_float) + {vs_base[0]=make_fixnum((int)&(joe.z1)-(int)&(joe.y1)); return;} + else + {siLsize_of();} +} + +void +swap_structure_contents(str1,str2) + object str1,str2; +{ + object def1,*self1; + check_type_structure(str1); + check_type_structure(str2); + def1=str1->str.str_def; + self1=str1->str.str_self; + str1->str.str_def=str2->str.str_def; + str1->str.str_self=str2->str.str_self; + str2->str.str_def=def1; + str2->str.str_self=self1; +} + +void +siLswap_structure_contents() +{ + check_arg(2); + swap_structure_contents(vs_base[0],vs_base[1]); + vs_base[0]=Cnil; + vs_top=vs_base+1; +} + +void +siLset_structure_def() +{check_arg(2); + check_type_structure(vs_base[0]); + check_type_structure(vs_base[1]); + vs_base[0]->str.str_def=vs_base[1]; + vs_base[0]=vs_base[1]; + vs_top=vs_base+1; +} + +init_structure_function() +{ + siLs_data=make_si_ordinary("S-DATA"); + siSstructure_init=make_si_ordinary("STRUCTURE-INIT"); + siSstructure_init_named=make_si_ordinary("STRUCTURE-INIT-NAMED"); + siSname=make_si_ordinary("NAME"); + siSdefault_init=make_si_ordinary("DEFAULT-INIT"); + siSraw=make_si_ordinary("RAW"); + siSslot_position=make_si_ordinary("SLOT-POSITION"); + siSsize=make_si_ordinary("SIZE"); + siSstaticp=make_si_ordinary("STATICP"); + siSslot_descriptions=make_si_ordinary("SLOT-DESCRIPTIONS"); + +@s] + + +****Change:(orig (239 239 a)) +@s[ make_si_function("MAKE-STRUCTURE", siLmake_structure); + +@s| make_si_function("MAKE-STRUCTURE", siLmake_structure); + make_si_function("MAKE-S-DATA-STRUCTURE",siLmake_s_data_structure); + +@s] + + +****Change:(orig (240 240 a)) +@s[ make_si_function("COPY-STRUCTURE", siLcopy_structure); + +@s| make_si_function("COPY-STRUCTURE", siLcopy_structure); + make_si_function("COPY-STRUCTURE-HEADER", siLcopy_structure_header); + +@s] + + +****Change:(orig (242 242 a)) +@s[ make_si_function("STRUCTURE-REF", siLstructure_ref); + +@s| make_si_function("STRUCTURE-REF", siLstructure_ref); + make_si_function("STRUCTURE-DEF", siLstructure_def); + make_si_function("STRUCTURE-REF1", siLstructure_ref1); + make_si_function("STRUCTURE-SET1", siLstructure_set1); + +@s] + + +****Change:(orig (245 245 c)) +@s[ make_si_function("STRUCTUREP", siLstructurep); + + +@s| make_si_function("STRUCTUREP", siLstructurep); + make_si_function("SIZE-OF", siLsize_of); + make_si_function("ALIGNMENT",siLalignment); + make_si_function("STRUCTURE-SUBTYPE-P",siLstructure_subtype_p); + +@s] + + +****Change:(orig (247 247 a)) +@s[ make_si_function("LIST-NTH", siLlist_nth); + +@s| make_si_function("LIST-NTH", siLlist_nth); + make_si_function("AET-TYPE",siLaet_type); + make_si_function("SWAP-STRUCTURE-CONTENTS",siLswap_structure_contents); + make_si_function("SET-STRUCTURE-DEF", siLset_structure_def); + make_si_function("MAKE-STRUCTURES", siLmake_structures); + + +@s] + +============================================================================== +============================== V/lsp/defstruct.lsp ============================= +Changes file for /kcl/lsp/defstruct.lsp +Usage \n@s[Original text\n@s|Replacement Text\n@s] +See the file rascal.ics.utexas.edu:/usr2/ftp/merge.c +for a program to merge change files. Anything not between + "\n@s[" and "\n@s]" is a simply a comment. +This file was constructed using emacs and merge.el + by (Bill Schelter) wfs@carl.ma.utexas.edu + + +****Change:(orig (20 71 c)) +@s[(defun make-access-function (name conc-name type named + slot-name default-init slot-type read-only + offset) + (declare (ignore named default-init slot-type)) + +@s, ((error "~S is an illegal structure type." type))))) + +@s|(defvar *accessors* (make-array 10 :adjustable t)) +(defvar *list-accessors* (make-array 2 :adjustable t)) +(defvar *vector-accessors* (make-array 2 :adjustable t)) + +@s] + + +****Change:(orig (72 72 a)) +@s[ + +@s| +(or (fboundp 'record-fn) (setf (symbol-function 'record-fn) + #'(lambda (&rest l) l nil))) + +@s] + + +****Change:(orig (73 73 a)) +@s[ + +@s| +(defun boot-slot-value (str name) + (if (structurep str) + (structure-ref str (structure-def str) name) + (getf (cdddr str) (intern (string name) :keyword)))) + +(defun boot-set-slot-value (str name new-value) + (if (structurep str) + (structure-set str (structure-def str) name new-value) + (setf (getf (cdddr str) (intern (string name) :keyword)) new-value))) + +(defun boot-subtypep (type1 type2) + (or (eq type1 type2) + (let* ((s-data (get type1 's-data)) + (include (boot-s-data-name (boot-slot-value s-data 'includes)))) + (boot-subtypep include type2)))) + +(defun make-slot-boot (&rest args) + (if (get 's-data 's-data) + (apply #'make-slot args) + (list* 'structure-init + nil + '(structure-init-named . slot) + args))) + +(defun make-s-data-boot (&rest args) + (if (get 's-data 's-data) + (apply #'make-s-data args) + (list* 'structure-init + nil + '(structure-init-named . s-data) + args))) + +(defun make-boot-accessor (slot accessor) + (setf (symbol-function accessor) + #'(lambda (object) + (boot-slot-value object slot))) + (let ((writer (intern (format nil "SET ~A" accessor)))) + (setf (symbol-function writer) + #'(lambda (object value) + (boot-set-slot-value object slot value))) + (eval `(defsetf ,accessor ,writer)))) + +(defmacro defstructboot (name &rest slots) + (let ((conc-name (if (listp name) + (string (second (assoc :conc-name (cdr name)))) + (format nil "~A-" name)))) + `(progn + ,@(mapcar #'(lambda (slot) + (let ((fname (intern (format nil "~A~A" conc-name slot)))) + `(make-boot-accessor ',slot ',fname))) + slots)))) + +(defstructboot (slot (:conc-name boot-slot-)) + name default-init type read-only offset accessor-name type-changed) + +(defstructboot (s-data-internal (:conc-name boot-s-data-)) + name length raw included includes staticp print-function + slot-descriptions slot-position size has-holes) + +(defstructboot (basic-wrapper (:conc-name boot-wrapper-)) + cache-number-vector state class) + +(defstructboot (s-data (:conc-name boot-s-data-)) + frozen documentation constructors offset + named type conc-name) + +(defun make-access-function (name conc-name type named include no-fun slot) + (declare (ignore named)) + + (let* ((slot-name (boot-slot-name slot)) + (slot-type (boot-slot-type slot)) + (read-only (boot-slot-read-only slot)) + (offset (boot-slot-offset slot)) + (access-function + (intern (si:string-concatenate (string conc-name) + (string slot-name)))) + accsrs dont-overwrite) + (unless (boot-slot-accessor-name slot) + (setf (boot-slot-accessor-name slot) access-function)) + (ecase type + ((nil) + (setf accsrs *accessors*)) + (list + (setf accsrs *list-accessors*)) + (vector + (setf accsrs *vector-accessors*))) + (or (> (length accsrs) offset) + (adjust-array accsrs (+ offset 10))) + (unless + dont-overwrite + (record-fn access-function 'defun '(t) slot-type) + (or no-fun + (and (fboundp access-function) + (eq (aref accsrs offset) (symbol-function access-function))) + (setf (symbol-function access-function) + (or (aref accsrs offset) + (setf (aref accsrs offset) + (cond ((eq accsrs *accessors*) + #'(lambda (x) + (or (structurep x) + (error "~a is not a structure" x)) + (structure-ref1 x offset))) + ((eq accsrs *list-accessors*) + #'(lambda(x) + (si:list-nth offset x))) + ((eq accsrs *vector-accessors*) + #'(lambda(x) + (aref x offset))))))))) + (cond (read-only + (remprop access-function 'structure-access) + (setf (get access-function 'struct-read-only) t)) + (t (remprop access-function 'setf-update-fn) + (remprop access-function 'setf-lambda) + (remprop access-function 'setf-documentation) + (let ((tem (get access-function 'structure-access))) + (cond ((and (consp tem) include + (if (consp (get include 's-data)) + (boot-subtypep include (car tem)) + (subtypep include (car tem))) + (eql (cdr tem) offset)) + ;; don't change overwrite accessor of subtype. + (setq dont-overwrite t) + ) + (t (setf (get access-function 'structure-access) + (cons (if type type name) offset))))))) + nil)) + + +@s] + + +****Change:(orig (80 89 c)) +@s[ (cond ((null x) + ;; If the slot-description is NIL, + ;; it is in the padding of initial-offset. + nil) + +@s, (t (car x)))) + +@s| (or (boot-slot-name x) + (and (boot-slot-default-init x) + ;; If the slot name is NIL, + ;; it is the structure name. + ;; This is for typed structures with names. + (list 'quote (boot-slot-default-init x))))) + +@s] + + +****Change:(orig (94 97 c)) +@s[ (cond ((null x) nil) + ((null (car x)) nil) + ((null (cadr x)) (list (car x))) + (t (list (list (car x) (cadr x)))))) + +@s| (when (boot-slot-name x) + (if (boot-slot-default-init x) + (list (list (boot-slot-name x) (boot-slot-default-init x))) + (list (boot-slot-name x))))) + +@s] + + +****Change:(orig (248 248 d)) +@s[ ((error "~S is an illegal structure type" type))))) + + + +@s| ((error "~S is an illegal structure type" type))))) + + +@s] + + +****Change:(orig (252 265 d)) +@s[ +(defun make-copier (name copier type named) + (declare (ignore named)) + (cond ((null type) + +@s, ((error "~S is an illegal structure type." type)))) + + + +@s| +@s] + + +****Change:(orig (267 275 c)) +@s[ (cond ((null type) + ;; If TYPE is NIL, the predicate searches the link + ;; of structure-include, until there is no included structure. + `(defun ,predicate (x) + +@s, (setq n (get n 'structure-include)))))) + +@s| (cond ((null type)) + ; done in define-structure + +@s] + + +****Change:(orig (282 283 c)) +@s[ (> (length x) ,name-offset) + (eq (elt x ,name-offset) ',name)))) + +@s| (> (the fixnum (length x)) ,name-offset) + (eq (aref (the (vector t) x) ,name-offset) ',name)))) + +@s] + + +****Change:(orig (294 294 a)) +@s[ ((= i 0) (and (consp y) (eq (car y) ',name))) + +@s| ((= i 0) (and (consp y) (eq (car y) ',name))) + (declare (fixnum i)) + +@s] + + +****Change:(orig (300 301 c)) +@s[;;; and returns a list of the form: +;;; (slot-name default-init slot-type read-only offset) + +@s|;;; and returns a slot. + +@s] + + +****Change:(orig (325 325 c)) +@s[ (list slot-name default-init slot-type read-only offset))) + +@s| (make-slot-boot :name slot-name + :default-init default-init + :type slot-type + :read-only read-only + :offset offset))) + +@s] + + +****Change:(orig (335 335 c)) +@s[ (let ((sds (member (caar olds) news :key #'car))) + +@s| (let* ((old (car olds)) + (sds (member (boot-slot-name old) news :key #'slot-name)) + (new (car sds))) + +@s] + + +****Change:(orig (337 348 c)) +@s[ (when (and (null (cadddr (car sds))) + (cadddr (car olds))) + ;; If read-only is true in the old + ;; and false in the new, signal an error. + +@s, (car (cddddr (car olds)))) + +@s| (when (and (null (boot-slot-read-only new)) + (boot-slot-read-only old)) + ;; If read-only is true in the old + ;; and false in the new, signal an error. + (error "~S is an illegal include slot-description." + new)) + ;; If + (setf (boot-slot-type new) + (best-array-element-type (boot-slot-type new))) + (when (not (equal (normalize-type (or (boot-slot-type new) t)) + (normalize-type (or (boot-slot-type old) t)))) + (error "Type mismmatch for included slot ~a" new)) + (cons (make-slot :name (boot-slot-name new) + :default-init (boot-slot-default-init new) + :type (boot-slot-type new) + :read-only (boot-slot-read-only new) + :offset (boot-slot-offset old)) + +@s] + + +****Change:(orig (353 353 a)) +@s[ (overwrite-slot-descriptions news (cdr olds)))))))) + + +@s| (overwrite-slot-descriptions news (cdr olds)))))))) + +(defvar *all-t-s-type* (make-array 50 :element-type 'unsigned-char :static t)) + +@s] + + +****Change:(orig (355 355 c)) +@s[;;; The DEFSTRUCT macro. + +@s|(defun make-t-type (n include slot-descriptions &aux i) + (let ((res (make-array n :element-type 'unsigned-char :static t))) + (when include + (let ((tem (get include 's-data))raw) + (or tem (error "Included structure undefined ~a" include)) + (setq raw (boot-s-data-raw tem)) + (dotimes (i (min n (length raw))) + (setf (aref res i) (aref raw i))))) + (dolist (v slot-descriptions) + (setq i (boot-slot-offset v)) + (let ((type (boot-slot-type v))) + (cond ((<= (the fixnum (alignment type)) #. (alignment t)) + (setf (aref res i) (aet-type type)))))) + (cond ((< n (length *all-t-s-type*)) + (dotimes (i n) + (cond ((not (eql (the fixnum (aref res i)) 0)) + (return-from make-t-type res)))) + *all-t-s-type*) + (t res)))) + +@s] + + +****Change:(orig (356 356 a)) +@s[ + +@s| +(defvar *standard-slot-positions* + (let ((ar (make-array 50 :element-type 'unsigned-short + :static t))) + (dotimes (i 50) + (declare (fixnum i)) + (setf (aref ar i)(* #. (size-of t) i))) + ar)) + +(eval-when (compile ) +(proclaim '(function round-up (fixnum fixnum ) fixnum)) +) + +(defun round-up (a b) + (declare (fixnum a b)) + (setq a (ceiling a b)) + (the fixnum (* a b))) + + +(defun get-slot-pos (leng include slot-descriptions &aux type small-types + has-holes) + (declare (special *standard-slot-positions*)) include + (dolist (v slot-descriptions) + (when (boot-slot-name v) + (setf type (best-array-element-type (boot-slot-type v)) + (boot-slot-type v) type) + (let ((val (boot-slot-default-init v))) + (unless (typep val type) + (if (and (symbolp val) + (constantp val)) + (setf val (symbol-value val))) + (and (constantp val) + (setf (boot-slot-default-init v) (coerce val type))))) + (cond ((memq type '(signed-char unsigned-char + short unsigned-short + long-float + bit)) + (setq small-types t))))) + (cond ((and (null small-types) + (< leng (length *standard-slot-positions*)) + (list *standard-slot-positions* (* leng #. (size-of t)) nil))) + (t (let ((ar (make-array leng :element-type 'unsigned-short + :static t)) + (pos 0)(i 0)(align 0)type (next-pos 0)) + (declare (fixnum pos i align next-pos)) + ;; A default array. + + (dolist (v slot-descriptions) + (setq type (boot-slot-type v)) + (setq align (alignment type)) + (unless (<= align #. (alignment t)) + (setq type t) + (setf (boot-slot-type v) t) + (setq align #. (alignment t)) + (setf (boot-slot-type-changed v) t)) + (setq next-pos (round-up pos align)) + (or (eql pos next-pos) (setq has-holes t)) + (setq pos next-pos) + (setf (aref ar i) pos) + (incf pos (size-of type)) + (incf i)) + (list ar (round-up pos (size-of t)) has-holes) + )))) + + +(defun define-structure (name conc-name type named slot-descriptions copier + static include print-function constructors + offset predicate &optional documentation no-funs + &aux leng) + (and (consp type) (eq (car type) 'vector)(setq type 'vector)) + (setq leng (length slot-descriptions)) + (setq slot-descriptions + (mapcar #'(lambda (info) + (make-slot-boot :name (first info) + :default-init (second info) + :type (third info) + :read-only (fourth info) + :offset (fifth info) + :accessor-name (sixth info) + :type-changed (seventh info))) + slot-descriptions)) + (dolist (x slot-descriptions) + (when (boot-slot-name x) + (make-access-function name conc-name type named include no-funs x))) + (when (and copier (not no-funs)) + (setf (symbol-function copier) + (ecase type + ((nil) #'si::copy-structure) + (list #'copy-list) + (vector #'copy-seq)))) + (let ((include-str (and include (get include 's-data)))) + (when (and (eq include 's-data-internal) + (not (eq name 'basic-wrapper))) + (error "only ~s can include ~s" 'basic-wrapper 's-data-internal)) + (when include-str + (cond ((and (not (consp include-str)) + (s-data-frozen include-str) + (or (not (s-data-included include-str)) + (not (let ((te (get name 's-data))) + (and te + (eq (s-data-includes te) + include-str)))))) + (warn " ~a was frozen but now included" + include))) + (let ((old-included (boot-slot-value include-str 'included))) + (unless (member name old-included) + (boot-set-slot-value include-str 'included (cons name old-included))))) + (let* ((tem (get name 's-data)) + (g-s-p (and (null type) + (get-slot-pos leng include slot-descriptions))) + (slot-position (car g-s-p)) + (size (if g-s-p (cadr g-s-p) 0)) + (has-holes (caddr g-s-p)) + (def (make-s-data-boot :name name + :length leng + :raw + (and (null type) + (make-t-type leng include + slot-descriptions)) + :slot-position slot-position + :size size + :has-holes has-holes + :staticp static + :includes include-str + :print-function print-function + :slot-descriptions slot-descriptions + :constructors constructors + :offset offset + :type type + :named named + :documentation documentation + :conc-name conc-name))) + (check-s-data tem def name) + (when (and (consp def) (eq name 's-data)) + (make-structures def)))) + (when documentation + (setf (get name 'structure-documentation) + documentation)) + (when (and (null type) predicate) + (record-fn predicate 'defun '(t) t) + (or no-funs + (setf (symbol-function predicate) + #'(lambda (x) + (si::structure-subtype-p x name)))) + (setf (get predicate 'compiler::co1) + 'compiler::co1structure-predicate) + (setf (get predicate 'struct-predicate) name)) + nil) + +(defun check-s-data (old new name) + (unless (and old (member name '(slot s-data-internal basic-wrapper s-data))) + (when (and old (eq (structure-def old) (get 's-data 's-data))) + (boot-set-slot-value new 'included (boot-slot-value old 'included)) + (boot-set-slot-value new 'frozen (boot-slot-value old 'frozen))) + (unless (and old + (eq (structure-def old) (get 's-data 's-data)) + (let ((new-cnv (boot-slot-value new 'cache-number-vector)) + (old-cnv (boot-slot-value old 'cache-number-vector))) + (boot-set-slot-value new 'cache-number-vector old-cnv) + (prog1 (equalp new old) + (boot-set-slot-value new 'cache-number-vector new-cnv)))) + (when old + (warn "structure ~a is changing" name) + (when (eq (structure-def old) (get 's-data 's-data)) + (boot-set-slot-value old 'state (list ':obsolete new)))) + (setf (get name 's-data) new)))) + + +@s] + + +****Change:(orig (364 364 c)) +@s[ predicate predicate-specified + include + +@s| predicate predicate-specified + include include-s-data + +@s] + + +****Change:(orig (367 367 c)) +@s[ offset name-offset + documentation) + +@s| offset name-offset + documentation + static) + +@s] + + +****Change:(orig (370 370 c)) +@s[ ;; The defstruct options are supplied. + +@s| ;; The defstruct options are supplied. + +@s] + + +****Change:(orig (390 425 c)) +@s[ (cond ((and (consp (car os)) (not (endp (cdar os)))) + (setq o (caar os) v (cadar os)) + (case o + (:conc-name + +@s, (t (error "~S is an illegal defstruct option." o)))))) + +@s| (cond ((and (consp (car os)) (not (endp (cdar os)))) + (setq o (caar os) v (cadar os)) + (case o + (:conc-name + (if (null v) + (setq conc-name "") + (setq conc-name v))) + (:constructor + (if (null v) + (setq no-constructor t) + (if (endp (cddar os)) + (setq constructors (cons v constructors)) + (setq constructors (cons (cdar os) constructors))))) + (:copier (setq copier v)) + (:static (setq static v)) + (:predicate + (setq predicate v) + (setq predicate-specified t)) + (:include + (setq include (cdar os)) + (unless (setq include-s-data (get v 's-data)) + (error "~S is an illegal included structure." v))) + (:print-function + (and (consp v) (eq (car v) 'function) + (setq v (second v))) + (setq print-function v)) + (:type (setq type v)) + (:initial-offset (setq initial-offset v)) + (t (error "~S is an illegal defstruct option." o)))) + (t + (if (consp (car os)) + (setq o (caar os)) + (setq o (car os))) + (case o + (:constructor + (setq constructors + (cons default-constructor constructors))) + ((:conc-name :copier :predicate :print-function)) + (:named (setq named t)) + (t (error "~S is an illegal defstruct option." o)))))) + +@s] + + +****Change:(orig (426 426 a)) +@s[ + +@s| + (setq conc-name (intern (string conc-name))) + + (and include-s-data (not print-function) + (setq print-function (boot-s-data-print-function include-s-data))) + + +@s] + + +****Change:(orig (434 435 c)) +@s[ (when include + (unless (equal type (get (car include) 'structure-type)) + +@s| (when include-s-data + (unless (equal type (boot-s-data-type include-s-data)) + +@s] + + +****Change:(orig (442 443 c)) +@s[ (t + (setq offset (get (car include) 'structure-offset)))) + +@s| (t + (setq offset (boot-s-data-offset include-s-data)))) + +@s] + + +****Change:(orig (457 458 c)) +@s[ (setq sds (cons (parse-slot-description (car ds) offset) sds)) + (setq offset (1+ offset))) + +@s| (setq sds (cons (parse-slot-description (car ds) offset) sds)) + (setq offset (1+ offset))) + +@s] + + +****Change:(orig (464 464 c)) +@s[ (cons (list nil name) slot-descriptions))) + +@s| (cons (make-slot :default-init name) slot-descriptions))) + +@s] + + +****Change:(orig (469 469 c)) +@s[ (append (make-list initial-offset) slot-descriptions))) + +@s| (append (mapcar #'make-named-slot (make-list initial-offset)) + slot-descriptions))) + +@s] + + +****Change:(orig (473 486 c)) +@s[ (cond ((null include)) + ((endp (cdr include)) + (setq slot-descriptions + (append (get (car include) 'structure-slot-descriptions) + +@s, slot-descriptions)))) + +@s| (let ((include-slot-descriptions + (and include + (boot-s-data-slot-descriptions include-s-data)))) + (cond ((null include)) + ((endp (cdr include)) + (setq slot-descriptions + (append include-slot-descriptions + slot-descriptions))) + (t + (setq slot-descriptions + (append (overwrite-slot-descriptions + (mapcar #'(lambda (sd) + (parse-slot-description sd 0)) + (cdr include)) + include-slot-descriptions) + slot-descriptions))))) + +@s] + + +****Change:(orig (489 492 c)) +@s[ ;; If a constructor option is NIL, + ;; no constructor should have been specified. + (when constructors + (error "Contradictory constructor options."))) + +@s| ;; If a constructor option is NIL, + ;; no constructor should have been specified. + (when constructors + (error "Contradictory constructor options."))) + +@s] + + +****Change:(orig (494 495 c)) +@s[ ;; If no constructor is specified, + ;; the default-constructor is made. + +@s| ;; If no constructor is specified, + ;; the default-constructor is made. + +@s] + + +****Change:(orig (497 497 a)) +@s[ (setq constructors (list default-constructor)))) + + +@s| (setq constructors (list default-constructor)))) + + ;; We need a default constructor for the sharp-s-reader + (or (member t (mapcar 'symbolp constructors)) + (push (intern (string-concatenate "__si::" default-constructor)) + constructors)) + + +@s] + + +****Change:(orig (509 509 c)) +@s[ (error "An print function is supplied to a typed structure.")) + +@s| (error "A print function is supplied to a typed structure.")) + + `(progn + (define-structure ',name ',conc-name ',type ',named + ',(mapcar #'(lambda (slotd) + (list (boot-slot-name slotd) + (boot-slot-default-init slotd) + (boot-slot-type slotd) + (boot-slot-read-only slotd) + (boot-slot-offset slotd) + (boot-slot-accessor-name slotd) + (boot-slot-type-changed slotd))) + slot-descriptions) + ',copier ',static ',include ',print-function ',constructors + ',offset ',predicate ',documentation) + +@s] + + +****Change:(orig (511 542 c)) +@s[ `(progn (si:putprop ',name + '(defstruct ,name ,@slots) + 'defstruct-form) + (si:putprop ',name t 'is-a-structure) + +@s, (si:putprop ',name ,documentation 'structure-documentation) + ',name))) + +@s| ,@(mapcar #'(lambda (constructor) + (make-constructor name constructor type named + slot-descriptions)) + constructors) + ,@(if (and type predicate) + (list (make-predicate name predicate type named + name-offset))) + ',name + ))) + +@s] + + +****Change:(orig (544 544 a)) +@s[ + + +@s| + +(eval-when (compile load eval) + +(defconstant wrapper-cache-number-adds-ok 4) + +(defconstant wrapper-cache-number-length + (- (integer-length most-positive-fixnum) + wrapper-cache-number-adds-ok)) + +(defconstant wrapper-cache-number-mask + (1- (expt 2 wrapper-cache-number-length))) + + +(defvar *get-wrapper-cache-number* (make-random-state)) + +(defun get-wrapper-cache-number () + (let ((n 0)) + (declare (fixnum n)) + (loop + (setq n + (logand wrapper-cache-number-mask + (random most-positive-fixnum *get-wrapper-cache-number*))) + (unless (zerop n) (return n))))) + +) + +(eval-when (compile load eval) + +(defconstant wrapper-cache-number-vector-length 8) + +(deftype cache-number-vector () + `(simple-array fixnum (8))) + +(defconstant wrapper-layout (make-list wrapper-cache-number-vector-length + :initial-element 'number)) + +) + +(defun make-wrapper-cache-number-vector () + (let ((cnv (make-array #.wrapper-cache-number-vector-length + :element-type 'fixnum))) + (dotimes (i #.wrapper-cache-number-vector-length) + (setf (aref cnv i) (get-wrapper-cache-number))) + cnv)) + +(defstruct (slot + (:static t) + (:constructor make-slot) + (:constructor make-named-slot (name))) + name + default-init + (type t) + read-only + offset + accessor-name + type-changed) + +;; All of the fields of s-data-internal must coincide with +;; the C structure s_data (see object.h). +(defstruct (s-data-internal + (:conc-name s-data-) + (:constructor nil) + (:static t)) + ;; all of these slots are used by c code + name ; a symbol + (length 0 :type fixnum) ; length of slot-descriptions + raw ; a static array of unsigned-short (enum aelttype) + included ; a list of the names of structures including this one + includes ; nil or a s-data structure + staticp ; t or nil + print-function ; nil, a symbol, or a lambda expression + slot-descriptions ; a list of slots + slot-position ; a static array of unsigned-short + (size 0 :type fixnum) ; total size to allocate + has-holes) ; t or nil + +(defstruct (basic-wrapper (:include s-data-internal) + (:conc-name wrapper-) + (:constructor nil) + (:static t)) + (cache-number-vector (make-wrapper-cache-number-vector)) + (state t) ; either t or a list (state-sym new-wrapper) + ;; where state-sym is either :flush or :obsolete + (class nil)) + +;(get name 'si::s-data) ;returns one of these: +(defstruct (s-data (:include basic-wrapper) + (:static t)) + ;; these slots are used only from lisp + frozen ; t or nil ; t means won't include this + documentation + constructors ; a list of either a symbol or a list symbol, arglist + offset ; the total number of slots and placeholders + named ; t or nil + type ; one of: nil, list, or vector + conc-name) ; an interned symbol + +#|| +(import '(si::wrapper-state si::wrapper-class si::basic-wrapper)) + +(defstruct (wrapper (:include basic-wrapper) + (:print-function print-wrapper) + (:constructor make-wrapper-internal) + (:predicate wrapper-p) + (:conc-name wrapper-)) + (class-slots nil :type list)) + +(defun print-wrapper (instance stream depth) + (printing-random-thing (wrapper stream) + (format stream "Wrapper ~S" (wrapper-class wrapper)))) +||# + +(defun update-wrapper-state (old new same-p) + (unless (consp old) + (setf (wrapper-state old) + (list (if same-p ':flush ':obsolete) new)))) + +(defun freeze-defstruct (name) + (let ((tem (and (symbolp name) (get name 's-data)))) + (if tem (setf (s-data-frozen tem) t)))) + + + +@s] + + +****Change:(orig (551 553 c)) +@s[ (let ((l (read stream))) + (unless (get (car l) 'is-a-structure) + (error "~S is not a structure." (car l))) + +@s| (let* ((l (prog1 (read stream t nil t) + (if *read-suppress* + (return-from sharp-s-reader nil)))) + (sd + (or (get (car l) 's-data) + + (error "~S is not a structure." (car l))))) + + +@s] + + +****Change:(orig (558 558 c)) +@s[ (do ((cs (get (car l) 'structure-constructors) (cdr cs))) + +@s| (do ((cs (s-data-constructors sd) (cdr cs))) + +@s] + + +****Change:(orig (571 571 d)) +@s[(set-dispatch-macro-character #\# #\S 'sharp-s-reader) + + + +@s|(set-dispatch-macro-character #\# #\S 'sharp-s-reader) + + +@s] + + +****Change:(orig (582 582 c)) +@s[(defstruct person name age sex) + +@s|(defstruct person name (age 20 :type signed-char) (eyes 2 :type signed-char) + sex) +(defstruct person name (age 20 :type signed-char) (eyes 2 :type signed-char) + sex) +(defstruct person1 name (age 20 :type fixnum) + sex) + +@s] + + +****Change:(orig (584 584 c)) +@s[(defstruct (astronaut (:include person (age 45)) + +@s|(defstruct joe a (a1 0 :type (mod 30)) (a2 0 :type (mod 30)) + (a3 0 :type (mod 30)) (a4 0 :type (mod 30)) ) + +;(defstruct person name age sex) + +(defstruct (astronaut (:include person (age 45 :type fixnum)) + +@s] + + +****Change:(orig (605 605 a)) +@s[ associative + identity) + +@s| associative + identity) + + +@s] + +============================================================================== diff --git a/pcl/slots-boot.lisp b/pcl/slots-boot.lisp new file mode 100644 index 000000000..da7b525b1 --- /dev/null +++ b/pcl/slots-boot.lisp @@ -0,0 +1,396 @@ +;;;-*-Mode:LISP; Package:PCL; 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. +;;; ************************************************************************* +;;; + +(in-package 'pcl) + +(defmacro slot-symbol (slot-name type) + `(if (and (symbolp ,slot-name) (symbol-package ,slot-name)) + (or (get ,slot-name ',(ecase type + (reader 'reader-symbol) + (writer 'writer-symbol) + (boundp 'boundp-symbol))) + (intern (format nil "~A ~A slot ~a" + (package-name (symbol-package ,slot-name)) + (symbol-name ,slot-name) + ,(symbol-name type)) + *slot-accessor-name-package*)) + (progn + (error "non-symbol and non-interned symbol slot name accessors~ + are not yet implemented") + ;;(make-symbol (format nil "~a ~a" ,slot-name ,type)) + ))) + +(defun slot-reader-symbol (slot-name) + (slot-symbol slot-name reader)) + +(defun slot-writer-symbol (slot-name) + (slot-symbol slot-name writer)) + +(defun slot-boundp-symbol (slot-name) + (slot-symbol slot-name boundp)) + +(defmacro asv-funcall (sym slot-name &rest args) + `(function-funcall (if (#-akcl fboundp #+akcl %fboundp ,sym) + (#-akcl symbol-function #+akcl %symbol-function ,sym) + (no-slot ,sym ,slot-name)) + ,@args)) + +(defun no-slot (slot-name sym) + (error "No class has a slot named ~S (~s has no function binding) + (or maybe your files were compiled with an old version of PCL:~ + try recompiling.)" + slot-name sym)) + +(defmacro accessor-slot-value (object slot-name) + (unless (constantp slot-name) + (error "~s requires its slot-name argument to be a constant" + 'accessor-slot-value)) + (let* ((slot-name (eval slot-name)) + (sym (slot-reader-symbol slot-name))) + `(asv-funcall ',sym ',slot-name ,object))) + +(defmacro accessor-set-slot-value (object slot-name new-value &environment env) + (unless (constantp slot-name) + (error "~s requires its slot-name argument to be a constant" + 'accessor-set-slot-value)) + (setq object (macroexpand object env)) + (setq slot-name (macroexpand slot-name env)) + (let* ((slot-name (eval slot-name)) + (bindings (unless (or (constantp new-value) (atom new-value)) + (let ((object-var (gensym))) + (prog1 `((,object-var ,object)) + (setq object object-var))))) + (sym (slot-writer-symbol slot-name)) + (form `(asv-funcall ',sym ',slot-name ,new-value ,object))) + (if bindings + `(let ,bindings ,form) + form))) + +(defconstant *optimize-slot-boundp* nil) + +(defmacro accessor-slot-boundp (object slot-name) + (unless (constantp slot-name) + (error "~s requires its slot-name argument to be a constant" + 'accessor-slot-boundp)) + (let* ((slot-name (eval slot-name)) + (sym (slot-boundp-symbol slot-name))) + (if (not *optimize-slot-boundp*) + `(slot-boundp-normal ,object ',slot-name) + `(asv-funcall ',sym ',slot-name ,object)))) + + +(defun structure-slot-boundp (object) + (declare (ignore object)) + t) + +(defun make-structure-slot-boundp-function (slotd) + (let* ((reader (slot-definition-internal-reader-function slotd)) + (fun #'(lambda (object) + (not (eq (funcall reader object) *slot-unbound*))))) + #+(and kcl turbo-closure) (si:turbo-closure fun) + fun)) + +(defun get-optimized-std-accessor-method-function (class slotd name) + (if (structure-class-p class) + (ecase name + (reader (slot-definition-internal-reader-function slotd)) + (writer (slot-definition-internal-writer-function slotd)) + (boundp (make-structure-slot-boundp-function slotd))) + (let* ((fsc-p (cond ((standard-class-p class) nil) + ((funcallable-standard-class-p class) t) + (t (error "~S is not a standard-class" class)))) + (slot-name (slot-definition-name slotd)) + (index (slot-definition-location slotd)) + (function (ecase name + (reader 'make-optimized-std-reader-method-function) + (writer 'make-optimized-std-writer-method-function) + (boundp 'make-optimized-std-boundp-method-function))) + (value (funcall function fsc-p slot-name index))) + (values value index)))) + +(defun make-optimized-std-reader-method-function (fsc-p slot-name index) + (declare #.*optimize-speed*) + (set-function-name + (etypecase index + (fixnum (if fsc-p + #'(lambda (instance) + (let ((value (%instance-ref (fsc-instance-slots instance) index))) + (if (eq value *slot-unbound*) + (slot-unbound (class-of instance) instance slot-name) + value))) + #'(lambda (instance) + (let ((value (%instance-ref (std-instance-slots instance) index))) + (if (eq value *slot-unbound*) + (slot-unbound (class-of instance) instance slot-name) + value))))) + (cons #'(lambda (instance) + (let ((value (cdr index))) + (if (eq value *slot-unbound*) + (slot-unbound (class-of instance) instance slot-name) + value))))) + `(reader ,slot-name))) + +(defun make-optimized-std-writer-method-function (fsc-p slot-name index) + (declare #.*optimize-speed*) + (set-function-name + (etypecase index + (fixnum (if fsc-p + #'(lambda (nv instance) + (setf (%instance-ref (fsc-instance-slots instance) index) nv)) + #'(lambda (nv instance) + (setf (%instance-ref (std-instance-slots instance) index) nv)))) + (cons #'(lambda (nv instance) + (declare (ignore instance)) + (setf (cdr index) nv)))) + `(writer ,slot-name))) + +(defun make-optimized-std-boundp-method-function (fsc-p slot-name index) + (declare #.*optimize-speed*) + (set-function-name + (etypecase index + (fixnum (if fsc-p + #'(lambda (instance) + (not (eq *slot-unbound* + (%instance-ref (fsc-instance-slots instance) index)))) + #'(lambda (instance) + (not (eq *slot-unbound* + (%instance-ref (std-instance-slots instance) index)))))) + (cons #'(lambda (instance) + (declare (ignore instance)) + (not (eq *slot-unbound* (cdr index)))))) + `(boundp ,slot-name))) + +(defun make-optimized-structure-slot-value-using-class-method-function (function) + #+cmu (declare (type function function)) + #'(lambda (class object slotd) + (let ((value (funcall function object))) + (if (eq value *slot-unbound*) + (slot-unbound class object (slot-definition-name slotd)) + value)))) + +(defun make-optimized-structure-setf-slot-value-using-class-method-function (function) + #+cmu (declare (type function function)) + #'(lambda (nv class object slotd) + (declare (ignore class slotd)) + (funcall function nv object))) + +(defun make-optimized-structure-slot-boundp-using-class-method-function (function) + #+cmu (declare (type function function)) + #'(lambda (class object slotd) + (declare (ignore class slotd)) + (not (eq (funcall function object) *slot-unbound*)))) + +(defun get-optimized-std-slot-value-using-class-method-function (class slotd name) + (if (structure-class-p class) + (ecase name + (reader (make-optimized-structure-slot-value-using-class-method-function + (slot-definition-internal-reader-function slotd))) + (writer (make-optimized-structure-setf-slot-value-using-class-method-function + (slot-definition-internal-writer-function slotd))) + (boundp (make-optimized-structure-slot-boundp-using-class-method-function + (slot-definition-internal-writer-function slotd)))) + (let* ((fsc-p (cond ((standard-class-p class) nil) + ((funcallable-standard-class-p class) t) + (t (error "~S is not a standard-class" class)))) + (slot-name (slot-definition-name slotd)) + (index (slot-definition-location slotd)) + (function + (ecase name + (reader + #'make-optimized-std-slot-value-using-class-method-function) + (writer + #'make-optimized-std-setf-slot-value-using-class-method-function) + (boundp + #'make-optimized-std-slot-boundp-using-class-method-function)))) + #+cmu (declare (type function function)) + (values (funcall function fsc-p slot-name index) index)))) + +(defun make-optimized-std-slot-value-using-class-method-function + (fsc-p slot-name index) + (declare #.*optimize-speed*) + (etypecase index + (fixnum (if fsc-p + #'(lambda (class instance slotd) + (declare (ignore slotd)) + (unless (fsc-instance-p instance) (error "not fsc")) + (let ((value (%instance-ref (fsc-instance-slots instance) index))) + (if (eq value *slot-unbound*) + (slot-unbound class instance slot-name) + value))) + #'(lambda (class instance slotd) + (declare (ignore slotd)) + (unless (std-instance-p instance) (error "not std")) + (let ((value (%instance-ref (std-instance-slots instance) index))) + (if (eq value *slot-unbound*) + (slot-unbound class instance slot-name) + value))))) + (cons #'(lambda (class instance slotd) + (declare (ignore slotd)) + (let ((value (cdr index))) + (if (eq value *slot-unbound*) + (slot-unbound class instance slot-name) + value)))))) + +(defun make-optimized-std-setf-slot-value-using-class-method-function + (fsc-p slot-name index) + (declare #.*optimize-speed*) + (declare (ignore slot-name)) + (etypecase index + (fixnum (if fsc-p + #'(lambda (nv class instance slotd) + (declare (ignore class slotd)) + (setf (%instance-ref (fsc-instance-slots instance) index) nv)) + #'(lambda (nv class instance slotd) + (declare (ignore class slotd)) + (setf (%instance-ref (std-instance-slots instance) index) nv)))) + (cons #'(lambda (nv class instance slotd) + (declare (ignore class instance slotd)) + (setf (cdr index) nv))))) + +(defun make-optimized-std-slot-boundp-using-class-method-function + (fsc-p slot-name index) + (declare #.*optimize-speed*) + (declare (ignore slot-name)) + (etypecase index + (fixnum (if fsc-p + #'(lambda (class instance slotd) + (declare (ignore class slotd)) + (not (eq *slot-unbound* + (%instance-ref (fsc-instance-slots instance) index)))) + #'(lambda (class instance slotd) + (declare (ignore class slotd)) + (not (eq *slot-unbound* + (%instance-ref (std-instance-slots instance) index)))))) + (cons #'(lambda (class instance slotd) + (declare (ignore class instance slotd)) + (not (eq *slot-unbound* (cdr index))))))) + +(defun get-accessor-from-svuc-method-function (class slotd sdfun name) + (macrolet ((emf-funcall (emf &rest args) + `(invoke-effective-method-function ,emf nil ,@args))) + (set-function-name + (case name + (reader #'(lambda (instance) (emf-funcall sdfun class instance slotd))) + (writer #'(lambda (nv instance) (emf-funcall sdfun nv class instance slotd))) + (boundp #'(lambda (instance) (emf-funcall sdfun class instance slotd)))) + `(,name ,(class-name class) ,(slot-definition-name slotd))))) + +(defun make-internal-reader-method-function (class-name slot-name) + (list* ':method-spec `(internal-reader-method ,class-name ,slot-name) + (make-method-function + (lambda (instance) + (let ((wrapper (cond ((std-instance-p instance) + (std-instance-wrapper instance)) + ((fsc-instance-p instance) + (fsc-instance-wrapper instance))))) + (if wrapper + (let* ((class (wrapper-class* wrapper)) + (index (or (instance-slot-index wrapper slot-name) + (assq slot-name (wrapper-class-slots wrapper))))) + (typecase index + (fixnum + (let ((value (%instance-ref (get-slots instance) index))) + (if (eq value *slot-unbound*) + (slot-unbound (class-of instance) instance slot-name) + value))) + (cons + (let ((value (cdr index))) + (if (eq value *slot-unbound*) + (slot-unbound (class-of instance) instance slot-name) + value))) + (t + (error "The wrapper for class ~S does not have the slot ~S" + class slot-name)))) + (slot-value instance slot-name))))))) + + +(defun make-std-reader-method-function (class-name slot-name) + (let* ((pv-table-symbol (gensym)) + (initargs (copy-tree + (make-method-function + (lambda (instance) + (pv-binding1 (.pv. .calls. + (symbol-value pv-table-symbol) + (instance) (instance-slots)) + (instance-read-internal + .pv. instance-slots 1 + (slot-value instance slot-name)))))))) + (setf (getf (getf initargs ':plist) ':slot-name-lists) + (list (list nil slot-name))) + (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol) + (list* ':method-spec `(reader-method ,class-name ,slot-name) + initargs))) + +(defun make-std-writer-method-function (class-name slot-name) + (let* ((pv-table-symbol (gensym)) + (initargs (copy-tree + (make-method-function + (lambda (nv instance) + (pv-binding1 (.pv. .calls. + (symbol-value pv-table-symbol) + (instance) (instance-slots)) + (instance-write-internal + .pv. instance-slots 1 nv + (setf (slot-value instance slot-name) nv)))))))) + (setf (getf (getf initargs ':plist) ':slot-name-lists) + (list nil (list nil slot-name))) + (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol) + (list* ':method-spec `(writer-method ,class-name ,slot-name) + initargs))) + +(defun make-std-boundp-method-function (class-name slot-name) + (let* ((pv-table-symbol (gensym)) + (initargs (copy-tree + (make-method-function + (lambda (instance) + (pv-binding1 (.pv. .calls. + (symbol-value pv-table-symbol) + (instance) (instance-slots)) + (instance-boundp-internal + .pv. instance-slots 1 + (slot-boundp instance slot-name)))))))) + (setf (getf (getf initargs ':plist) ':slot-name-lists) + (list (list nil slot-name))) + (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol) + (list* ':method-spec `(boundp-method ,class-name ,slot-name) + initargs))) + +(defun initialize-internal-slot-gfs (slot-name) + (let* ((name (slot-reader-symbol slot-name)) + (gf (ensure-generic-function name))) + (unless (generic-function-methods gf) + (add-reader-method *the-class-slot-object* gf slot-name))) + (let* ((name (slot-writer-symbol slot-name)) + (gf (ensure-generic-function name))) + (unless (generic-function-methods gf) + (add-writer-method *the-class-slot-object* gf slot-name))) + (when *optimize-slot-boundp* + (let* ((name (slot-boundp-symbol slot-name)) + (gf (ensure-generic-function name))) + (unless (generic-function-methods gf) + (add-boundp-method *the-class-slot-object* gf slot-name)))) + nil) -- GitLab