rs@uunet.UU.NET (Rich Salz) (07/31/87)
Submitted-by: Roy D'Souza <dsouza%hplabsc@hplabs.HP.COM>
Posting-number: Volume 10, Issue 79
Archive-name: comobj.lisp/Part05
#! /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 5 (of 13)."
# Contents: meth-combi.l profmacs.l
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'meth-combi.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'meth-combi.l'\"
else
echo shar: Extracting \"'meth-combi.l'\" \(19923 characters\)
sed "s/^X//" >'meth-combi.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;;; User-defined method combination. A first try.
X;;;
X;;; For compatibility with New Flavors, the following functions macros and
X;;; variables have the same meaning.
X;;; define-simple-method-combination
X;;; define-method-combination
X;;; call-component-method
X;;; call-component-methods
X;;; *combined-method-arguments*
X;;; *combined-method-apply*
X;;;
X;;; In define-method-combination the arguments have the following meanings:
X;;;
X;;; name the name of this method combination type (symbol)
X;;; parameters like a defmacro lambda list, it is matched with
X;;; the value specified by the :method-combination
X;;; option to make-specializable
X;;; method-patterns a list of method-patterns specifications that are
X;;; used to select some subset of the methods defined
X;;; on the discriminator. Each method pattern specifies
X;;; a variable which is bound to a list of the methods
X;;; it selects.
X;;; body forms evaluated with the variables specified by
X;;; the method patterns bound to produce the body of
X;;; the combined method. (see call-component-methods).
X;;;
X;;; Body can be preceded by any number of options which take the form:
X;;; (<option-name> . <option-args>)
X;;;
X;;; Currently, the defined options are:
X;;;
X;;; :causes-combination-predicate
X;;; The only argument, should be a function of one argument. It
X;;; will be called on a method (of the discriminator) and should
X;;; return T if that method causes the discriminator to combine
X;;; its methods.
X;;;
X;;; A method-patterns looks like:
X;;;
X;;; (<var> <printer> <filter> <order> <pattern-1> <pattern-2> ..)
X;;;
X;;; <var> is the variable to which the selected methods
X;;; are bound
X;;; <printer> is ignored
X;;; <filter> one of :every, :first, :last or :remove-duplicates
X;;; <order> :most-specific-first or :most-specific-last
X;;;
X;;; Methods matching any of the patterns are selected. The patterns
X;;; are matched against the method-combination-options of the method
X;;; as specified in the defmeth.
X;;;
X
X(in-package 'pcl)
X
X;;;
X;;; The method combination type of a particular method combination is stored
X;;; as a symbol (the name of the method-combination) in the discriminator (in
X;;; the method-combination-type slot). Information about that particular
X;;; method-combination-type is stored on the property list of the type symbol
X;;;
X(defun get-method-combination-info (type &optional no-error-p)
X (or (get type 'method-combination)
X (if no-error-p () (error "No method combination named ~S." type))))
X
X(defun set-method-combination-info (type combiner predicate)
X (setf (get type 'method-combination) (list type combiner predicate)))
X
X(defmeth method-combiner ((discriminator method-combination-mixin))
X (cadr (get-method-combination-info
X (method-combination-type discriminator))))
X
X(defmeth method-causes-combination-predicate
X ((discriminator method-combination-mixin))
X (caddr (get-method-combination-info
X (method-combination-type discriminator))))
X
X
X
X
X ;;
X;;;;;; COMBINED-METHOD class
X ;;
X
X(ndefstruct (combined-method (:class class)
X (:include (method)))
X (deactivated-methods ()))
X
X(defmeth automatically-defined-p ((m combined-method)) (ignore m) t)
X
X(defmeth method-options ((m combined-method)) (ignore m) '(:combined))
X
X(defmeth method-causes-combination-p ((m combined-method)) (ignore m) nil)
X
X(defmacro define-simple-method-combination (name operator
X &optional single-arg-is-value
X (pretty-name
X (string-downcase
X name)))
X `(define-method-combination ,name
X (&optional (order :most-specific-first))
X ((methods ,pretty-name :every order () (,name) :default))
X `(call-component-methods ,methods
X :operator ,',operator
X :single-arg-is-value ,',single-arg-is-value)))
X
X(defmacro define-method-combination (name parameters method-patterns
X &body body)
X (check-type parameters list)
X (check-type method-patterns (and list (not null)))
X (make-method-combination name parameters method-patterns body))
X
X
X(defvar *combined-method-arguments*)
X(defvar *combined-method-apply*)
X(defvar *combined-method-template*)
X
X;;;
X;;; Generate a form that calls a single method.
X;;; With no keyword arguments, uses the value of *combined-methods-arguments*
X;;; as the arguments to the call;
X;;; With :ARGLIST, uses that instead;
X;;; With :ARGLIST and :APPLY T, uses APPLY instead of FUNCALL
X;;; With just :APPLY, it is the single argument to apply to.
X;;;
X;;; When called with *combined-method-template* bound, generates calls to
X;;; the value of variables gotten from *combined-method-template* instead
X;;; of to the actual methods themselves. This is used to build templates
X;;; for combined methods.
X;;;
X(defmacro call-component-method
X (method &key (apply nil apply-p)
X (arglist
X (if apply-p
X (prog1 (list apply) (setq apply t))
X (prog1 *combined-method-arguments*
X (setq apply *combined-method-apply*)))))
X (call-component-method-internal method apply arglist))
X
X(defmacro call-component-methods (methods &key (operator 'progn)
X (single-arg-is-value nil))
X (call-component-methods-internal methods operator single-arg-is-value))
X
X(defmeth call-component-method-internal
X (method &optional (apply *combined-method-apply*)
X (arglist *combined-method-arguments*))
X (when method
X `(,(if apply 'apply 'funcall)
X ,(if (boundp '*combined-method-template*)
X (let ((gensym (cdr (assq method *combined-method-template*))))
X (if gensym
X `(the function ,gensym)
X (error "*combined-method-template* out of sync??")))
X `',(method-function method))
X ,@arglist)))
X
X(defmeth call-component-methods-internal (methods
X operator single-arg-is-value)
X (when methods
X (if (and single-arg-is-value (null (cdr methods)))
X (call-component-method-internal (car methods))
X `(,operator
X ,@(iterate ((method in methods))
X (collect (call-component-method-internal method)))))))
X
X(defmeth call-component-method-equal (discriminator call-1 call-2)
X ;; If the options are the same (the part that the macros control the
X ;; processing of); and the individual calls are the same the part the
X ;; methods themselves control the processing of.
X (and (equal (cddr call-1) (cddr call-2))
X (if (eq (car call-1) 'call-component-method)
X (cond ((null (cadr call-1)) (null (cadr call-2)))
X ((null (cadr call-2)) (null (cadr call-1)))
X (t
X (call-component-method-equal-internal
X discriminator (cadr call-1) (cadr call-2))))
X (iterate ((meth-1 on (cadr call-1))
X (meth-2 on (cadr call-2)))
X (when (or (and (cdr meth-1) (null (cdr meth-2)))
X (and (cdr meth-2) (null (cdr meth-1)))
X (null (call-component-method-equal-internal
X discriminator (car meth-1) (car meth-2))))
X (return nil))))))
X
X(defmeth call-component-method-equal-internal (discriminator meth-1 meth-2)
X (ignore discriminator meth-1 meth-2)
X t)
X
X
X
X(defvar *method-combination-filters*
X '(:every :first :last :remove-duplicates))
X
X(defvar *method-combination-orders*
X '(:most-specific-first :most-specific-last))
X
X(defun make-method-combination (name parameters method-patterns body)
X (let ((causes-combination-predicate 'true)
X (combiner (make-symbol (string-append name " Method Combiner"))))
X ;; Error check and canonicalize the arguments.
X (unless (symbolp name)
X (error "The name of a method combination type must be a symbol, but ~S~
X was specified."
X name))
X ;; Check the various sub-parts of each method-patterns. Canonicalize
X ;; each method-pattern by adding the () pattern to it if it has no
X ;; other patterns.
X (iterate ((method-patterns-loc on method-patterns))
X (destructuring-bind (var printer filter order . patterns)
X (car method-patterns-loc)
X (check-symbol-variability var "bind (in a method-patterns)")
X (or (null (keywordp filter))
X (memq filter *method-combination-filters*)
X (error "A method-patterns filter must be one of: ~S~%not ~S."
X *method-combination-filters* filter))
X (or (null (keywordp order))
X (memq order *method-combination-orders*)
X (error "A method-patterns order must be one of: ~S~%not ~S."
X *method-combination-orders* filter))
X (if (null patterns)
X (setf (car method-patterns-loc)
X (append (car method-patterns-loc) (list nil)))
X (iterate ((pattern in patterns))
X (or (listp pattern)
X (eq pattern ':default)
X (error "A method-pattern must be a list.~%~
X In the method-patterns ~S, ~S is an invalid pattern."
X (car method-patterns-loc) pattern))))))
X (iterate ()
X (while (and body (listp (car body))))
X (case (caar body)
X (:causes-combination-predicate
X (setq causes-combination-predicate (cadr (pop body))))
X (otherwise (return))))
X
X `(progn
X ,(make-combiner-definer
X combiner name parameters method-patterns body)
X (setf (get ',name 'combined-method-templates) ())
X (set-method-combination-info ',name
X ',combiner
X ',causes-combination-predicate))))
X
X(defun make-combiner-definer
X (combiner name parameters method-patterns body)
X (ignore name)
X `(defun ,combiner (.discriminator. .methods. .params.)
X .discriminator.
X (apply
X #'(lambda ,parameters
X (let ,(iterate (((var) in method-patterns)) (collect `(,var nil)))
X (do ((.method. (pop .methods.) (pop .methods.)))
X ((null .method.))
X (cond
X ,@(iterate (((var nil fil ord . pats) in method-patterns))
X (collect
X `((and ,(ecase fil
X (:first
X `(if (eq ,ord :most-specific-first)
X (null ,var)
X 't))
X (:last
X `(if (eq ,ord :most-specific-first)
X t
X (null ,var)))
X (:every
X 't))
X (method-matches-patterns-p .method. ',pats))
X (push .method. ,var))))))
X ,@(iterate (((var nil fil ord) in method-patterns))
X (cond ((memq fil '(:first :last))
X (collect `(setq ,var (car ,var))))
X ((eq ord ':most-specific-first)
X (collect `(setq ,var (nreverse ,var))))))
X ,@body))
X .params.)))
X
X
X(defmeth method-matches-patterns-p (method patterns)
X (iterate ((pattern in patterns))
X (when (method-matches-pattern-p method pattern)
X (return t))))
X
X(defmeth method-matches-pattern-p (method pattern)
X (iterate ((pats = pattern (cdr pats))
X (opts = (method-options method) (cdr opts)))
X (if (symbolp pats)
X ;; Special case this because it means we have to blow out of
X ;; iterate. Should iterate should know about dotted lists.
X (return (or (eq pats '*) (eq pats opts)))
X (unless (or (eq (car pats) '*)
X (equal (car pats) (car opts)))
X (return nil)))
X (finally (return t))))
X
X(defun patterns-keywords (patterns)
X (let ((keywords ()))
X (iterate ((pattern in patterns))
X (iterate ((elem in pattern))
X (when (keywordp elem) (push elem keywords))))
X keywords))
X
X(defun check-symbol-variability (symbol verb)
X (cond ((not (symbolp symbol))
X (error "Attempt to ~A ~S which is not a symbol" verb symbol))
X ((or (null symbol) (eq symbol 't))
X (error "Attempt to ~A ~S" verb symbol))
X ((eq (symbol-package symbol) (find-package 'keyword))
X (error "Attempt to ~A ~S, which is a keyword" verb symbol))
X ((constantp symbol)
X (error "Attempt to ~A ~S, which is a constant" verb symbol))))
X
X(defun cpl-filter-= (cpl1 cpl2 discriminator)
X (macrolet ((has-method-on-discriminator-p (class)
X `(memq discriminator (class-direct-discriminators ,class))))
X (prog ()
X restart
X (cond ((null cpl1)
X (if (null cpl2)
X (return t)
X (return nil)))
X ((null cpl2)
X (return nil)))
X (unless (has-method-on-discriminator-p (car cpl1))
X (pop cpl1)
X (go restart))
X (unless (has-method-on-discriminator-p (car cpl2))
X (pop cpl2)
X (go restart))
X (if (neq (pop cpl1) (pop cpl2))
X (return nil)
X (go restart)))))
X
X
X;;; class-discriminators-which-combine-methods
X;;; discriminator-methods-combine-p
X
X(defmeth combine-methods ((class class) &optional discriminators)
X (let ((cpl (class-class-precedence-list class))
X (method nil)
X (method-cpl nil)
X (combined-method nil))
X
X (iterate ((disc in discriminators))
X (setq method (lookup-method disc class)
X method-cpl (and method
X (not (combined-method-p method))
X (class-class-precedence-list
X (car (method-type-specifiers method)))))
X (unless (cpl-filter-= cpl method-cpl disc)
X (dolist (other-method (discriminator-methods disc))
X (when (and (combined-method-p other-method)
X (eq (car (method-type-specifiers other-method))
X class))
X (remove-method disc other-method)))
X (multiple-value-bind (arguments apply-p body)
X (combine-methods-internal class disc cpl)
X (setq combined-method
X (make 'combined-method
X :function (compile-combined-method
X disc arguments apply-p body)
X :arglist arguments
X :type-specifiers (cons class
X (cdr (method-type-specifiers
X method)))))
X (add-method disc combined-method nil))))))
X
X(defmeth combine-methods-internal (class discriminator cpl)
X (ignore class)
X (let ((methods (iterate ((c in cpl))
X (join
X (iterate ((m in (discriminator-methods discriminator)))
X (when (and (eq (car (method-type-specifiers m)) c)
X (not (combined-method-p m)))
X (collect m)))))))
X (multiple-value-bind (required restp)
X (compute-discriminating-function-arglist-info discriminator)
X (let ((*combined-method-arguments*
X (make-discriminating-function-arglist required restp))
X (*combined-method-apply* restp))
X (values *combined-method-arguments*
X *combined-method-apply*
X (funcall (method-combiner discriminator)
X discriminator methods ()))))))
X
X
X ;;
X;;;;;; COMPILE-COMBINED-METHOD
X ;;
X
X(defmeth compile-combined-method ((discriminator method-combination-mixin)
X *combined-method-arguments*
X *combined-method-apply*
X body)
X (multiple-value-bind (constructor methods-called)
X (compile-combined-method-internal discriminator body)
X (apply constructor (mapcar #'method-function methods-called))))
X
X(defmeth compile-combined-method-internal (discriminator body)
X (let* ((combination-type (method-combination-type discriminator))
X (templates (get combination-type 'combined-method-templates))
X (methods-called ())
X (walked-body
X (walk-form body
X :walk-function
X #'(lambda (form context &aux temp)
X (ignore context)
X (values form
X (and (eq context 'eval)
X (listp form)
X (setq temp (car form))
X (cond ((eq temp 'call-component-method)
X (push (cadr form) methods-called))
X ((eq temp 'call-component-methods)
X (setq methods-called
X (append (cadr form)
X methods-called))))))))))
X (setq methods-called (remove nil methods-called))
X (iterate ((entry in templates))
X (when (combined-method-equal discriminator (car entry) walked-body)
X (return (values (cdr entry) methods-called)))
X (finally
X (let* ((*combined-method-template*
X (iterate ((method in methods-called))
X (collect (cons method (gensym)))))
X (new-constructor
X (compile ()
X `(lambda
X ,(mapcar #'cdr *combined-method-template*)
X #'(lambda ,*combined-method-arguments*
X ,(walk-form walked-body))))))
X (push (cons walked-body new-constructor)
X (get combination-type 'combined-method-templates))
X (return (values new-constructor methods-called)))))))
X
X(defmeth combined-method-equal (discriminator comb-meth-1 comb-meth-2)
X (cond ((atom comb-meth-1) (eq comb-meth-1 comb-meth-2))
X ((memq (car comb-meth-1)
X '(call-component-method call-component-methods))
X (and (eq (car comb-meth-1) (car comb-meth-2))
X (call-component-method-equal
X discriminator comb-meth-1 comb-meth-2)))
X (t
X (and (combined-method-equal
X discriminator (car comb-meth-1) (car comb-meth-2))
X (combined-method-equal
X discriminator (cdr comb-meth-1) (cdr comb-meth-2))))))
X
X
X
X(defmeth discriminator-changed ((discriminator method-combination-mixin)
X (method combined-method)
X added-p)
X (ignore discriminator method added-p))
X
X(defmeth discriminator-changed ((discriminator method-combination-mixin)
X method
X added-p)
X (when (methods-combine-p discriminator)
X (let ((class (car (method-type-specifiers method))))
X (when (classp class)
X (labels ((walk-tree (class)
X (combine-methods class (list discriminator))
X (dolist (subclass (class-direct-subclasses class))
X (walk-tree subclass))))
X (walk-tree class)))))
X (run-super))
X
X
END_OF_FILE
if test 19923 -ne `wc -c <'meth-combi.l'`; then
echo shar: \"'meth-combi.l'\" unpacked with wrong size!
fi
# end of 'meth-combi.l'
fi
if test -f 'profmacs.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'profmacs.l'\"
else
echo shar: Extracting \"'profmacs.l'\" \(20279 characters\)
sed "s/^X//" >'profmacs.l' <<'END_OF_FILE'
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; File: profmacs.l
X; SCCS: %A% %G% %U%
X; Description: Macros For Profiling
X; Author: James Kempf, HP/DCC
X; Created: 7-Feb-87
X; Modified: 25-Feb-87 09:06:08 (James Kempf)
X; Language: Lisp
X; Package: TEST
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X(in-package 'test)
X(use-package 'lisp)
X
X;;Need COOL
X
X(require "co")
X(use-package 'co)
X
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; System Dependent Customizations
X;
X; Some systems will have special, hardware or software dependent profiling
X; packages. If your system has one, put it in here. Otherwise, the default
X; timing functions from CLtL will be used. In addition, the system dependent
X; function for garbage collection should be inserted, if your system
X; requires garbage collection. Otherwise, no garbage collection will be done.
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;warn-garbage-collect-Warn that no garbage collection function is in use.
X
X(defun warn-garbage-collect ()
X (warn
X "~&******** Profiling Measurments Could Be Interrupted By Garbage Collection *******"
X )
X) ;warn-garbage-collect
X
X;;*clock-increment-in-milliseconds*-Increment of the clock
X
X(defvar *clock-increment-in-milliseconds* 0)
X
X;;Use the 10 microsecond clock
X
X#+HP
X(eval-when (load eval)
X (require "measure")
X (setf (symbol-function 'get-time) (symbol-function measure:time10usec))
X (setf *clock-increment-in-milliseconds* 0.01)
X (setf (symbol-function 'do-garbage-collect) (symbol-function 'system:gc))
X
X)
X
X;;Default is to just use the functions from Steele
X
X#-HP
X(eval-when (load eval)
X (setf (symbol-function 'get-time) (symbol-function 'get-internal-real-time))
X (setf *clock-increment-in-milliseconds*
X (* (float (/ 1.0 internal-time-units-per-second)) 1000.0)
X )
X (setf (symbol-function 'do-garbage-collect) (symbol-function 'warn-garbage-collect))
X
X)
X
X;;Switch for Class Definition Syntax
X
X(defvar *define-type-switch* T)
X
X;;Vector containing names of types with zero, one, two, and
X;; three instance variables.
X
X(defvar *iv-defined-types* (make-array '(4 4) :initial-element NIL))
X
X;;Lists of results
X
X;;For type definition (iterations ivs parents time)
X
X(defvar *define-type-results* NIL)
X
X;;For instance creation (interations ivs parents time)
X
X(defvar *creation-results* NIL)
X
X;;For method definition (iterations preexisting time)
X
X(defvar *define-method-results* NIL)
X
X;;For messaging (iterations functions time)
X
X(defvar *messaging-results* NIL)
X
X;;For inherited messaging (iterations parents time)
X
X(defvar *inherited-messaging-results* NIL)
X
X;;These variables and macros are used for inserting the result of
X;; macroexpantion times into the calculations
X
X(defvar *macro-start-clock* 0)
X(defvar *macro-end-clock* 0)
X(defvar *macro-total-time* 0)
X
X(defmacro macro-start-clock ()
X
X (setf *macro-start-clock* (get-time))
X NIL
X)
X
X(defmacro macro-end-clock ()
X
X (setf *macro-end-clock* (get-time))
X (setf *macro-total-time* (- *macro-end-clock* *macro-start-clock*))
X (setf *macro-end-clock* 0)
X (setf *macro-start-clock* 0)
X
X NIL
X)
X
X(defmacro macro-insert-sum ()
X
X (let
X (
X (returned-sum *macro-total-time*)
X )
X
X (setf *macro-total-time* 0)
X returned-sum
X )
X
X)
X
X;;do-type-definition-Profile Type or Class Definition
X
X(defmacro do-type-definition (record variables parents)
X
X (let
X (
X (iv-names NIL)
X (code NIL)
X (tname NIL)
X (pnames NIL)
X )
X
X ;;Construct a new function symbol for this test
X
X (push (gensym) *function-symbols*)
X
X ;;Generate a list of instance variable names
X
X (dotimes (i variables )
X (setf iv-names
X (list*
X (if *define-type-switch*
X `(:var ,(gentemp))
X (gentemp)
X )
X iv-names
X )
X )
X )
X
X ;;Generate list of parent names
X
X (dotimes (i parents)
X (setf pnames
X (list*
X (if *define-type-switch*
X `(:inherit-from ,(nth i (aref *iv-defined-types* 0 0)))
X (nth i (aref *iv-defined-types* 0 0))
X )
X pnames
X )
X )
X )
X
X ;;Generate code for type definition
X
X (dotimes (i 20)
X
X ;;Generate the name for this type and
X ;; push onto the appropriate list
X
X (setf tname (gentemp))
X
X (setf (aref *iv-defined-types* parents variables)
X (push tname (aref *iv-defined-types* parents variables))
X )
X
X ;;Generate the type code
X
X (push
X (if *define-type-switch*
X `(define-type ,tname
X ,@iv-names
X ,@pnames
X )
X `(ndefstruct
X (,tname
X (:class class)
X ,pnames
X )
X ,@iv-names
X )
X ) ;if
X
X code
X
X ) ;push
X
X )
X
X ;;Return code, inserting prolog and cache heating
X
X `(defun ,(first *function-symbols*) ()
X (let
X (
X (after 0)
X (before 0)
X (sum 0)
X )
X
X (tagbody
X again
X
X (do-garbage-collect)
X
X ,(if *define-type-switch*
X `(define-type ,(gentemp)
X ,@iv-names
X ,@pnames
X )
X `(ndefstruct
X (,(gentemp)
X (:class class)
X ,pnames
X )
X ,@iv-names
X )
X ) ;if
X
X (setf before (get-time))
X (macro-start-clock)
X ,@code
X (macro-end-clock)
X (setf after (get-time))
X
X (setf sum (macro-insert-sum))
X
X
X (if (< (the integer after) (the integer before))
X (go again)
X )
X )
X
X (if ,record
X (push (list 20 ,variables ,parents (- after before) sum) *define-type-results*)
X )
X
X )
X
X )
X
X ) ;let
X
X) ;do-type-definition
X
X(setf (symbol-function 'do-type-definition-macro) (macro-function 'do-type-definition))
X(compile 'do-type-definition-macro)
X(setf (macro-function 'do-type-definition) (symbol-function 'do-type-definition-macro))
X
X;;do-instance-creation-Create instances of types as above
X
X(defmacro do-instance-creation (record ivs parents)
X
X (let
X (
X (code NIL)
X )
X
X ;;Generate a new function symbol
X
X (push (gensym) *function-symbols*)
X
X ;;Generate code to create
X
X (dotimes (i 20)
X
X (push
X `(make-instance ',(nth i (aref *iv-defined-types* parents ivs)))
X code
X )
X
X ) ;dotimes
X
X ;;Return code, inserting prolog and cache heating
X
X `(defun ,(first *function-symbols*) ()
X (let
X (
X (after 0)
X (before 0)
X )
X
X (tagbody
X again
X
X (do-garbage-collect)
X
X (make-instance ',(nth 1 (aref *iv-defined-types* parents ivs)))
X
X (setf before (get-time))
X ,@code
X (setf after (get-time))
X
X (if (< (the integer after) (the integer before))
X (go again)
X )
X )
X
X (if ,record
X (push (list 20 ,ivs ,parents (- after before)) *creation-results*)
X )
X
X )
X )
X
X ) ;let
X
X) ;do-instance-creation
X
X(setf (symbol-function 'do-instance-creation-macro) (macro-function 'do-instance-creation))
X(compile 'do-instance-creation-macro)
X(setf (macro-function 'do-instance-creation) (symbol-function 'do-instance-creation-macro))
X
X;;switch-define-types-Define types depending on switch
X
X(defmacro switch-define-types ( parent &rest t-list)
X
X (let
X (
X (code NIL)
X )
X
X (dolist (ty t-list)
X (push
X (if *define-type-switch*
X `(define-type ,ty ,@(if parent `((:inherit-from ,parent)) NIL))
X `(ndefstruct (,ty (:class class) ,@(if parent `((:include (,parent))) `() ) ) )
X )
X code
X )
X )
X
X `(progn
X ,@code
X )
X
X )
X) ;switch-define-types
X
X;;switch-define-method-Define method depending on switch
X
X(defmacro switch-define-method (name)
X
X (if *define-type-switch*
X `(define-method (,name ,(intern (symbol-name name) (find-package 'keyword)) ) () )
X `(defmeth ,(intern (symbol-name name) co::*keyword-standin-package*)
X ((.inner-self. ,name))
X )
X )
X
X) ;switch-define-method
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; Define Types For Method Definition Tests and Make Instances
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;For testing method definition and invocation with varying methods on
X;; discriminator
X
X(funcall
X (compile ()
X `(lambda () (switch-define-types NIL temp0 temp1 temp2 temp3 temp4))
X )
X)
X
X(setf temp0 (make-instance 'temp0))
X(setf temp1 (make-instance 'temp1))
X(setf temp2 (make-instance 'temp2))
X(setf temp3 (make-instance 'temp3))
X(setf temp4 (make-instance 'temp4))
X
X;;For testing method invocation of inherited methods
X
X(funcall
X (compile ()
X `(lambda () (switch-define-types NIL g3f))
X )
X)
X
X(funcall
X (compile ()
X `(lambda () (switch-define-method g3f))
X )
X)
X
X(funcall
X (compile ()
X `(lambda () (switch-define-types g3f g2f))
X )
X)
X
X(funcall
X (compile ()
X `(lambda () (switch-define-method g2f))
X )
X)
X
X(funcall
X (compile ()
X `(lambda () (switch-define-types g2f g1f))
X )
X)
X
X(funcall
X (compile ()
X `(lambda () (switch-define-method g1f))
X )
X)
X
X(funcall
X (compile ()
X `(lambda () (switch-define-types g1f g0f))
X )
X)
X
X(funcall
X (compile ()
X `(lambda () (switch-define-method g0f))
X )
X)
X
X;;Make an instance of g0f
X
X(setf g0f (make-instance 'g0f))
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;Method symbol List
X
X(defvar *list-of-method-symbols* NIL)
X
X;;do-method-definition-Do the method definition
X
X(defmacro do-method-definition (record predefined fortype)
X
X (let
X (
X (code NIL)
X )
X
X ;;Generate a new function symbol
X
X (push (gensym) *function-symbols*)
X
X ;;Generate method symbols if necessary
X
X (if (not *list-of-method-symbols*)
X
X (dotimes (i 20)
X (push (intern (format NIL "T~D" i) (find-package :keyword))
X *list-of-method-symbols*
X )
X )
X ) ;if
X
X ;;Generate code for method definition
X
X (dolist (l *list-of-method-symbols*)
X
X (push
X (if *define-type-switch*
X `(define-method (,fortype ,l) () )
X `(defmeth ,(intern (symbol-name l) co::*keyword-standin-package*)
X ((.inner-self. ,fortype))
X )
X )
X code
X )
X
X )
X
X ;;Return code, inserting prolog and cache heating
X
X `(defun ,(first *function-symbols*) ()
X (let
X (
X (after 0)
X (before 0)
X (sum 0)
X )
X
X (tagbody
X again
X (do-garbage-collect)
X
X ,(if *define-type-switch*
X `(define-method (,fortype ,(gentemp)) () )
X `(defmeth ,(gentemp) ((.inner-self. ,fortype)) )
X )
X
X (setf before (get-time))
X (macro-start-clock)
X ,@code
X (macro-end-clock)
X (setf after (get-time))
X
X (setf sum (macro-insert-sum))
X
X (if (< (the integer after) (the integer before))
X (go again)
X )
X )
X
X (if ,record
X (push (list 20 ,predefined (- after before) sum) *define-method-results*)
X )
X
X )
X
X )
X
X ) ;let
X
X) ;do-method-definition
X
X(setf (symbol-function 'do-method-definition-macro) (macro-function 'do-method-definition))
X(compile 'do-method-definition-macro)
X(setf (macro-function 'do-method-definition) (symbol-function 'do-method-definition-macro))
X
X;;do-messaging-Messaging macro code construction
X
X(defmacro do-messaging (record predefined &rest type-list)
X
X (let
X (
X (code NIL)
X )
X
X ;;Generate a new function symbol
X
X (push (gensym) *function-symbols*)
X
X ;;Push on 20 messagings
X
X (dotimes (i 20)
X
X ;;Message for each type
X
X (dolist (ty type-list)
X
X (push
X (if *define-type-switch*
X `(=> ,ty ,(first *list-of-method-symbols*))
X `(,(intern
X (symbol-name (first *list-of-method-symbols*))
X co::*keyword-standin-package*
X )
X ,ty
X )
X )
X code
X
X ) ;push
X
X ) ;dolist
X
X ) ;dotimes
X
X ;;Return code, inserting prolog and hardware cache
X ;; heating to another message.
X
X `(defun ,(first *function-symbols*) ()
X (let
X (
X (after 0)
X (before 0)
X (sum 0)
X )
X
X (tagbody
X again
X
X (do-garbage-collect)
X
X ,(if *define-type-switch*
X `(=> ,(first type-list) ,(second *list-of-method-symbols*))
X `(,(intern
X (symbol-name (second *list-of-method-symbols*))
X co::*keyword-standin-package*
X )
X ,(first type-list)
X )
X )
X
X
X (setf before (get-time))
X (macro-start-clock)
X ,@code
X (macro-end-clock)
X (setf after (get-time))
X
X (setf sum (macro-insert-sum))
X
X (if (< (the integer after) (the integer before))
X (go again)
X )
X )
X
X (if ,record
X (push (list (* 20 ,(length type-list))
X ,predefined
X (- after before)
X sum
X )
X *messaging-results*
X )
X )
X
X )
X
X )
X
X ) ;let
X
X) ;do-messaging
X
X(setf (symbol-function 'do-messaging-macro) (macro-function 'do-messaging))
X(compile 'do-messaging-macro)
X(setf (macro-function 'do-messaging) (symbol-function 'do-messaging-macro))
X
X;;do-inherited-messaging-Generate code for profiling inherited messaging
X
X(defmacro do-inherited-messaging (record level method)
X
X (let
X (
X (code NIL)
X )
X
X ;;Generate a new function symbol
X
X (push (gensym) *function-symbols*)
X
X ;;Push on 20 messagings
X
X (dotimes (i 20)
X
X (push
X (if *define-type-switch*
X `(=> g0f ,(intern (symbol-name method) (find-package 'keyword)))
X `(,(intern
X (symbol-name method)
X co::*keyword-standin-package*
X )
X g0f
X )
X )
X code
X
X ) ;push
X
X ) ;dotimes
X
X ;;Return code, inserting prolog and hardware cache
X ;; heating to another message.
X
X `(defun ,(first *function-symbols*) ()
X (let
X (
X (after 0)
X (before 0)
X (sum 0)
X )
X
X (tagbody
X again
X
X (do-garbage-collect)
X
X ,(if *define-type-switch*
X `(=> g0f ,(intern (symbol-name method) (find-package 'keyword)))
X `(,(intern
X (symbol-name method)
X co::*keyword-standin-package*
X )
X g0f
X )
X )
X
X
X (setf before (get-time))
X (macro-start-clock)
X ,@code
X (macro-end-clock)
X (setf after (get-time))
X
X (setf sum (macro-insert-sum))
X
X (if (< (the integer after) (the integer before))
X (go again)
X )
X )
X
X (if ,record
X (push (list 20 ,level (- after before) sum) *inherited-messaging-results*)
X )
X
X )
X
X )
X
X ) ;let
X
X) ;do-inherited-messaging
X
X(setf (symbol-function 'do-inherited-messaging-macro) (macro-function 'do-inherited-messaging))
X(compile 'do-inherited-messaging-macro)
X(setf (macro-function 'do-inherited-messaging) (symbol-function 'do-inherited-messaging-macro))
X
X;;print-results-Print the results to the file
X
X(defun print-results (filename fromwho)
X
X (with-open-file
X (istream filename :direction :output
X :if-exists :append
X :if-does-not-exist :create
X )
X
X (format istream "~%~%~A~%~%" fromwho)
X (format istream "~%~%Times are in msec. Clock increment:~F~%~%" *clock-increment-in-milliseconds*)
X
X
X
X (format istream "~1,8@T~1,8@T~1,8@TMacroexpand Times~%~%")
X (format istream
X "Operation~1,8@TSlots~1,8@TParents~1,8@TIterations~1,8@TTotal Time~1,8@TTime per Call~%~%"
X )
X (dolist (l (reverse *define-type-results*))
X (format istream
X "Define Type~1,8@T~D~1,8@T~D~1,8@T~D~1,8@T~1,8@T~8,2F~1,8@T~8,2F~%"
X (second l)
X (third l)
X (first l)
X (* (fifth l) *clock-increment-in-milliseconds*)
X (* (float (/ (fifth l) (first l))) *clock-increment-in-milliseconds*)
X )
X )
X (format istream
X "~%~%Operation~1,8@TIterations~1,8@TFunctions~1,8@TTotal Time~1,8@TTime per Call~%~%"
X )
X (dolist (l (reverse *define-method-results*))
X (format istream
X "Define Operation~1,8@T~D~1,8@T~D~1,8@T~1,8@T~8,2F~1,8@T~8,2F~%"
X (first l)
X (second l)
X (* (fourth l) *clock-increment-in-milliseconds*)
X (* (float (/ (fourth l) (first l))) *clock-increment-in-milliseconds*)
X )
X )
X (dolist (l (reverse *messaging-results*))
X (format istream
X "Operation Invocation~1,8@T~D~1,8@T~D~1,8@T~1,8@T~8,2F~1,8@T~8,2F~%"
X (first l)
X (second l)
X (* (fourth l) *clock-increment-in-milliseconds*)
X (* (float (/ (fourth l) (first l))) *clock-increment-in-milliseconds*)
X )
X )
X (format istream "~|")
X
X
X (format istream "~%~%~A~%~%" fromwho)
X (format istream "~%~%All Times in msec~%~%")
X
X (format istream "~1,8@T~1,8@T~1,8@TType Definition and Instance Creation~%~%")
X (format istream
X "Operation~1,8@TSlots~1,8@TParents~1,8@TIterations~1,8@TTotal Time~1,8@TTime per Call~%~%"
X )
X (dolist (l (reverse *define-type-results*))
X (format istream
X "Define Type~1,8@T~D~1,8@T~D~1,8@T~D~1,8@T~1,8@T~8,2F~1,8@T~8,2F~%"
X (second l)
X (third l)
X (first l)
X (* (fourth l) *clock-increment-in-milliseconds*)
X (* (float (/ (fourth l) (first l))) *clock-increment-in-milliseconds*)
X )
X )
X
X (dolist (l (reverse *creation-results*))
X (format istream
X "Create Instance~1,8@T~D~1,8@T~D~1,8@T~D~1,8@T~1,8@T~8,2F~1,8@T~8,2F~%"
X (second l)
X (third l)
X (first l)
X (* (fourth l) *clock-increment-in-milliseconds*)
X (* (float (/ (fourth l) (first l))) *clock-increment-in-milliseconds*)
X )
X )
X
X (format istream "~%~%~1,8@T~1,8@TOperation Creation and Invocation~%~%")
X (format istream
X "Operation~1,8@TIterations~1,8@TFunctions~1,8@TTotal Time~1,8@TTime per Call~%~%"
X )
X (dolist (l (reverse *define-method-results*))
X (format istream
X "Define Operation~1,8@T~D~1,8@T~D~1,8@T~1,8@T~8,2F~1,8@T~8,2F~%"
X (first l)
X (second l)
X (* (third l) *clock-increment-in-milliseconds*)
X (* (float (/ (third l) (first l))) *clock-increment-in-milliseconds*)
X )
X )
X
X (dolist (l (reverse *messaging-results*))
X (format istream
X "Operation Invocation~1,8@T~D~1,8@T~D~1,8@T~1,8@T~8,2F~1,8@T~8,2F~%"
X (first l)
X (second l)
X (* (third l) *clock-increment-in-milliseconds*)
X (* (float (/ (third l) (first l))) *clock-increment-in-milliseconds*)
X )
X )
X
X (format istream "~%~%~1,8@T~1,8@TInherited Operation Invocation~%~%")
X (format istream
X "Operation~1,8@TIterations~1,8@TParents~1,8@TTotal Time~1,8@TTime per Call~%~%"
X )
X
X (dolist (l (reverse *inherited-messaging-results*))
X (format istream
X "Operation Invocation~1,8@T~D~1,8@T~D~1,8@T~1,8@T~8,2F~1,8@T~8,2F~%"
X (first l)
X (second l)
X (* (third l) *clock-increment-in-milliseconds*)
X (* (float (/ (third l) (first l))) *clock-increment-in-milliseconds*)
X )
X )
X (format istream "~|")
X ) ;with-open-file
X
X (setf *define-type-results* NIL)
X (setf *creation-results* NIL)
X (setf *define-method-results* NIL)
X (setf *messaging-results* NIL)
X (setf *inherited-messaging-results* NIL)
X
X) ;print-results
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X(provide "co-profmacs")
X
END_OF_FILE
if test 20279 -ne `wc -c <'profmacs.l'`; then
echo shar: \"'profmacs.l'\" unpacked with wrong size!
fi
# end of 'profmacs.l'
fi
echo shar: End of archive 5 \(of 13\).
cp /dev/null ark5isdone
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