rs@uunet.UU.NET (Rich Salz) (07/31/87)
Submitted-by: Roy D'Souza <dsouza%hplabsc@hplabs.HP.COM>
Posting-number: Volume 10, Issue 76
Archive-name: comobj.lisp/Part02
#! /bin/sh
# This is a shell archive. Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file". To overwrite existing
# files, type "sh file -c". You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g.. If this archive is complete, you
# will see the following message at the end:
# "End of archive 2 (of 13)."
# Contents: 3600-low.l co-macros.l co-prof.l co-sfun.l co-test.l
# dfun-templ.l pcl-patches.l xerox-low.l
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f '3600-low.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'3600-low.l'\"
else
echo shar: Extracting \"'3600-low.l'\" \(8740 characters\)
sed "s/^X//" >'3600-low.l' <<'END_OF_FILE'
X;;; -*- Mode:LISP; Package:(PCL Lisp 1000); Base:10.; Syntax:Common-lisp; Patch-File: Yes -*-
X;;;
X;;; *************************************************************************
X;;; Copyright (c) 1985 Xerox Corporation. All rights reserved.
X;;;
X;;; Use and copying of this software and preparation of derivative works
X;;; based upon this software are permitted. Any distribution of this
X;;; software or derivative works must comply with all applicable United
X;;; States export control laws.
X;;;
X;;; This software is made available AS IS, and Xerox Corporation makes no
X;;; warranty about the software, its performance or its conformity to any
X;;; specification.
X;;;
X;;; Any person obtaining a copy of this software is requested to send their
X;;; name and post office or electronic mail address to:
X;;; CommonLoops Coordinator
X;;; Xerox Artifical Intelligence Systems
X;;; 2400 Hanover St.
X;;; Palo Alto, CA 94303
X;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
X;;;
X;;; Suggestions, comments and requests for improvements are also welcome.
X;;; *************************************************************************
X;;;
X;;; This is the 3600 version of the file portable-low.
X;;;
X
X(in-package 'pcl)
X
X(defmacro without-interrupts (&body body)
X `(zl:without-interrupts ,.body))
X
X ;;
X;;;;;; Load Time Constants
X ;;
X;;;
X;;; This implementation of load-time-eval exploits the perhaps questionable
X;;; feature that it is possible to define optimizers on macros.
X;;;
X;;; WHEN EXPANDS-TO
X;;; compile to a file (#:EVAL-AT-LOAD-TIME-MARKER . <form>)
X;;; compile to core '<result of evaluating form>
X;;; not in compiler at all (progn <form>)
X;;;
X(defmacro load-time-eval (form)
X ;; The interpreted definition of load-time-eval. This definition
X ;; never gets compiled.
X (let ((value (gensym)))
X `(multiple-value-bind (,value)
X (progn ,form)
X ,value)))
X
X(compiler:deftransformer (load-time-eval compile-load-time-eval)
X (form &optional interpreted-form)
X (ignore interpreted-form)
X ;; When compiling a call to load-time-eval the compiler will call
X ;; this optimizer before the macro expansion.
X (if zl:compiler:(and (boundp '*compile-function*) ;Probably don't need
X ;this boundp check
X ;but it can't hurt.
X (funcall *compile-function* :to-core-p))
X ;; Compiling to core.
X ;; Evaluate the form now, and expand into a constant
X ;; (the result of evaluating the form).
X `',(eval (cadr form))
X ;; Compiling to a file.
X ;; Generate the magic which causes the dumper compiler and loader
X ;; to do magic and evaluate the form at load time.
X `',(cons compiler:eval-at-load-time-marker (cadr form))))
X
X ;;
X;;;;;; Memory Block primitives.
X ;;
X
X
X(defmacro make-memory-block (size &optional area)
X `(make-array ,size :area ,area))
X
X(defmacro memory-block-ref (block offset) ;Don't want to go faster yet.
X `(aref ,block ,offset))
X
X(defvar class-wrapper-area)
X(eval-when (load eval)
X (si:make-area :name 'class-wrapper-area
X :room t
X :gc :static))
X
X
X;;;
X;;; Reimplementation OF %INSTANCE
X;;;
X;;; We take advantage of the fact that Symbolics defstruct doesn't depend on
X;;; the fact that Common Lisp defstructs are fixed length. This allows us to
X;;; use defstruct to define a new type, but use internal structure allocation
X;;; code to make structure of that type of any length we like.
X;;;
X;;; In Symbolics Common Lisp, structures are really just arrays with a magic
X;;; bit set. The first element of the array points to the symbol which is
X;;; the name of this structure. The remaining elements are used for the
X;;; slots of the structure.
X;;;
X;;; In our %instance datatype, the array look like
X;;;
X;;; element 0: The symbol %INSTANCE, this tells the system what kind of
X;;; structure this is.
X;;; element 1: The meta-class of this %INSTANCE
X;;; element 2: This is used to store the value of %instance-ref slot 0.
X;;; element 3: This is used to store the value of %instance-ref slot 1.
X;;; . .
X;;; . .
X;;;
X(defstruct (%instance (:print-function print-instance)
X (:constructor nil)
X (:predicate %instancep))
X meta-class)
X
X(zl:defselect ((:property %instance zl:named-structure-invoke))
X (:print-self (iwmc-class stream print-depth *print-escape*)
X (print-instance iwmc-class stream print-depth))
X (:describe (iwmc-class &optional no-complaints)
X (ignore no-complaints)
X (describe-instance iwmc-class)))
X
X(defmacro %make-instance (meta-class size)
X (let ((instance-var (gensym)))
X `(let ((,instance-var (make-array (+ 2 ,size))))
X (setf (SI:ARRAY-NAMED-STRUCTURE-BIT ,instance-var) 1
X (aref ,instance-var 0) '%instance
X (aref ,instance-var 1) ,meta-class)
X ,instance-var)))
X
X(defmacro %instance-ref (instance index)
X `(aref ,instance (+ ,index 2)))
X
X ;;
X;;;;;; Cache No's
X ;;
X
X(zl:defsubst symbol-cache-no (symbol mask)
X (logand (si:%pointer symbol) mask))
X
X(compiler:defoptimizer (symbol-cache-no fold-symbol-cache-no) (form)
X (if (and (constantp (cadr form))
X (constantp (caddr form)))
X `(load-time-eval (logand (si:%pointer ,(cadr form)) ,(caddr form)))
X form))
X
X(defmacro object-cache-no (object mask)
X `(logand (si:%pointer ,object) ,mask))
X
X ;;
X;;;;;; printing-random-thing-internal
X ;;
X(defun printing-random-thing-internal (thing stream)
X (format stream "~O" (si:%pointer thing)))
X
X ;;
X;;;;;; function-arglist
X ;;
X;;;
X;;; This is hard, I am sweating.
X;;;
X(defun function-arglist (function) (zl:arglist function t))
X
X(defun function-pretty-arglist (function) (zl:arglist function))
X
X;; Unfortunately, this doesn't really work...
X(defun set-function-pretty-arglist (function new-value)
X (ignore function new-value))
X
X;; But this does...
X(zl:advise zl:arglist
X :after
X pcl-patch-to-arglist
X ()
X (let ((function (car zl:arglist))
X (discriminator nil))
X (when (and (symbolp function)
X (setq discriminator (discriminator-named function)))
X (setq values (list (discriminator-pretty-arglist discriminator))))))
X
X
X ;;
X;;;;;;
X ;;
X
X(defun record-definition (name type &rest args)
X (case type
X (method (si:record-source-file-name name 'zl:defun t))
X (class ())))
X
X(defun compile-time-define (type name &rest ignore)
X (case type
X (defun (compiler:file-declare name 'zl:def 'zl:ignore))))
X
X ;;
X;;;;;; Environment support and Bug-Fixes
X ;;
X;;; Some VERY basic environment support for the 3600, and some bug fixes and
X;;; improvements to 3600 system utilities. These may need some work before
X;;; they will work in release 7.
X;;;
X(eval-when (load eval)
X (setf
X (get 'defmeth 'zwei:definition-function-spec-type) 'defun
X ;(get 'defmeth 'zwei:definition-function-spec-finder-template) '(0 1)
X (get 'ndefstruct 'zwei:definition-type-name) "Class"
X (get 'ndefstruct 'zwei:definition-function-spec-finder-template) '(0 1))
X )
X
X;;; These changes let me dump instances of PCL metaclasses in files, and also arrange
X;;; for the #S syntax to work for PCL instances.
X;;; si:dump-object and si:get-defstruct-constructor-macro-name get "advised".
X;;; Actually the advice is done by hand since it doesn't get compiled otherwise.
X
X(defvar *old-dump-object*)
X(defun patched-dump-object (object stream)
X (if (or (si:send si:*bin-dump-table* :get-hash object)
X (not (and (%instancep object)
X (class-standard-constructor (class-of object)))))
X (funcall *old-dump-object* object stream)
X ;; Code pratically copied from dump-instance.
X (let ((index (si:enter-table object stream t t)))
X (si:dump-form-to-eval
X (cons (class-standard-constructor (class-of object))
X (iterate
X ((slot in (all-slots object) by cddr)
X (val in (cdr (all-slots object)) by cddr))
X (collect (make-keyword slot))
X (collect `',val)))
X stream)
X (si:finish-enter-table object index))))
X
X(unless (boundp '*old-dump-object*)
X (setf *old-dump-object* (symbol-function 'si:dump-object)
X (symbol-function 'si:dump-object) 'patched-dump-object))
X
X(defvar *old-get-defstruct-constructor-macro-name*)
X(defun patched-get-defstruct-constructor-macro-name (structure)
X (let ((class (class-named structure t)))
X (if class
X (class-standard-constructor class)
X (funcall *old-get-defstruct-constructor-macro-name* structure))))
X
X
X(unless (boundp '*old-get-defstruct-constructor-macro-name*)
X (setf *old-get-defstruct-constructor-macro-name*
X (symbol-function 'si:get-defstruct-constructor-macro-name)
X (symbol-function 'si:get-defstruct-constructor-macro-name)
X 'patched-get-defstruct-constructor-macro-name))
X
END_OF_FILE
if test 8740 -ne `wc -c <'3600-low.l'`; then
echo shar: \"'3600-low.l'\" unpacked with wrong size!
fi
# end of '3600-low.l'
fi
if test -f 'co-macros.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'co-macros.l'\"
else
echo shar: Extracting \"'co-macros.l'\" \(7103 characters\)
sed "s/^X//" >'co-macros.l' <<'END_OF_FILE'
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; File: co-macros.l
X; RCS: $Revision: 1.1 $
X; SCCS: %A% %G% %U%
X; Description: Macros used by Interface For CommonObjects
X; with co parser in CL.
X; Author: James Kempf, HP/DCC
X; Created: 31-Jul-86
X; Modified: 11-Mar-87 22:22:44 (James Kempf)
X; Language: Lisp
X; Package: COMMON-OBJECTS
X; Status: Distribution
X;
X; (c) Copyright 1987, HP Labs, all rights reserved.
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; Copyright (c) 1987 Hewlett-Packard Corporation. All rights reserved.
X;
X; Use and copying of this software and preparation of derivative works based
X; upon this software are permitted. Any distribution of this software or
X; derivative works must comply with all applicable United States export
X; control laws.
X;
X; This software is made available AS IS, and Hewlett-Packard Corporation makes
X; no warranty about the software, its performance or its conformity to any
X; specification.
X;
X; Suggestions, comments and requests for improvement may be mailed to
X; aiws@hplabs.HP.COM
X
X;;;-*-Mode:LISP; Package:(CO (PCL LISP)); Base:10; Syntax: Common-lisp-*-
X;;;
X;;; *************************************************************************
X;;; Copyright (c) 1985 Xerox Corporation. All rights reserved.
X;;;
X;;; Use and copying of this software and preparation of derivative works
X;;; based upon this software are permitted. Any distribution of this
X;;; software or derivative works must comply with all applicable United
X;;; States export control laws.
X;;;
X;;; This software is made available AS IS, and Xerox Corporation makes no
X;;; warranty about the software, its performance or its conformity to any
X;;; specification.
X;;;
X;;; Any person obtaining a copy of this software is requested to send their
X;;; name and post office or electronic mail address to:
X;;; CommonLoops Coordinator
X;;; Xerox Artifical Intelligence Systems
X;;; 2400 Hanover St.
X;;; Palo Alto, CA 94303
X;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
X;;;
X;;; Suggestions, comments and requests for improvements are also welcome.
X;;; *************************************************************************
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; Preliminaries
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;;The CommonObjects interface is in the COMMON-OBJECTS package. We need
X;;; both PCL and the CommonObjects parser, which is in the
X;; COMMON-OBJECTS-PARSER package. Note that PCL is assumed to be
X;; loaded.
X
X(provide "co-macros")
X
X(in-package 'common-objects :nicknames '(co) :use '(lisp pcl walker))
X
X;;Export these symbols. They are the only ones which clients should see.
X
X(export
X '(
X make-instance
X define-type
X define-method
X call-method
X apply-method
X assignedp
X undefine-type
X rename-type
X undef Artifical Intelligence Systems
X;;; 2400 Hanovration-p
X send?
X instance
X import-specialized-functions
X )
X)
X
X;;Need PCL and patches
X
X(require "pcl")
X(require "pcl-patches")
X
X;;Need the parser
X
X(require "co-parse")
X
X;;Use the parser's package
X
X(use-package 'co-parser)
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; Constant Definition
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;;Need this flag to indicate that an instance variable is uninitialized.
X
X(defconstant $UNINITIALIZED-VARIABLE-FLAG 'LISP::*UNDEFINED*)
X
X;;Offsets of important things in instances.
X;;Location of class object.
X
X(defconstant $CLASS-OBJECT-INDEX 0)
X
X;;Location of pointer to self.
X
X(defconstant $SELF-INDEX 1)
X
X;;Starting index of parents.
X
X(defconstant $START-OF-PARENTS 2)
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; Special Variable Definition
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;*special-functions-list*-Holds a list of uninterned symbols for TYPE-OF,
X;; TYPEP, EQL, EQUAL, and EQUALP. These symbols have their function cells
X;; bound to special functions which use CommonObjects messaging if the
X;; argument is a CommonObjects object.
X
X(defvar *special-functions-list*
X (list
X (cons ':type-of (make-symbol "TYPE-OF"))
X (cons ':typep (make-symbol "TYPEP"))
X (cons ':eql (make-symbol "EQL"))
X (cons ':equal (make-symbol "EQUAL"))
X (cons ':equalp (make-symbol "EQUALP"))
X )
X)
X
X;;*universal-methods*-List of universal methods
X
X(defvar *universal-methods*
X '(
X :init
X :initialize
X :print
X :describe
X :eql
X :equal
X :equalp
X :typep
X :copy
X :copy-instance
X :copy-state
X )
X)
X
X;;*universal-method-selectors*-List of selectors for universal
X;; methods
X
X(defvar *universal-method-selectors* NIL)
X
X;;*keyword-standin-package*-Package for interning methods as functions.
X;; CommonObjects "encourages" the use of keywords as method names,
X;; but not all CL's allow keyword symbol function cells to be
X;; occupied.
X
X(eval-when (compile load eval)
X (defvar *keyword-standin-package*
X (or (find-package 'keyword-standin) (make-package 'keyword-standin))
X )
X)
X
X;;;Unuse the lisp package in the keyword-standin package, to
X;;; avoid conflicts with named functions.
X
X(unuse-package 'lisp *keyword-standin-package*)
X
X;;*special-method-symbols*-List of special method symbols which
X;; shouldn't go into the keyword-standin package, paired with
X;; their method names.
X
X(defvar *special-method-symbols*
X (list
X (cons ':print 'print-instance)
X )
X)
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; Support for Using Keywords as Method Names
X;
X; These macros and functions translate keyword method names into
X; names in a package. Some Common Lisps do allow keyword symbols
X; to have an associated function, others don't. Rather than
X; differentiating, a single package, KEYWORD-STANDIN, is used
X; for method symbols which are keywords.
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;special-keyword-p-Return T if the keyword is a special method
X;; symbol.
X
X(defmacro special-keyword-p (keyword)
X `(assoc ,keyword *special-method-symbols* :test #'eq)
X
X) ;end special-keyword-p
X
X;;keyword-standin-special-Return the special symbol for this
X;; keyword.
X
X(defmacro keyword-standin-special (keyword)
X `(cdr (assoc ,keyword *special-method-symbols* :test #'eq))
X
X) ;end keyword-standin-special
X
X;;special-method-p-Return T if the symbol is a special method
X;; symbol.
X
X(defmacro special-method-p (symbol)
X `(rassoc ,symbol *special-method-symbols* :test #'eq)
X
X) ;end special-method-p
X
X;;unkeyword-standin-special-Return the keyword for this
X;; special method
X
X(defmacro unkeyword-standin-special (symbol)
X `(car (rassoc ,symbol *special-method-symbols* :test #'eq))
X
X) ;end unkeyword-standin-special
X
X;;keyword-standin-Get a standin symbol for a keyword
X
X;;; end of co-macros.l ;;;;;
X
END_OF_FILE
if test 7103 -ne `wc -c <'co-macros.l'`; then
echo shar: \"'co-macros.l'\" unpacked with wrong size!
fi
# end of 'co-macros.l'
fi
if test -f 'co-prof.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'co-prof.l'\"
else
echo shar: Extracting \"'co-prof.l'\" \(5412 characters\)
sed "s/^X//" >'co-prof.l' <<'END_OF_FILE'
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; File: co-prof.l
X; SCCS: %A% %G% %U%
X; Description: Profiling For COOL
X; Author: James Kempf, HP/DCC
X; Created: 10-Feb-87
X; Modified: 25-Feb-87 10:51:31 (James Kempf)
X; Language: Lisp
X; Package: TEST
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X(in-package 'test)
X
X(require "co")
X
X(use-package 'co)
X
X(require "co-profmacs")
X
X;;Collection Variable for Test Functions
X
X(defvar *function-symbols* NIL)
X
X;;Default names for output file and output messages.
X;; Can be overridden before this file is loaded.
X
X(defvar *output-file-name* "runprof.out")
X(defvar *definition-message* "COOL Definition Results")
X(defvar *redefinition-message* "COOL Redefinition Results")
X
X;;Run everything compiled so that best
X;; times are obtained.
X
X;;Measurement of Type Definition
X
X;;Warmup
X
X(do-type-definition NIL 0 0)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;No instance variables and no parents
X
X(do-type-definition T 0 0)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;One instance variable and no parents
X
X(do-type-definition T 1 0)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;Two instance variables and no parents
X
X(do-type-definition T 2 0)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;Three instance variables and no parents
X
X(do-type-definition T 3 0)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;No variables and one parent
X
X(do-type-definition T 0 1)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;No variables and two parents
X
X(do-type-definition T 0 2)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;No variables and three parents
X
X(do-type-definition T 0 3)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;Measure Instance Creation
X
X;;Warmup
X
X(do-instance-creation NIL 0 0)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;No instance variables and no parents
X
X(do-instance-creation T 0 0)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;One instance variable and no parents
X
X(do-instance-creation T 1 0)
X(funcall (first *function-symbols*))
X
X;;Two instance variables and no parents
X
X(do-instance-creation T 2 0)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;Three instance variables and no parents
X
X(do-instance-creation T 3 0)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;No variables and one parent
X
X(do-instance-creation T 0 1)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;No variables and two parents
X
X(do-instance-creation T 0 2)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;No variables and three parents
X
X(do-instance-creation T 0 3)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;Measurement of Method Definition
X
X(do-method-definition NIL 0 temp1)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;So that new symbols will be generated
X
X(setf *list-of-method-symbols* NIL)
X
X;;No predefined method
X
X(do-method-definition T 0 temp1)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;Measure method invocation
X
X(do-messaging T 1 temp1)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;One predefined method
X
X(do-method-definition T 1 temp2)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;Measure method invocation
X
X(do-messaging T 2 temp1 temp2)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;Two predefined methods
X
X(do-method-definition T 2 temp3)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;Measure method invocation
X
X(do-messaging T 3 temp1 temp2 temp3)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;Three predefined methods
X
X(do-method-definition T 3 temp4)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;Measure method invocation
X
X(do-messaging T 4 temp1 temp2 temp3 temp4)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;Method Invocation and Inheritence
X
X(do-inherited-messaging NIL 0 g0f)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;No inheritence
X
X(do-inherited-messaging T 0 g0f)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X
X;;One level
X
X(do-inherited-messaging T 1 g1f)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X
X;;Two levels
X
X(do-inherited-messaging T 2 g2f)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X
X;;Three levels
X
X(do-inherited-messaging T 3 g3f)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X
X;;Dump out the results
X
X(print-results *output-file-name* *definition-message*)
X
X;;Run Everything Again
X
X(dolist (l (reverse *function-symbols*))
X (funcall l)
X)
X
X;;And dump results
X
X(print-results *output-file-name* *redefinition-message*)
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X(provide "co-prof")
X
END_OF_FILE
if test 5412 -ne `wc -c <'co-prof.l'`; then
echo shar: \"'co-prof.l'\" unpacked with wrong size!
fi
# end of 'co-prof.l'
fi
if test -f 'co-sfun.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'co-sfun.l'\"
else
echo shar: Extracting \"'co-sfun.l'\" \(5643 characters\)
sed "s/^X//" >'co-sfun.l' <<'END_OF_FILE'
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; File: co-sfun.l
X; RCS: $Revision: 1.1 $
X; SCCS: %A% %G% %U%
X; Description: Override System Functions
X; Author: James Kempf
X; Created: March 10, 1987
X; Modified: March 10, 1987 13:31:39 (Roy D'Souza)
X; Language: Lisp
X; Package: COMMON-OBJECTS
X; Status: Distribution
X;
X; (c) Copyright 1987, HP Labs, all rights reserved.
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; Copyright (c) 1987 Hewlett-Packard Corporation. All rights reserved.
X;
X; Use and copying of this software and preparation of derivative works based
X; upon this software are permitted. Any distribution of this software or
X; derivative works must comply with all applicable United States export
X; control laws.
X;
X; This software is made available AS IS, and Hewlett-Packard Corporation makes
X; no warranty about the software, its performance or its conformity to any
X; specification.
X;
X; Suggestions, comments and requests for improvement may be mailed to
X; aiws@hplabs.HP.COM
X
X;;;-*-Mode:LISP; Package:(CO (PCL LISP)); Base:10; Syntax: Common-lisp-*-
X;;;
X;;; *************************************************************************
X;;; Copyright (c) 1985 Xerox Corporation. All rights reserved.
X;;;
X;;; Use and copying of this software and preparation of derivative works
X;;; based upon this software are permitted. Any distribution of this
X;;; software or derivative works must comply with all applicable United
X;;; States export control laws.
X;;;
X;;; This software is made available AS IS, and Xerox Corporation makes no
X;;; warranty about the software, its performance or its conformity to any
X;;; specification.
X;;;
X;;; Any person obtaining a copy of this software is requested to send their
X;;; name and post office or electronic mail address to:
X;;; CommonLoops Coordinator
X;;; Xerox Artifical Intelligence Systems
X;;; 2400 Hanover St.
X;;; Palo Alto, CA 94303
X;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
X;;;
X;;; Suggestions, comments and requests for improvements are also welcome.
X;;; *************************************************************************
X
X(in-package 'common-objects :nicknames '(co) :use '(lisp pcl walker))
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; Overridden System Functions
X;
X; The semantics of CommonObjects requires that the Lisp functions EQL, EQUAL,
X; EQUALP, and TYPEP go through the corresponding universial methods rather
X; than having their default behavior, and that TYPE-OF return the CommonObjects
X; type. To avoid circularity problems, these functions are defined as
X; special, non-interned symbols, and are SHADOWING-IMPORTED into the
X; package by the user if this behavior is desired. Note, however,
X; that the default Lisp symbols can't be specialized because otherwise
X; circularity problems in PCL functions like CLASS-OF may occur. An application
X; wanting to use them must call the function IMPORT-SPECIALIZED-FUNCTIONS
X; (below) to get access.
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X(eval-when (load eval)
X
X (progn
X
X ;;For TYPE-OF
X
X (setf
X (symbol-function
X (cdr (assoc ':type-of *special-functions-list* :test #'eq))
X )
X (function (lambda (object) (class-name (class-of object))))
X
X ) ;setf
X
X ;;For TYPEP
X
X (setf
X (symbol-function
X (cdr (assoc ':typep *special-functions-list* :test #'eq))
X )
X (function
X (lambda (object type)
X (cond
X
X ;;Object is a CommonObjects instance
X
X (
X (instancep object)
X (keyword-standin::typep object type)
X )
X
X ;;Type is a CommonObjects type
X
X (
X (member type (defined-classes))
X NIL
X )
X
X ;;Default
X
X (
X T
X (lisp::typep object type)
X )
X
X ) ;cond
X )
X )
X ) ;setf
X
X ;;For EQL
X
X (setf
X (symbol-function
X (cdr (assoc ':eql *special-functions-list* :test #'eq))
X )
X (function
X (lambda (object1 object2)
X (if (instancep object1)
X (keyword-standin::eql object1 object2)
X (lisp::eql object1 object2)
X )
X )
X )
X ) ;setf
X
X ;;For EQUAL
X
X (setf
X (symbol-function
X (cdr (assoc ':equal *special-functions-list* :test #'eq))
X )
X (function
X (lambda (object1 object2)
X (if (instancep object1)
X (keyword-standin::equal object1 object2)
X (lisp::equal object1 object2)
X )
X )
X )
X ) ;setf
X
X ;;For EQUALP
X
X (setf
X (symbol-function
X (cdr (assoc ':equalp *special-functions-list* :test #'eq))
X )
X (function
X (lambda (object1 object2)
X (if (instancep object1)
X (keyword-standin::equalp object1 object2)
X (lisp::equalp object1 object2)
X )
X )
X )
X ) ;setf
X
X ) ;progn
X
X) ;eval-when
X
X;;import-specialized-functions-Import the specialized functions into
X;; the current package. This will override the Lisp package
X;; symbols.
X
X(defmacro import-specialized-functions ()
X
X (let
X ( (import-list NIL) )
X
X `(shadowing-import
X ',(dolist (p *special-functions-list* import-list)
X (push (cdr p) import-list)
X )
X
X )
X )
X
X) ;end import-specialized-functions
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X
X
END_OF_FILE
if test 5643 -ne `wc -c <'co-sfun.l'`; then
echo shar: \"'co-sfun.l'\" unpacked with wrong size!
fi
# end of 'co-sfun.l'
fi
if test -f 'co-test.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'co-test.l'\"
else
echo shar: Extracting \"'co-test.l'\" \(6054 characters\)
sed "s/^X//" >'co-test.l' <<'END_OF_FILE'
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; File: co-test.l
X; RCS: $Revision: 1.1 $
X; SCCS: %A% %G% %U%
X; Description: Portable Test Macro for Testing COOL
X; Author: James Kempf, HP/DCC
X; Created: 24-Feb-87
X; Modified: 25-Feb-87 08:45:43 (James Kempf)
X; Language: Lisp
X; Package: PCL
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; Copyright (c) 1987 Hewlett-Packard Corporation. All rights reserved.
X;
X; Use and copying of this software and preparation of derivative works based
X; upon this software are permitted. Any distribution of this software or
X; derivative works must comply with all applicable United States export
X; control laws.
X;
X; This software is made available AS IS, and Hewlett-Packard Corporation makes
X; no warranty about the software, its performance or its conformity to any
X; specification.
X;
X; Suggestions, comments and requests for improvement may be mailed to
X; aiws@hplabs.HP.COM
X
X;;;-*- Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
X;;;
X;;; *************************************************************************
X;;; Copyright (c) 1985 Xerox Corporation. All rights reserved.
X;;;
X;;; Use and copying of this software and preparation of derivative works
X;;; based upon this software are permitted. Any distribution of this
X;;; software or derivative works must comply with all applicable United
X;;; States export control laws.
X;;;
X;;; This software is made available AS IS, and Xerox Corporation makes no
X;;; warranty about the software, its performance or its conformity to any
X;;; specification.
X;;;
X;;; Any person obtaining a copy of this software is requested to send their
X;;; name and post office or electronic mail address to:
X;;; CommonLoops Coordinator
X;;; Xerox Artifical Intelligence Systems
X;;; 2400 Hanover St.
X;;; Palo Alto, CA 94303
X;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
X;;;
X;;; Suggestions, comments and requests for improvements are also welcome.
X;;; *************************************************************************
X;;;
X;;; Testing code. Note: This file is derived from the PCL file test.l and
X;;; removes some of the PCL specific stuff from the test macro.
X
X(in-package 'pcl)
X(use-package 'lisp)
X
X(require "pcl")
X
X(export
X '(
X do-test
X )
X)
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; Catching Errors
X;
X; Since CLtL defines no portable way of catching errors, most system
X; implementors have done their own. Certainly it would be possible
X; to code a portable error catcher, but the complexity involved
X; (catching errors at macroexpand time as well, etc.) is considerable.
X; As a stopgap, the *WITHOUT-ERRORS* special is provided for people
X; bringing up COOL on a new system to add their system's special error
X; catching code. It is taken from the original PCL test file.
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;Other info needed for exception handling
X
X#+HP (require "exception")
X
X(defvar *without-errors*
X (or #+Symbolics #'(lambda (form)
X `(multiple-value-bind (.values. .errorp.)
X (si::errset ,form nil)
X (declare (ignore .values.))
X .errorp.))
X #+Xerox #'(lambda (form)
X `(xcl:condition-case (progn ,form nil)
X (error () t)))
X
X #+HP #'(lambda (form)
X `(extn:when-error
X (progn ,form NIL)
X T
X )
X )
X nil
X )
X
X) ;defvar
X
X;;without-errors-This macro generates code for error testing
X
X(defmacro without-errors (&body body)
X
X (if *without-errors*
X (funcall *without-errors* `(progn ,@body))
X (error "Calling WITHOUT-ERRORS when *without-errors* is nil.")
X )
X
X
X) ;without-errors
X
X;;with-return-value-Set up each form in BODY to match return value
X
X(defmacro with-return-value (form return-value)
X
X ;;Note the use of full qualification on EQUALP
X ;; to avoid problems with redefinition from CO
X
X `(lisp::equalp ',return-value ,form)
X
X) ;with-return-value
X
X;;do-test-Execute BODY according to the options list
X
X(defmacro do-test (name&options &body body)
X (let
X (
X (name (if (listp name&options) (car name&options) name&options))
X (options (if (listp name&options) (cdr name&options) ()))
X (code NIL)
X )
X
X ;;Bind the options from keywords
X
X (keyword-bind
X (
X (should-error nil)
X (return-value nil)
X )
X
X options
X
X ;;Check if errors should be caught and can be
X
X (cond
X
X ;;Errors can't be caught in this Lisp, so don't do it
X
X (
X (and should-error (null *without-errors*))
X `(format t
X "~&Skipping testing ~A,~%~
X because can't ignore errors in this Common Lisp."
X ',name
X )
X )
X
X ;;Generate code for test. If the return value was supplied
X ;; as an option, check if the return values are the same.
X ;; Note the use of LISP::EQUALP. This is because CommonObjects
X ;; redefines EQUALP.
X
X (t
X `(progn
X (format t "~&Testing ")
X (format t ,name)
X (format t "... ")
X ,@(dolist (form body (reverse code))
X (push
X `(if
X ,(cond
X (
X should-error
X `(without-errors ,form)
X )
X (
X return-value
X `(with-return-value ,@form)
X )
X (
X T
X `(progn ,form)
X )
X )
X (format T "~&OK: ~S~%" ',form)
X (format T "~&FAILED: ~S~%" ',form)
X )
X code
X
X ) ;push
X ) ;dolist
X
X ) ;progn
X )
X ) ;cond
X
X ) ;keyword-bind
X
X ) ;let
X
X) ;do-test
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X(provide "co-test")
X
END_OF_FILE
if test 6054 -ne `wc -c <'co-test.l'`; then
echo shar: \"'co-test.l'\" unpacked with wrong size!
fi
# end of 'co-test.l'
fi
if test -f 'dfun-templ.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'dfun-templ.l'\"
else
echo shar: Extracting \"'dfun-templ.l'\" \(7420 characters\)
sed "s/^X//" >'dfun-templ.l' <<'END_OF_FILE'
X;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
X;;;
X;;; *************************************************************************
X;;; Copyright (c) 1985 Xerox Corporation. All rights reserved.
X;;;
X;;; Use and copying of this software and preparation of derivative works
X;;; based upon this software are permitted. Any distribution of this
X;;; software or derivative works must comply with all applicable United
X;;; States export control laws.
X;;;
X;;; This software is made available AS IS, and Xerox Corporation makes no
X;;; warranty about the software, its performance or its conformity to any
X;;; specification.
X;;;
X;;; Any person obtaining a copy of this software is requested to send their
X;;; name and post office or electronic mail address to:
X;;; CommonLoops Coordinator
X;;; Xerox Artifical Intelligence Systems
X;;; 2400 Hanover St.
X;;; Palo Alto, CA 94303
X;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
X;;;
X;;; Suggestions, comments and requests for improvements are also welcome.
X;;; *************************************************************************
X;;;
X
X(in-package 'pcl)
X
X
X;;;
X;;; A caching discriminating function looks like:
X;;; (lambda (arg-1 arg-2 arg-3 &rest rest-args)
X;;; (prog* ((class-1 (class-of arg-1))
X;;; (class-2 (class-of arg-2))
X;;; method-function)
X;;; (and (cached-method method-function CACHE MASK class-1 class-2)
X;;; (go hit))
X;;; miss
X;;; (setq method-function
X;;; (cache-method DISCRIMINATOR
X;;; (lookup-method-function DISCRIMINATOR
X;;; class-1
X;;; class-2)))
X;;; hit
X;;; (if method-function
X;;; (return (apply method-function arg-1 arg-2 arg-3 rest-args))
X;;; (return (no-matching-method DISCRIMINATOR)))))
X;;;
X;;; The upper-cased variables are the ones which are lexically bound.
X
X;;; There is a great deal of room to play here. This open codes the
X;;; test to see if the instance is iwmc-class-p. Only if it isn't is
X;;; there a function call to class-of. This is done because we only have
X;;; a default implementation of make-discriminating-function, we don't
X;;; have one which is specific to discriminator-class DISCRIMINATOR and
X;;; meta-class CLASS.
X;;;
X;;; Of course a real implementation of CommonLoops wouldn't even do a
X;;; real function call to get to the discriminating function.
X
X(eval-when (compile load eval)
X
X(defun default-make-class-of-form-fn (arg)
X `(if (iwmc-class-p ,arg)
X (class-of--class ,arg)
X (class-of ,arg)))
X
X(defvar *make-class-of-form-fn* #'default-make-class-of-form-fn)
X
X(define-function-template caching-discriminating-function
X (required restp
X specialized-positions
X lookup-function)
X '(.DISCRIMINATOR. .CACHE. .MASK.)
X (let* ((args (iterate ((i from 0 below required))
X (collect (make-symbol (format nil "Disc-Fn-Arg ~D" i)))))
X (class-bindings
X (iterate ((i from 0 below required)
X (ignore in specialized-positions))
X (if (member i specialized-positions)
X (collect
X (list (make-symbol (format nil "Class of ARG ~D" i))
X (funcall *make-class-of-form-fn* (nth i args))))
X (collect nil))))
X (classes (remove nil (mapcar #'car class-bindings)))
X (method-function-var (make-symbol "Method Function"))
X (rest-arg-var (and restp (make-symbol "Disc-Fn-&Rest-Arg"))))
X `(function
X (lambda (,@args ,@(and rest-arg-var (list '&rest rest-arg-var)))
X (prog (,@(remove nil class-bindings) ,method-function-var)
X (and (cached-method ,method-function-var .CACHE. .MASK. ,@classes)
X (go hit))
X ;miss
X (setq ,method-function-var
X (cache-method .CACHE.
X .MASK.
X (,lookup-function .DISCRIMINATOR.
X ,@(mapcar #'car
X class-bindings))
X ,@classes))
X hit
X (if ,method-function-var
X (return ,(if restp
X `(apply ,method-function-var
X ,@args
X ,rest-arg-var)
X `(funcall ,method-function-var ,@args)))
X (no-matching-method .DISCRIMINATOR.)))))))
X)
X
X(eval-when (compile)
X(defmacro pre-make-caching-discriminating-functions (specs)
X `(progn . ,(iterate ((spec in specs))
X (collect `(pre-make-templated-function-constructor
X caching-discriminating-function
X ,@spec))))))
X
X(eval-when (load)
X (pre-make-caching-discriminating-functions
X ((2 NIL (0 1) LOOKUP-MULTI-METHOD)
X (4 NIL (0) LOOKUP-CLASSICAL-METHOD)
X (5 NIL (0) LOOKUP-CLASSICAL-METHOD)
X (1 T (0) LOOKUP-CLASSICAL-METHOD)
X (3 NIL (0 1) LOOKUP-MULTI-METHOD)
X (4 T (0) LOOKUP-CLASSICAL-METHOD)
X (3 T (0) LOOKUP-CLASSICAL-METHOD)
X (3 NIL (0) LOOKUP-CLASSICAL-METHOD)
X (1 NIL (0) LOOKUP-CLASSICAL-METHOD)
X (2 NIL (0) LOOKUP-CLASSICAL-METHOD))))
X
X ;;
X;;;;;;
X ;;
X
X(eval-when (compile load eval)
X
X(define-function-template checking-discriminating-function
X (required restp defaultp checks)
X `(discriminator method-function default-function
X ,@(make-checking-discriminating-function-1 checks))
X (let* ((arglist (make-discriminating-function-arglist required restp)))
X `(function
X (lambda ,arglist
X (declare (optimize (speed 3) (safety 0)))
X discriminator default-function ;ignorable
X (if (and ,@(iterate ((check in
X (make-checking-discriminating-function-1
X checks))
X (arg in arglist))
X (when (neq check 'ignore)
X (collect
X `(memq ,check
X (let ((.class. (class-of ,arg)))
X (get-slot--class .class.
X 'class-precedence-list)))))))
X ,(if restp
X `(apply method-function ,@(remove '&rest arglist))
X `(funcall method-function ,@arglist))
X ,(if defaultp
X (if restp
X `(apply default-function ,@(remove '&rest arglist))
X `(funcall default-function ,@arglist))
X `(no-matching-method discriminator)))))))
X
X(defun make-checking-discriminating-function-1 (check-positions)
X (iterate ((pos in check-positions))
X (collect (if (null pos) 'ignore (intern (format nil "Check ~D" pos))))))
X
X)
X
X(eval-when (compile)
X(defmacro pre-make-checking-discriminating-functions (specs)
X `(progn . ,(iterate ((spec in specs))
X (collect `(pre-make-templated-function-constructor
X checking-discriminating-function
X ,@spec))))))
X
X(eval-when (load)
X (pre-make-checking-discriminating-functions ((3 NIL NIL (0 1))
X (7 NIL NIL (0 1))
X (5 NIL NIL (0 1))
X (3 NIL NIL (0 NIL 2))
X (6 NIL NIL (0))
X (5 NIL NIL (0))
X (4 T NIL (0))
X (3 T NIL (0))
X (1 T NIL (0))
X (4 NIL NIL (0))
X (3 NIL NIL (0))
X (3 NIL T (0 1))
X (2 NIL T (0))
X (5 NIL T (0 1))
X (1 T T (0))
X (1 NIL T (0))
X (2 NIL T (0 1))
X (3 NIL T (0))
X (2 T T (0))
X (6 NIL T (0 1))
X (3 NIL T (0 NIL 2))
X (4 NIL T (0 1))
X (4 NIL T (0))
X (5 NIL T (0))
X (1 NIL NIL (0))
X (2 NIL NIL (0)))))
X
END_OF_FILE
if test 7420 -ne `wc -c <'dfun-templ.l'`; then
echo shar: \"'dfun-templ.l'\" unpacked with wrong size!
fi
# end of 'dfun-templ.l'
fi
if test -f 'pcl-patches.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'pcl-patches.l'\"
else
echo shar: Extracting \"'pcl-patches.l'\" \(6462 characters\)
sed "s/^X//" >'pcl-patches.l' <<'END_OF_FILE'
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; File: pcl-patches.l
X; RCS: $Revision: 1.1 $
X; SCCS: %A% %G% %U%
X; Description: Patches to Released PCL so CommonObjects works
X; Author: James Kempf, HP/DCC
X; Created: 11-Nov-86
X; Modified: 5-Mar-87 08:04:02 (James Kempf)
X; Language: Lisp
X; Package: PCL
X; Status: Distribution
X;
X; (c) Copyright 1987, HP Labs, all rights reserved.
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; Copyright (c) 1987 Hewlett-Packard Corporation. All rights reserved.
X;
X; Use and copying of this software and preparation of derivative works based
X; upon this software are permitted. Any distribution of this software or
X; derivative works must comply with all applicable United States export
X; control laws.
X;
X; This software is made available AS IS, and Hewlett-Packard Corporation makes
X; no warranty about the software, its performance or its conformity to any
X; specification.
X;
X; Suggestions, comments and requests for improvement may be mailed to
X; aiws@hplabs.HP.COM
X
X;;Need the PCL module
X
X(require "pcl")
X
X(in-package 'pcl)
X(use-package 'lisp)
X
X;;These symbols are needed by CommonObjects
X
X(export
X '(
X print-instance
X make-specializable
X rename-class
X call-next-method
X expand-with-make-entries
X method-type-specifiers
X method-arglist
X )
X)
X
X;;Note-Every implementation of CL will need to add the
X;; check for nonatomic type specifiers.
X
X#+HP(setq *class-of*
X '(lambda (x)
X (cond ((%instancep x)
X (%instance-class-of x))
X ;; Ports of PCL should define the rest of class-of
X ;; more meaningfully. Because of the underspecification
X ;; of type-of this is the best that I can do.
X ((null x)
X (class-named 'null))
X ((stringp x)
X (class-named 'string))
X ((characterp x)
X (class-named 'character))
X (t
X (or (class-named (atom-type-of (type-of x)) t)
X (error "Can't determine class of ~S." x)
X ))
X )
X )
X)
X
X#+ExCL(eval-when (load)
X (setq *class-of*
X '(lambda (x)
X (or (and (%instancep x)
X (%instance-class-of x))
X ;(%funcallable-instance-p x)
X (and (stringp x) (class-named 'string))
X (class-named (type-of x) t)
X (error "Can't determine class of ~S." x)))
X )
X
X)
X
X;;Now arrange things so CLASS-OF gets recompiled when this file gets
X;; loaded
X
X#-KCL(eval-when (load eval)
X
X (recompile-class-of)
X
X)
X
X;;atom-type-of-Return principle type. This is the first
X;; item on the type specifier list, or specifier itself,
X;; if the specifier is atomic.
X
X(defun atom-type-of (x)
X
X (if (listp x)
X (car x)
X x
X )
X
X) ;end atom-type-of
X
X;;
X;;
X;;
X;;
X;; Default print-instance method
X;;
X;;
X;;
X
X(defmeth print-instance (instance stream depth)
X (printing-random-thing (instance stream)
X (format stream "instance ??")))
X
X;;;New for CO
X
X
X;;rename-class-Find the class object named old-name and rename to
X;; new-name
X
X(defmeth rename-class ((old-name symbol) (new-name symbol))
X
X (rename-class (class-named old-name) new-name)
X
X) ;end rename-class
X
X
X;;rename-class-Change the name of the essential class's name to name
X
X(defmeth rename-class ((class essential-class) (name symbol))
X
X (let
X (
X (old-name (class-name class))
X )
X
X
X (setf (class-name class) name)
X
X ;;Needed to be sure the naming hash table is OK
X
X (setf (class-named name) class)
X (setf (class-named old-name) NIL)
X name
X )
X
X) ;end rename-class
X
X
X;;
X;;
X;;
X;; From class-prot.l
X;;
X;;
X;;
X
X;;JAK 2/15/86 Additional bug. OPTIMIZE-GET-SLOT and OPTIMIZE-SETF-OF
X;; GET-SLOT didn't seem to be getting called. This version calls
X;; them. NOTE-this has been added to CLASS-PROT.L so that the
X;; optimization functions get called in the kernel as well.
X
X(defun expand-with-slots
X (proto-discriminator proto-method first-arg env body)
X (ignore proto-discriminator)
X (let ((entries (expand-with-make-entries proto-method first-arg))
X (gensyms ()))
X (dolist (arg first-arg)
X (push (list (if (listp arg) (car arg) arg)
X (gensym))
X gensyms))
X `(let ,(mapcar #'reverse gensyms)
X ,(walk-form (cons 'progn body)
X :environment env
X :walk-function
X #'(lambda (form context &aux temp)
X (cond ((and (symbolp form)
X (eq context ':eval)
X (null (variable-lexical-p form))
X (null (variable-special-p form))
X (setq temp (assq form entries)))
X (if (car (cddddr temp)) ;use slot-value?
X (optimize-get-slot
X ;;;; proto-method ;;the method object ;rds 3/8
X (third temp) ;;the class object
X `(get-slot ,(cadr (assq (cadr temp) gensyms))
X ',(slotd-name (cadddr temp)))
X )
X `(,(slotd-accessor (cadddr temp))
X ,(cadr (assq (cadr temp) gensyms)))))
X ((and (listp form)
X (or (eq (car form) 'setq)
X (eq (car form) 'setf)))
X (cond ((cdddr form)
X (cons 'progn
X (iterate ((pair on (cdr form) by cddr))
X (collect (list (car form)
X (car pair)
X (cadr pair))))))
X ((setq temp (assq (cadr form) entries))
X
X;;JAK 2/14/87 Bug found. The following IF was not included, causing
X;; the second form to always be returned. This caused forms like
X;;; (SETF (NIL #:G1234) 5) to be generated, which aren't SETF expandable
X
X (if (not (slotd-accessor (cadddr temp)))
X (optimize-setf-of-get-slot
X ;;; proto-method ; rds 3/8
X (third temp)
X `(setf-of-get-slot
X ,(cadr (assq (cadr temp) gensyms))
X ',(slotd-name (cadddr temp))
X ,(caddr form))
X )
X
X `(setf (,(slotd-accessor (cadddr temp))
X ,(cadr (assq (cadr temp) gensyms)))
X ,(caddr form))))
X (t form)))
X (t form)))))))
X
X;;Default methods for optimize-get-slot and optimize-setf-of-get-slot
X
X; rds 3/9 changed arglist to conform to new PCL
X; (defmeth optimize-get-slot (method class form)
X; form
X;)
X(defmeth optimize-get-slot (class form)
X form
X )
X
X; rds 3/9 changed arglist to conform to new PCL
X;(defmeth optimize-setf-of-get-slot (method class form)
X; form
X;)
X(defmeth optimize-setf-of-get-slot (class form)
X form
X )
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X(provide "pcl-patches")
X
END_OF_FILE
if test 6462 -ne `wc -c <'pcl-patches.l'`; then
echo shar: \"'pcl-patches.l'\" unpacked with wrong size!
fi
# end of 'pcl-patches.l'
fi
if test -f 'xerox-low.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'xerox-low.l'\"
else
echo shar: Extracting \"'xerox-low.l'\" \(5605 characters\)
sed "s/^X//" >'xerox-low.l' <<'END_OF_FILE'
X;;; -*- Mode:LISP; Package:(PCL Lisp 1000); Base:10.; Syntax:Common-lisp -*-
X;;;
X;;; *************************************************************************
X;;; Copyright (c) 1985 Xerox Corporation. All rights reserved.
X;;;
X;;; Use and copying of this software and preparation of derivative works
X;;; based upon this software are permitted. Any distribution of this
X;;; software or derivative works must comply with all applicable United
X;;; States export control laws.
X;;;
X;;; This software is made available AS IS, and Xerox Corporation makes no
X;;; warranty about the software, its performance or its conformity to any
X;;; specification.
X;;;
X;;; Any person obtaining a copy of this software is requested to send their
X;;; name and post office or electronic mail address to:
X;;; CommonLoops Coordinator
X;;; Xerox Artifical Intelligence Systems
X;;; 2400 Hanover St.
X;;; Palo Alto, CA 94303
X;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
X;;;
X;;; Suggestions, comments and requests for improvements are also welcome.
X;;; *************************************************************************
X;;;
X;;; This is the 1100 (Xerox version) of the file portable-low.
X;;;
X
X(in-package 'pcl)
X
X(defmacro load-time-eval (form)
X `(il:LOADTIMECONSTANT ,form))
X
X ;;
X;;;;;; Memory block primitives.
X ;;
X
X; what I have done is to replace all calls to il:\\RPLPTR with a call to
X; RPLPTR (in the PCL) package. RPLPTR is a version which does some error
X; checking and then calls il:\\RPLPTR. As follows:
X
X;(defun rplptr (block index value)
X; (if (< index (* (il:\\#blockdatacells block) 2))
X; (il:\\rplptr block index value)
X; (error "bad args to rplptr")))
X
X(defmacro make-memory-block (size &optional area)
X `(il:\\allocblock ,size T))
X
X(defmacro memory-block-ref (block offset)
X `(il:\\GETBASEPTR ,block (* ,offset 2)))
X
X(defsetf memory-block-ref (memory-block offset) (new-value)
X `(il:\\rplptr ,memory-block (* ,offset 2) ,new-value))
X
X(defmacro memory-block-size (block)
X ;; this returns the amount of memory allocated for the block --
X ;; it may be larger than size passed at creation
X `(il:\\#BLOCKDATACELLS ,block))
X
X(defmacro CLEAR-memory-block (block start)
X (once-only (block)
X `(let ((end (* (il:\\#blockdatacells ,block) 2)))
X (do ((index (* ,start 2) (+ index 2)))
X ((= index end))
X (il:\\rplptr ,block index nil)))))
X
X ;;
X;;;;;; Static slot storage primitives
X ;;
X
X;;;
X;;; Once everything sees to work, uncomment this back into play and remove
X;;; the * 2 in the other places.
X;;;
X;(defmacro %convert-slotd-position-to-slot-index (slotd-position)
X; `(* 2 ,slotd-position))
X
X(defmacro %allocate-static-slot-storage--class (no-of-slots)
X `(il:\\ALLOCBLOCK ,no-of-slots t))
X
X(defmacro %static-slot-storage-get-slot--class (static-slot-storage
X slot-index)
X `(il:\\GETBASEPTR ,static-slot-storage (* ,slot-index 2)))
X
X(defsetf %static-slot-storage-get-slot--class (static-slot-storage
X slot-index)
X (new-value)
X `(il:\\rplptr ,static-slot-storage (* ,slot-index 2) ,new-value))
X
X
X ;;
X;;;;;; Instance With Meta-Class Class (IWMC-CLASS)
X ;;
X;;; In Xerox Lisp, the type of an object is inextricably linked to its size.
X;;; This means that we can't build IWMC-CLASS on top of %instance and still
X;;; get rid of the indirection to instance-storage the way we would like to.
X;;; So, we build iwmc-class on its own base using defstruct.
X;;;
X;;; NOTE: %instance-meta-class will not return the right value for an
X;;; instance
X
X(eval-when (compile load eval)
X ;; see if we can save our implementation of macros from itself
X (dolist (x '(iwmc-class-class-wrapper
X iwmc-class-static-slots
X iwmc-class-dynamic-slots))
X (fmakunbound x)
X (remprop x 'il:macro-fn)))
X
X(defstruct (iwmc-class (:predicate iwmc-class-p)
X (:conc-name iwmc-class-)
X (:constructor %%allocate-instance--class ())
X (:print-function print-instance))
X (class-wrapper nil)
X (static-slots nil)
X (dynamic-slots ()))
X
X(defmacro %allocate-instance--class (no-of-slots &optional class-class)
X `(let ((iwmc-class (%%allocate-instance--class)))
X (%allocate-instance--class-1 ,no-of-slots iwmc-class)
X iwmc-class))
X
X
X(defmacro %allocate-class-class (no-of-slots) ;This is used to allocate the
X `(let ((i (%%allocate-instance--class))) ;class class. It bootstraps
X ;(setf (%instance-meta-class i) i) ;the call to class-named in
X (setf (class-named 'class) i) ;%allocate-instance--class.
X (%allocate-instance--class-1 ,no-of-slots i)
X i))
X
X(eval-when (compile load eval)
X (setq *class-of*
X '(lambda (x)
X (or (and (iwmc-class-p x)
X (class-of--class x))
X (and (%instancep x)
X (%instance-class-of x))
X ;(%funcallable-instance-p x)
X (class-named (type-of x) t)
X (error "Can't determine class of ~S" x))))
X
X (setq *meta-classes* (delete (assq 'class *meta-classes*) *meta-classes*)))
X
X
X
X ;;
X;;;;;; FUNCTION-ARGLIST
X ;;
X
X(defun function-arglist (x) (il:arglist x))
X
X ;;
X;;;;;; Generating CACHE numbers
X ;;
X
X(defmacro symbol-cache-no (symbol mask)
X `(logand (il:llsh (logand #o17777 (il:\\loloc ,symbol)) 2) ,mask))
X
X(defmacro object-cache-no (object mask)
X `(logand (il:\\loloc ,object) ,mask))
X
X
X ;;
X;;;;;; printing-random-thing-internal
X ;;
X
X(defun printing-random-thing-internal (thing stream)
X (princ (il:\\hiloc thing) stream)
X (princ "," stream)
X (princ (il:\\loloc thing) stream))
X
X(defun record-definition (name type &optional parent-name parent-type)
X (declare (ignore type parent-name))
X ())
X
END_OF_FILE
if test 5605 -ne `wc -c <'xerox-low.l'`; then
echo shar: \"'xerox-low.l'\" unpacked with wrong size!
fi
# end of 'xerox-low.l'
fi
echo shar: End of archive 2 \(of 13\).
cp /dev/null ark2isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 ; do
if test ! -f ark${I}isdone ; then
MISSING="${MISSING} ${I}"
fi
done
if test "${MISSING}" = "" ; then
echo You have unpacked all 13 archives.
rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
echo You still need to unpack the following archives:
echo " " ${MISSING}
fi
## End of shell archive.
exit 0
--
Rich $alz "Anger is an energy"
Cronus Project, BBN Labs rsalz@bbn.com
Moderator, comp.sources.unix sources@uunet.uu.net-