rs@uunet.UU.NET (Rich Salz) (07/31/87)
Submitted-by: Roy D'Souza <dsouza%hplabsc@hplabs.HP.COM>
Posting-number: Volume 10, Issue 75
Archive-name: comobj.lisp/Part01
#! /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 1 (of 13)."
# Contents: MANIFEST README co-defsys.l compat.l compile-it.sh
# excl-low.l hp-low.l kcl-low.l lucid-low.l ntype-of.l
# semantics.asci spice-low.l sublines ti-low.l trapd.l vaxl-low.l
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'MANIFEST' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'MANIFEST'\"
else
echo shar: Extracting \"'MANIFEST'\" \(1464 characters\)
sed "s/^X//" >'MANIFEST' <<'END_OF_FILE'
X File Name Archive # Description
X-----------------------------------------------------------
X 3600-low.l 2
X MANIFEST 1 This shipping list
X README 1
X braid.l 10
X class-prot.l 8
X class-slots.l 4
X co-defsys.l 1
X co-dmeth.l 7
X co-dtype.l 11
X co-macros.l 2
X co-meta.l 3
X co-parse.l 13
X co-prof.l 2
X co-sfun.l 2
X co-test.l 2
X compat.l 1
X compile-it.sh 1
X defclass.l 4
X defsys.l 3
X dfun-templ.l 2
X excl-low.l 1
X fixup.l 3
X fsc-low.l 4
X gfun-low.l 6
X high.l 3
X hp-low.l 1
X kcl-low.l 1
X low.l 8
X lucid-low.l 1
X macros.l 7
X meth-combi.l 5
X methods.l 12
X ntype-of.l 1
X pcl-patches.l 2
X profmacs.l 5
X regress.l 4
X semantics.asci 1
X spice-low.l 1
X sublines 1
X test.l 6
X ti-low.l 1
X trapd.l 1
X vaxl-low.l 1
X walk.l 9
X xerox-low.l 2
END_OF_FILE
if test 1464 -ne `wc -c <'MANIFEST'`; then
echo shar: \"'MANIFEST'\" unpacked with wrong size!
fi
# end of 'MANIFEST'
fi
if test -f 'README' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'README'\"
else
echo shar: Extracting \"'README'\" \(13990 characters\)
sed "s/^X//" >'README' <<'END_OF_FILE'
X Revised Instructions for Installing and Using
X CommonObjects on CommonLoops
X (COOL)
X
XI) INTRODUCTION
X
XCOOL is an implementation of HP's CommonObjects on
Xthe Portable CommonLoops (PCL) metaclass kernel.
XAs such, it provides a portable implementation of
XCommonObjects. It should be of particular interest
Xto people who want to program in the mixin style
Xsupported by PCL but are also interested in trying
Xthe encapsulation style of Smalltalk, which CommonObjects
Xsupports.
X
XThis version of COOL is guaranteed to work with Portable
XCommonLoops system date 2-24-87. A copy of this version
Xof Portable CommonLoops is distributed along with COOL.
X
XCOOL comes as a set of files grouped into four groups:
X
X 1) Documentation
X
X README-this file
X
X semantics.asci-Description of semantic differences
X between the CommonObjects specification in the
X document ATC-85-01, "Object Oriented Programming
X for Common Lisp," by Alan Snyder.
X
X 2) The System
X co-defsys.l
X pcl-patches.l
X co-parse.l
X co-dtype.l
X co-meta.l
X co-dmeth.l
X co-sfun.l
X
X 3) Test and Profiling files
X
X co-test.l-A generalized version of the PCL test macro.
X co-regress.l-Some simple regression tests for COOL.
X co-profmacs.l-Macros for simplifying profiling.
X co-prof.l-Profiling tests.
X
X 4) Portable CommonLoops (system date 2-24-87)
X The file <xxx>-low.l corresponds to the machine-dependent
X file for your system. For HP Lisp, this will be hp-low.l.
X
X walk.l
X macros.l
X low.l
X <xxx>-low.l
X braid.l
X class-slots.l
X defclass.l
X class-prot.l
X methods.l
X dfun-templ.l
X fixup.l
X high.l
X compat.l
X
XIf you are on a Un*x system, the COOL files will be in the
Xdirectory co/ and the PCL files will be in the directory pcl/.
X
XIf you have never programmed using CommonObjects, it is
Xsuggested you request a paper copy of ATC-85-01, "Object
XOriented Programming for Common Lisp," by Alan Snyder;
Xwhich is a specification of the CommonObjects language.
XIt can be obtained by sending electronic mail with your
Xname and address to mingus@hplabs.hp.com. If you are anxious
Xto get started and don't want to wait for the specification,
Xlook at some of the test examples in co-regress.l for
Xan idea of how to use CommonObjects.
X
XII) BRINGING UP PORTABLE COMMONLOOPS
XDirections are given in the file defsys.l
XBriefly, one edits the variables *pcl-pathname-defaults* (which
Xgives the location of the PCL files on your system). After that
Xthe PCL files can be compiled by invoking:
X
X (require "defsys")
X (pcl::compile-pcl)
X
Xand loaded by invoking:
X
X (pcl::load-pcl)
X
XIII) BRINGING UP COOL
X
XCool uses the PCL defsystem. Directions are given in the file
Xco-defsys.l . Briefly, in file co-defsys.l, one sets the variable
X*co-pathname-defaults* to correspond to the location of the files
Xon your local system. After that, the COOL files may be compiled by invoking:
X
X (require "co-defsys")
X (co:compile-co)
X
Xand loaded by invoking:
X
X (co:load-co)
X
XIn addition, the file pcl-patches.l contains a patch for
Xthe PCL function CLASS-OF. This function is specialized
Xfor each implementation of Common Lisp, but, in the
Xreleased version, it does not check if the type specifier
Xreturned by TYPE-OF is list. You will need to modify
Xthe SETQ of *CLASS-OF* in your implementation xxx-low.l
Xfile so that the function PCL::ATOM-TYPE-OF is called
Xon (TYPE-OF X) instead of simply TYPE-OF. To see how this was
Xdone for HP Lisp, look at the top of pcl-patches.l
XRemember to put the form:
X
X(eval-when (load eval)
X (recompile-class-of)
X
X)
X
Xin your file after you have rebound *CLASS-OF*; otherwise,
Xthe new definition will not take effect.
X
XIII) COMPILATION
X
XYou will probably want to compile COOL before using it,
Xunless your system doesn't have a compiler. There
Xare only three files in the COOL system itself. If
Xyou have set up your pathnames for REQUIRE correctly,
Xthen the following script should compile COOL:
X
X (require "co-defsys")
X (co:compile-co)
X
XYou may want to turn on optimizations before compiling.
XBefore doing this, it is suggested that you try the
Xregression tests without any optimizations, in case
Xyour optimizer does something which might cause the
Xsystem to break (like not checking for NIL during
Xa CAR or CDR operation). For profiling, however, it
Xis best to put as much optimization on as you think
Xcan safely be done.
X
XIV) LOADING
X
XTo load the system, do the following:
X (require "co-defsys")
X (co:load-co)
X
XV) USE
X
XThere are two steps needed to use the CommonObjects
Xobject oriented language extensions within your
XCommon Lisp.
X
XFirst, in the package where you plan to use
XCommonObjects, you need to get access to the CommonObjects
Xfunctions and macros. Do that by using the USE-PACKAGE
Xform:
X
X(in-package <your package>)
X(use-package 'co)
X
XYou will now have access to CommonObjects. Note to
Xusers on HP Lisp: it is not possible to use both
XCOOL and the system dependent CommonObjects implementation
Xin the same package, since a symbol conflict occurs
Xupon import of the CommonObjects symbols.
X
XIt is suggested that you avoid trying to use both
XPCL and COOL in the same package. It MAY work,
Xhowever, it has not been tried and is therefore
Xuntested. As a matter of good software engineering,
Xit also seems best to try to segment applications
Xwhich use both objects in different packages.
X
XSecond, there are a number of Common Lisp functions which
XCommonObjects semantics modify. These are EQL, EQUAL, EQUALP,
XTYPE-OF, and TYPEP. For more information on exactly what
Xthese modifications are, see ATC-85-01. Because redefining
Xthe default Lisp functions could be potentially very
Xdangerous or cause serious performance degradation, a
Xspecial macro has been constructed which SHADOWING-IMPORTs
Xthe redefined functions into a package using CO, without
Xredefining the Common Lisp functions throughout the entire
Xsystem. To get access to these functions, the macro
XIMPORT-SPECIALIZED-FUNCTIONS needs to be invoked after the
XCO package is used:
X
X (import-specialized-functions)
X
XThe Common Lisp functions will now locally reflect the
XCommonObjects semantics, but the global definitions
Xare still available by using full package qualification
Xof the names.
X
XHere is a short description of the available CommonObjects
Xoperations exported from CO. For a more detailed description,
Xsee ATC-85-01.
X
X(define-type <type name> <options>)
X
XDefine a CommonObjects type whose name is <type name>. There
Xare a whole host of options, including instance variable
X(slot) definition and inheritence. Macro.
X
X(define-method (<type name> <method name>) (<arguments>)
X <body>
X)
X
XDefine a CommonObjects method named <method name> on <type name>.
X<method name> will typically be a keyword but need not be. Macro.
X
X(call-method (<parent type name> <parent method name>) <arguments>)
X(call-method <method name> arguments)
X
X(apply-method (<parent type name> <parent method name>) &rest <arguments>)
X(apply-method <method name> &rest arguments)
X
XUsed to invoke a parent method or a method on SELF. The difference
Xfrom sending to SELF directly is that the method to call is
Xdetermined at compile time. The CALL-METHOD form is like FUNCALL,
XAPPLY-METHOD like APPLY. These forms are only valid within the
Xbody of a DEFINE-METHOD. Macros.
X
X(make-instance <type name> <initialization keyword list>)
X
XMake an instance of CommonObjects type <type name> The
X<initialization keyword list> is used to initialize
Xinstance variables and for other initialization purposes.
XPCL method.
X
X(=> <instance> <method name> <arguments>)
X
XInvoke operation <method name> on <instance> with <arguments>.
XThis invocation operator makes no checks for errors and
Xoperates at full PCL messaging speed. Note that all arguments
Xwill be evaluated. Macro.
X
X(send? <instance> <method name> <arguments>)
X
XInvoke operation <method name> on <instance> with <arguments>,
Xchecking to be sure <instance> is a valid CommonObjects
Xinstance and that it supports <method name> as an operation.
XReturns NIL if the operation cannot be invoked. This
Xinvocation operator is slow but safe. Note that all arguments
Xwill be evaluated. Macro.
X
X(instancep <arg>)
X
XReturns T if <arg> is a CommonObjects instance, NIL if
Xnot. Function.
X
X(supports-operation-p <arg> <method name>)
X
XReturns T if <arg> supports operation <method name>,
XNIL if not. Function.
X
X(assignedp <instance variable name>)
X
XReturns T if <instance variable name> has been assigned
Xa value, NIL if not. Valid only within a DEFINE-METHOD
Xbody. Macro.
X
X(undefine-type <type name>)
X
XUndefine the CommonObjects type <type name>. Returns T
Xif the type was undefined, NIL if not. Signals an error
Xif the argument is not a symbol. Function.
X
X(rename-type <old type name> <new type name>)
X
XRename <old type name> to <new type name>. Returns T
Xif the type was renamed. Signals an error if old
Xtype is not defined, if new type already exists,
Xor if the arguments are not symbols. Function.
X
X(undefine-method <type name> <method name>)
X
XUndefine the method <method name> on <type name>.
XSignals an error if <type name> is not a symbol or
Xif there is no type named <type name>. Issues a
Xwarning message if <method name> is a universal
Xmethod and the type has the default universal
Xmethods. Returns T if the operation was successful,
XNIL if not. Function.
X
X
XVI) REGRESSION TESTS
X
XThe file co-regress.l contains a series of regression
Xtests which test out important features of COOL.
XSome of these regression tests cause errors to be
Xsignalled, but, in order to have the tests complete
Xsuccessfully, the errors must be ignored. Since there
Xis no portable way defined in CLtL to modify error
Xhandling (short of redefining the CL function ERROR)
Xmost system implementors have added extensions to
Xdo the job.
X
XIf you don't know what the extensions are on your
Xsystem, or don't want to be bothered about trying
Xto find out, skip this paragraph and go on to
Xthe next, but first a warning: the tests requiring
Xerror handling will be skipped, but the result
Xmay be that some implementation dependent problem
Xis missed. If you know what the extensions are,
Xthen edit the file co-test.l. Go to the top
Xof the file and look for the special variable
X*WITHOUT-ERRORS*. This variable should contain
Xa function which generates the test with an error
Xcatcher in place around the code. Add
X#+<implementation name> to the list, and a LAMBDA
Xdefinition to return the proper test code with
Xerror catching. Note that the code should return T
Xif an error occurs, and NIL if not, for the
Xtest macro to work correctly. When you are done,
Xmail that portion of the file with your system
Xdependent code to cool@hplabs.hp.com.
X
XTo run the regression tests, simply REQUIRE the
Xfile co-regress.l:
X
X (require "co-regress")
X
XThe test results will be printed to the standard
Xoutput.
X
XNote that the regression tests make no checks
Xfor compilation, since the compilation semantics
Xof PCL (upon which COOL is based) are very weakly
Xdefined. File compilation should work, however.
X
XVII) PROFILING
X
XIf you're really feeling ambitious, you may even
Xwant to run the profiling tests to see how well
Xyour COOL is performing.
X
XAgain, there are some implementation dependencies
Xwhich should be addressed before running the profiling
Xtests. Probably the most important is that the name
Xof the implementation's garbage collector be known.
XIf this is NOT done, then you run the risk of having
Xa garbage collect occur in the middle of the profiling,
Xwhich will destroy your measurements. If your system
Xhas a large enough virtual image, however, garbage
Xcollection may not be a problem.
X
XEdit the file co-profmacs.l and look at the top below
Xthe header. The function cell of the symbol
XDO-GARBAGE-COLLECT should be set to the function
Xfor your implementation's garbage collector. Be
Xsure to put a #+<implementation name> before any
Ximplementation dependent code you may add. The default
Xfor garbage collection is to simply warn the user
Xthat the measurements may be in error because
Xthe test can't garbage collect.
X
XYou may also want to add any implementation dependent
Xcode for getting clock values. The default is the
XCommon Lisp function GET-INTERNAL-REAL-TIME, and
Xthe clock increment in milliseconds (in the
Xspecial variable *CLOCK-INCREMENT-IN-MILLISECONDS*)
Xis calculated using the Common Lisp special
XINTERNAL-TIME-UNITS-PER-SECOND. However, many
Ximplementations may have special ways of getting
Xclock values, and these should be added here.
X
XPlease send any implementation dependent changes
Xto cool@hplabs.hp.com.
X
XThe results of the profiling tests are put into
Xa file whose name (as a string) is bound to the
Xspecial variable TEST::*OUTPUT-FILE-NAME*. The
Xdefault string is "runprof.out", as can be
Xseen by checking the special variable definition
Xfor *OUTPUT-FILE-NAME* at the top of co-prof.l.
XIf you want the results in another file, please
XSETF this variable to the file name before
Xstarting the profiling:
X
X (in-package 'test)
X (setf *output-file-name* <your file name>)
X
XTo run the profiling tests, just:
X
X (require "co-prof")
X
Xand, providing you've set up your REQUIRE pathnames
Xcorrectly, you should find it.
X
XNote that profiling may take quite a while, and
Xit is a good idea to have as little else going on
Xon your machine as possible during the tests.
X
XIf you feel you want to distribute the profile
Xinformation, you may want to send it to
Xcool@hplabs.hp.com with a brief description of
Xyour system. It might help identify particular
Ximplementation dependencies which are causing
Xperformance problems.
X
XVIII) CONCLUSION
X
XIf you have problems with COOL or find any bugs,
Xplease report them to cool@hplabs.hp.com. It
Xis most helpful if the bug can be as isolated
Xas possible (e.g. "It broke when I defined
Xtype xxx" is less easy to trace down than
Xa backtrace listing where it broke). It may
Xbe difficult to track all implementations of
XCommon Lisp, but an effort will be made to
Xkeep COOL running as long as people are
Xinterested.
X
END_OF_FILE
if test 13990 -ne `wc -c <'README'`; then
echo shar: \"'README'\" unpacked with wrong size!
fi
# end of 'README'
fi
if test -f 'co-defsys.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'co-defsys.l'\"
else
echo shar: Extracting \"'co-defsys.l'\" \(4339 characters\)
sed "s/^X//" >'co-defsys.l' <<'END_OF_FILE'
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; File: co-defsys.l
X; RCS: $Revision: 1.1 $
X; SCCS: %A% %G% %U%
X; Description: System Definition for CommonObjects
X; Author: James Kempf, HP/DCC
X; Created: 11-Mar-87
X; Modified: 11-Mar-87 22:08:34 (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:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
X;;;
X;;; *************************************************************************
X;;; Copyright (c) 1985, 1986, 1987 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(provide "co-defsys")
X
X(in-package 'common-objects :nicknames '(co) :use '(lisp pcl walker))
X
X(export '(compile-co
X load-co
X run-tests
X ))
X
X(require "pcl") ; Portable CommonLoops
X
X(defvar *co-system-date* "3/10/87")
X
X(defvar *co-pathname-defaults*
X (pathname "/net/hplfs2/users/kempf/public/cool/")
X
X)
X
X(defvar *co-files*
X (let ((xxx-low (or #+KCL 'kcl-low ; placeholder
X #+HP 'hp-low
X nil)))
X ;; file load compile files which force
X ;; environment environment recompilations of
X ;; this file
X `(
X (pcl-patches nil nil nil)
X (co-macros t (pcl-patches
X (co-macros :source)) (pcl-patches))
X (co-dmeth t (co-macros
X pcl-patches)
X (co-macros pcl-patches))
X (co-meta t (co-macros
X pcl-patches
X (co-meta :source))
X (co-macros pcl-patches))
X (co-dtype t (co-macros
X pcl-patches) (co-macros pcl-patches))
X (co-sfun t (co-macros
X pcl-patches) (co-macros))
X )))
X
X(defmacro wrong-pcl-version? ()
X '(not (string-equal "2/24/87" pcl::*pcl-system-date*)))
X
X(defmacro error-wrong-pcl ()
X '(error
X"This version of CommonObjects will only run with
XPortable CommonLoops Version 'System Date 2/24/87'.
XThis version of PCL may be obtained by sending mail
Xto commonobjects-request@hplabs.hp.com"))
X
X(defun load-co (&optional (sources-p nil))
X (when (wrong-pcl-version?) (error-wrong-pcl))
X (pcl::load-system
X (if sources-p :sources :load) *co-files* *co-pathname-defaults*)
X (provide "co"))
X
X(defun compile-co (&optional (force-p nil))
X (when (wrong-pcl-version?) (error-wrong-pcl))
X (pcl::load-system
X (if force-p ':force ':compile) *co-files* *co-pathname-defaults*))
X
X(defun run-tests ()
X (load "co-test.l")
X (load "co-regress.l")
X)
X
X;;; end of co-defsys.l ;;;;;
X
END_OF_FILE
if test 4339 -ne `wc -c <'co-defsys.l'`; then
echo shar: \"'co-defsys.l'\" unpacked with wrong size!
fi
# end of 'co-defsys.l'
fi
if test -f 'compat.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'compat.l'\"
else
echo shar: Extracting \"'compat.l'\" \(1942 characters\)
sed "s/^X//" >'compat.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(defmacro run-super () '(call-next-method))
X
X
X(defun convert-with-first-arg (first-arg use-slot-value)
X (iterate ((opc in first-arg))
X (or (listp opc) (setq opc (list opc)))
X (collect
X ;; Can't use the obvious backquote in Genera!
X (let ((entry ()))
X (when use-slot-value
X (push t entry)
X (push :use-slot-value entry))
X (when (cddr opc)
X (push (caddr opc) entry)
X (push :class entry))
X (when (cadr opc)
X (push (cadr opc) entry)
X (push :prefix entry))
X (cons (car opc) entry)))))
X
X(defmacro with (objects-prefixes-and-classes &body body)
X `(with-slots ,(convert-with-first-arg objects-prefixes-and-classes nil)
X . ,body))
X
X(defmacro with* (objects-prefixes-and-classes &body body)
X `(with-slots ,(convert-with-first-arg objects-prefixes-and-classes t)
X . ,body))
X
END_OF_FILE
if test 1942 -ne `wc -c <'compat.l'`; then
echo shar: \"'compat.l'\" unpacked with wrong size!
fi
# end of 'compat.l'
fi
if test -f 'compile-it.sh' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'compile-it.sh'\"
else
echo shar: Extracting \"'compile-it.sh'\" \(410 characters\)
sed "s/^X//" >'compile-it.sh' <<'END_OF_FILE'
X#!/bin/sh
X# Load CommonLoops, compile and test COOL.
X
XCL=${CL-'/lisp/bin/cl'} # change this to point to your local
X # Common Lisp
XPCL=${PCL-'/net/hplfs2/users/kempf/public/pcl'}
X
Xecho "Compiling Portable CommonLoops"
X$CL <<EOF
X#+HP(compile-file "defsys.l")
X#-HP(compile-file "defsys.lsp")
X(load "defsys")
X(pcl::compile-pcl)
X(sys::exit)
XEOF
X
Xecho "Done Compiling Portable CommonLoops"
X
END_OF_FILE
if test 410 -ne `wc -c <'compile-it.sh'`; then
echo shar: \"'compile-it.sh'\" unpacked with wrong size!
fi
# end of 'compile-it.sh'
fi
if test -f 'excl-low.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'excl-low.l'\"
else
echo shar: Extracting \"'excl-low.l'\" \(3881 characters\)
sed "s/^X//" >'excl-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 EXCL (Franz) lisp version of the file portable-low.
X;;;
X;;; This is for version 1.1.2. Many of the special symbols now in the lisp
X;;; package (e.g. lisp::pointer-to-fixnum) will be in some other package in
X;;; a later release so this will need to be changed.
X;;;
X
X(in-package 'pcl)
X
X(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 )
X
X(defmacro load-time-eval (form)
X (cond ((and sys:*macroexpand-for-compiler* sys:*compile-to-core*)
X `',(eval form))
X ((and sys:*macroexpand-for-compiler* sys:*compile-to-file*)
X ;(cerror "go ahead" "called load-time-eval in compile-to-file")
X `'(,compiler::*eval-when-load-marker* . ,form))
X (t
X `(progn ,form))))
X
X(eval-when (compile load eval)
X (unless (fboundp 'excl::sy_hash)
X (setf (symbol-function 'excl::sy_hash)
X (symbol-function 'excl::_sy_hash-value))))
X
X(defmacro symbol-cache-no (symbol mask)
X (if (and (constantp symbol)
X (constantp mask))
X `(load-time-eval (logand (ash (excl::sy_hash ',symbol) -1) ,mask))
X `(logand (ash (the fixnum (excl::pointer-to-fixnum ,symbol)) -1)
X (the fixnum ,mask))))
X
X(defmacro object-cache-no (object mask)
X `(logand (the fixnum (excl::pointer-to-fixnum ,object))
X (the fixnum ,mask)))
X
X(defun printing-random-thing-internal (thing stream)
X (format stream "~O" (excl::pointer-to-fixnum thing)))
X
X
X(defun function-arglist (f)
X (excl::arglist f))
X
X
X(defun symbol-append (sym1 sym2 &optional (package *package*))
X ;; This is a version of symbol-append from macros.cl
X ;; It insures that all created symbols are of one case and that
X ;; case is the current prefered case.
X ;; This special version of symbol-append is not necessary if all you
X ;; want to do is compile and run pcl in a case-insensitive-upper
X ;; version of cl.
X ;;
X (let ((string (string-append sym1 sym2)))
X (case excl::*current-case-mode*
X ((:case-insensitive-lower :case-sensitive-lower)
X (setq string (string-downcase string)))
X ((:case-insensitive-upper :case-sensitive-upper)
X (setq string (string-upcase string))))
X (intern string package)))
X
X;(eval-when (compile load eval)
X; (let ((consts
X; (sys:memref (symbol-function 'compiler::pa-macrolet)
X; (compiler::mdparam 'compiler::md-function-constant-adj)
X; 0
X; :lisp)))
X; (dotimes (i (length consts))
X; (cond ((eq 'compiler::macro (svref consts i))
X; (setf (svref consts i) 'excl::macro)
X; (format t "fixed in slot ~s~%" i))
X; ((eq 'excl::macro (svref consts i))
X; (format t "already fixed in slot ~s~%" i))))))
X
END_OF_FILE
if test 3881 -ne `wc -c <'excl-low.l'`; then
echo shar: \"'excl-low.l'\" unpacked with wrong size!
fi
# end of 'excl-low.l'
fi
if test -f 'hp-low.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'hp-low.l'\"
else
echo shar: Extracting \"'hp-low.l'\" \(3874 characters\)
sed "s/^X//" >'hp-low.l' <<'END_OF_FILE'
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; File: new-hp-low.l
X; SCCS: %A% %G% %U%
X; Description: Revised hp-low.l
X; Author: James Kempf, HP/DCC
X; Created: 16-Jul-86
X; Modified: 26-Feb-87 13:35:43 (James Kempf)
X; Language: Lisp
X; Package: USER
X; Status: Experimental (Do Not Distribute)
X;
X; (c) Copyright 1986, James Kempf, all rights reserved.
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
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 HP Common Lisp version of the file low.
X;;;
X;;;
X
X(in-package 'pcl)
X
X ;;
X;;;;;; Load Time Eval
X ;;
X;;;
X;;; #, is woefully inadequate. You can't use it inside of a macro and have
X;;; the expansion of part of the macro be evaluated at load-time its kind of
X;;; a joke. load-time-eval is used to provide an interface to implementation
X;;; dependent implementation of load time evaluation.
X;;;
X;;; A compiled call to load-time-eval:
X;;; should evaluated the form at load time,
X;;; but if it is being compiled-to-core evaluate it at compile time
X;;; Interpreted calls to load-time-eval:
X;;; should just evaluate form at run-time.
X;;;
X;;; The portable implementation just evaluates it every time, and PCL knows
X;;; this. PCL is careful to only use load-time-eval in places where (except
X;;; for performance penalty) it is OK to evaluate the form every time.
X;;;
X;;(defmacro load-time-eval (form)
X;; `(progn ,form))
X;;(defmacro load-time-eval (form)
X;; `(impl::loadtime ,form))
X
X(defmacro load-time-eval (form)
X `(eval-when (load eval) ,form))
X
X
X(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 (type-of x) t)
X (error "Can't determine class of ~S." x)
X )
X )
X )
X )
X)
X
X(eval-when (load eval)
X (recompile-class-of)
X)
X ;;
X;;;;;; Cache No's
X ;;
X
X;;; Grab the top 29 bits
X;;;
X(defmacro symbol-cache-no (symbol mask)
X;`(logand (prim:@inf ,symbol) ,mask) ; 33% hit rate
X `(logand (ash (prim:@inf ,symbol) -5) ,mask)) ; 83% hit rate
X; `(the extn::index (logand (prim::@>> ,symbol 4) ,mask))) ; 75% hit rate
X
X(defmacro object-cache-no (symbol mask)
X `(logand (ash (prim:@inf ,symbol) -5) ,mask))
X
X ;;
X;;;;;; printing-random-thing-internal
X ;;
X(defun printing-random-thing-internal (thing stream)
X (format stream "~O" (prim:@inf thing)))
X
X
END_OF_FILE
if test 3874 -ne `wc -c <'hp-low.l'`; then
echo shar: \"'hp-low.l'\" unpacked with wrong size!
fi
# end of 'hp-low.l'
fi
if test -f 'kcl-low.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'kcl-low.l'\"
else
echo shar: Extracting \"'kcl-low.l'\" \(2844 characters\)
sed "s/^X//" >'kcl-low.l' <<'END_OF_FILE'
X;;; -*- Mode: LISP; Syntax: Common-lisp; Package: (PCL Lisp 1000); Base: 10. -*-
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;;; The version of low for Kyoto Common Lisp (KCL)
X(in-package 'pcl)
X
X ;;
X;;;;;; Load Time Eval
X ;;
X;;;
X
X;;; This doesn't work because it looks at a global variable to see if it is
X;;; in the compiler rather than looking at the macroexpansion environment.
X;;;
X;;; The result is that if in the process of compiling a file, we evaluate a
X;;; form that has a call to load-time-eval, we will get faked into thinking
X;;; that we are compiling that form.
X;;;
X;;; THIS NEEDS TO BE DONE RIGHT!!!
X;;;
X;(defmacro load-time-eval (form)
X; ;; In KCL there is no compile-to-core case. For things that we are
X; ;; "compiling to core" we just expand the same way as if were are
X; ;; compiling a file since the form will be evaluated in just a little
X; ;; bit when gazonk.o is loaded.
X; (if (and (boundp 'compiler::*compiler-input*) ;Hack to see of we are
X; compiler::*compiler-input*) ;in the compiler!
X; `'(si:|#,| . ,form)
X; `(progn ,form)))
X
X
X ;;
X;;;;;; The %instance datastructure.
X ;;
X
X
X ;;
X;;;;;; Generating CACHE numbers
X ;;
X;;; This needs more work to be sure it is going as fast as possible.
X;;; - The calls to si:address should be open-coded.
X;;; - The logand should be open coded.
X;;;
X
X(defmacro symbol-cache-no (symbol mask)
X (if (and (constantp symbol)
X (constantp mask))
X `(load-time-eval (logand (ash (si:address ,symbol) -2) ,mask))
X `(logand (ash (the fixnum (si:address ,symbol)) -2) ,mask)))
X
X(defmacro object-cache-no (object mask)
X `(logand (the fixnum (si:address ,object)) ,mask))
X
X ;;
X;;;;;; printing-random-thing-internal
X ;;
X(defun printing-random-thing-internal (thing stream)
X (format stream "~O" (si:address thing)))
X
X
END_OF_FILE
if test 2844 -ne `wc -c <'kcl-low.l'`; then
echo shar: \"'kcl-low.l'\" unpacked with wrong size!
fi
# end of 'kcl-low.l'
fi
if test -f 'lucid-low.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'lucid-low.l'\"
else
echo shar: Extracting \"'lucid-low.l'\" \(3690 characters\)
sed "s/^X//" >'lucid-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 Lucid lisp version of the file portable-low.
X;;;
X;;; Lucid: (415)329-8400
X;;; Sun: Steve Gadol (415)960-1300
X;;;
X
X(in-package 'pcl)
X
X ;;
X;;;;;; Memory Block primitives.
X ;;
X
X(defmacro make-memory-block (size &optional area)
X (ignore area)
X `(make-array ,size))
X
X;;;
X;;; Reimplementation OF %INSTANCE
X;;;
X;;; We take advantage of the fact that Lucid 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 our %instance datatype, the array look like
X;;;
X;;; structure type: The symbol %INSTANCE, this tells the system what kind
X;;; of structure this is.
X;;; element 0: The meta-class of this %INSTANCE
X;;; element 1: This is used to store the value of %instance-ref slot 0.
X;;; element 2: 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(defmacro %make-instance (meta-class size)
X (let ((instance-var (gensym)))
X `(let ((,instance-var (lucid::new-structure (1+ ,size) '%instance)))
X (setf (lucid::structure-ref ,instance-var 0 '%instance) ,meta-class)
X ,instance-var)))
X
X(defmacro %instance-ref (instance index)
X `(lucid::structure-ref ,instance (1+ ,index) '%instance))
X
X
X ;;
X;;;;;; Cache No's
X ;;
X
X;;; Grab the top 29 bits
X;;;
X(lucid::defsubst symbol-cache-no (symbol mask)
X (logand (lucid::%field symbol 3 29) mask))
X
X;;; Same here
X;;;
X(lucid::defsubst object-cache-no (object mask)
X (logand (lucid::%field object 3 29) mask))
X
X ;;
X;;;;;; printing-random-thing-internal
X ;;
X(defun printing-random-thing-internal (thing stream)
X (format stream "~O" (lucid::%pointer thing)))
X
X
X(in-package 'lucid)
X
X(defun output-structure (struct currlevel)
X (let ((type (structure-type struct)))
X (multiple-value-bind (length struct-type constructor print-function)
X (defstruct-info type)
X (declare (ignore struct-type constructor))
X (if (not *print-structure*)
X (output-terse-object struct
X (if (streamp struct) "Stream" "Structure")
X type)
X (funcall (if print-function
X (symbol-function print-function)
X #'default-structure-print)
X struct *print-output* currlevel)))))
X
END_OF_FILE
if test 3690 -ne `wc -c <'lucid-low.l'`; then
echo shar: \"'lucid-low.l'\" unpacked with wrong size!
fi
# end of 'lucid-low.l'
fi
if test -f 'ntype-of.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'ntype-of.l'\"
else
echo shar: Extracting \"'ntype-of.l'\" \(3698 characters\)
sed "s/^X//" >'ntype-of.l' <<'END_OF_FILE'
X;;;-*- Mode:LISP; Package: (ntype-of 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(in-package 'ntype-of)
X
X(defvar *portable-types*
X `(number
X (ratio 1/2)
X (complex #c(1 2) complexp)
X ((integer fixnum bignum) 1 integerp)
X ((float short-float single-float double-float long-float) 1.1 floatp)
X (null () null)
X ((character standard-char string-char) #\a characterp)
X (simple-bit-vector #*101 simple-bit-vector-p)
X (bit-vector ,(make-array 3 :element-type 'bit) bit-vector-p)
X (simple-array ,(make-array 10))
X (string ,(make-string 3) stringp)
X (simple-vector #(1 2 3))
X (array (make-array 3 :displaced-to (make-array 3)) arrayp)
X ))
X
X(defvar *portable-types*
X `(t
X (array (make-array 3 :displaced-to (make-array 3)) arrayp)
X (simple-bit-vector #*101 simple-bit-vector-p)
X (bit-vector ,(make-array 3 :element-type 'bit) bit-vector-p)
X (simple-array ,(make-array 10))
X ))
X
X(defvar *portable-type-lattice*)
X
X(defstruct (node (:conc-name node-)
X (:constructor make-node (type entry))
X (:print-function
X (lambda (node stream d)
X (declare (ignore d))
X (format stream "#<node ~S ~:S ~:S>"
X (node-type node)
X (mapcar #'node-type (node-supers node))
X (mapcar #'node-type (node-subs node))))))
X type
X supers
X subs
X entry)
X
X(defun make-type-lattice ()
X (macrolet ((memq (x l) `(member ,x ,l :test #'eq))
X (delq (x l) `(delete ,x ,l :test #'eq)))
X (flet ((entry-type (entry) ;type of an element
X (cond ((symbolp entry) entry) ;of *portable-types*
X ((symbolp (car entry)) (car entry))
X (t (caar entry))))
X (add-super (node super)
X (setf (node-supers node) (cons super (node-supers node))
X (node-subs super) (cons node (node-subs super))))
X (remove-super (node super)
X (setf (node-supers node) (delq super (node-supers node))
X (node-subs super) (delq node (node-subs super)))))
X (let ((nodes (mapcar #'(lambda (entry)
X (make-node (entry-type entry) entry))
X *portable-types*)))
X (setq *portable-type-lattice* (find 't nodes :key #'node-type))
X (dolist (n1 nodes)
X (dolist (n2 (cdr (memq n1 nodes)))
X (cond ((subtypep (node-type n1) (node-type n2))
X (add-super n1 n2))
X ((subtypep (node-type n2) (node-type n1))
X (add-super n2 n1)))))
X (dolist (node nodes)
X (dolist (super1 (node-supers node))
X (dolist (super2 (cdr (node-supers node)))
X (unless (eq super1 super2)
X (when (subtypep (node-type super1) (node-type super2))
X (remove-super node super2))))))
X nodes))))
X
X(defun prune-type-lattice (lattice subs)
X (cond ((null subs) nil)
X (
X
X )))
X
END_OF_FILE
if test 3698 -ne `wc -c <'ntype-of.l'`; then
echo shar: \"'ntype-of.l'\" unpacked with wrong size!
fi
# end of 'ntype-of.l'
fi
if test -f 'semantics.asci' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'semantics.asci'\"
else
echo shar: Extracting \"'semantics.asci'\" \(2675 characters\)
sed "s/^X//" >'semantics.asci' <<'END_OF_FILE'
X
X Semantic Changes for CommonObjects
X on CommonLoops (COOL)
X
X
X1) It is not possible to have seperately defined methods
X inherited if the methods and the child types are
X defined in the same file as the parent. Methods which are generated
X by the parent type definition are inheritable, however.
X In general, defining parent types and methods and
X child types and methods in seperate files is a good idea.
X The parent types and methods must be defined in the
X compile time environment of the child.
X
X2) The universal methods :PRINT, :DESCRIBE, :TYPEP, :COPY,
X :COPY-INSTANCE, :COPY-STATE, :EQL, :EQUAL, :EQUALP
X :INIT, and :INITIALIZE
X are defined in common for all CommonObjects types. The
X user can redefine these methods for a particular type,
X but cannot undefine them if the type uses the default
X method. A warning message is issued if the user tries
X to undefine a default universal method.
X
X3) SELF is SETF-able within a method. SELF will also
X be accepted as an instance variable name.
X
X4) The :VARIABLES suboption for inheritence is not
X supported. Trying to use it will cause an error
X during type definition.
X
X5) The :TYPE suboption of :VAR has no effect. It
X may be included (for documentation purposes)
X and will not cause an error to be signalled.
X
X6) An instance variable named SET-x and an
X instance variable named x which is declared
X settable in the same type cause no warning
X message to be generated.
X
X7) Types are fully defined at compile time (minus
X generated methods). Compiling a type will thus
X cause a defined type in the environment to be
X trashed. The actual time when the type is defined
X is during expansion of the DEFINE-TYPE macro.
X
X8) In order to have the universal methods invoked for
X the Lisp functions TYPEP, EQL, EQUAL, and EQUALP
X and have TYPE-OF return the CommonObjects type
X rather than the Lisp type for a CommonObjects
X object, the macro CO:IMPORT-SPECIALIZED-FUNCTIONS
X must be invoked in the package where CommonObjects
X is to be used. Special functions which shadow the
X defined Lisp functions are used to avoid problems
X with infinite recursion and excessive CONSing
X which may otherwise result. In addition, the
X default universal method for TYPEP does not
X signal an error when an undefined type name
X is given.
X
X9) The argument lists of methods with the same
X name on different types must match. The
X exact rules for argument conformity are
X outlined in the Common Lisp Object System
X document (the proposed standard) but for purposes
X of COOL, the lists must have the same number
X of required, &REST, and keyword parameters.
X
END_OF_FILE
if test 2675 -ne `wc -c <'semantics.asci'`; then
echo shar: \"'semantics.asci'\" unpacked with wrong size!
fi
# end of 'semantics.asci'
fi
if test -f 'spice-low.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'spice-low.l'\"
else
echo shar: Extracting \"'spice-low.l'\" \(2846 characters\)
sed "s/^X//" >'spice-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 Spice Lisp version of the file portable-low.
X;;;
X;;; History:
X;;; 7-Dec-86
X;;; Rick Busdiecker (rfb) at Carnegie-Mellon University
X;;; Added suggested change from Gregor Kiczales @ Parc
X;;; ??-???-??
X;;; CMU: David B. McDonald (412)268-8860
X;;; Modified.
X;;; ??-???-??
X;;; Skef Wholey at Carnegie-Mellon University
X;;; Created.
X;;;
X;;;
X;;;
X
X(in-package 'pcl)
X
X ;;
X;;;;;; Cache No's
X ;;
X
X;;; Abuse the type declaration, but it generates great code.
X
X(defun symbol-cache-no (symbol mask)
X (logand (the fixnum (%primitive lisp::make-immediate-type
X symbol
X system::%+-fixnum-type))
X (the fixnum mask)))
X
X(clc::deftransform symbol-cache-no symbol-cache-no-transform (symbol mask)
X `(logand (the fixnum (%primitive lisp::make-immediate-type
X ,symbol
X system::%+-fixnum-type))
X (the fixnum ,mask)))
X
X(defun object-cache-no (symbol mask)
X (logand (the fixnum (%primitive lisp::make-immediate-type
X symbol
X system::%+-fixnum-type))
X (the fixnum mask)))
X
X(clc::deftransform object-cache-no object-cache-no-transform (symbol mask)
X `(logand (the fixnum (%primitive make-immediate-type
X ,symbol
X system::%+-fixnum-type))
X (the fixnum ,mask)))
X
X
X
X(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
X (and (null object) (class-named 'nil))
X (and (stringp object) (class-named 'string))
X (and (ratiop object) (class-named 'rational))
X (and (streamp object) (class-named 'stream))
X
X (class-named (type-of x) t)
X (error "Can't determine class of ~S" x)))))
X
END_OF_FILE
if test 2846 -ne `wc -c <'spice-low.l'`; then
echo shar: \"'spice-low.l'\" unpacked with wrong size!
fi
# end of 'spice-low.l'
fi
if test -f 'sublines' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'sublines'\"
else
echo shar: Extracting \"'sublines'\" \(274 characters\)
sed "s/^X//" >'sublines' <<'END_OF_FILE'
Xvi 3600-low.l braid.l class-prot.l class-slots.l compat.l compile-it.sh defsys.l defclass.l fixup.l fsc-low.l gfun-low.l high.l hp-low.l kcl-low.l low.l lucid-low.l macros.l meth-combi.l methods.l ntype-of.l spice-low.l test.l ti-low.l trapd.l vaxl-low.l walk.l xerox-low.l
END_OF_FILE
if test 274 -ne `wc -c <'sublines'`; then
echo shar: \"'sublines'\" unpacked with wrong size!
fi
# end of 'sublines'
fi
if test -f 'ti-low.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'ti-low.l'\"
else
echo shar: Extracting \"'ti-low.l'\" \(1881 characters\)
sed "s/^X//" >'ti-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;;;;;; Cache No's
X ;;
X
X(defmacro symbol-cache-no (symbol mask)
X `(logand (si::%pointer ,symbol) ,mask))
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(eval-when (compile load eval) ;There seems to be some bug with
X (setq si::inhibit-displacing-flag t)) ;macrolet'd macros or something.
X ;This gets around it but its not
X ;really the right fix.
X
END_OF_FILE
if test 1881 -ne `wc -c <'ti-low.l'`; then
echo shar: \"'ti-low.l'\" unpacked with wrong size!
fi
# end of 'ti-low.l'
fi
if test -f 'trapd.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'trapd.l'\"
else
echo shar: Extracting \"'trapd.l'\" \(2353 characters\)
sed "s/^X//" >'trapd.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;;; Trapped discriminators.
X;;;
X;;; These allow someone to declare that for a given selector, the methods
X;;; should actually be defined on some other selector, the so-called trap-
X;;; selector.
X;;;
X;;; An example of its use is:
X;;; (make-primitive-specializable 'car 'car-trap)
X;;;
X
X(in-package 'pcl)
X
X(ndefstruct (trapped-discriminator-mixin
X (:class class)
X (:include discriminator)
X (:conc-name trapped-discriminator-))
X (trap-discriminator ()))
X
X(defmeth trapped-discriminator-selector ((self trapped-discriminator-mixin))
X (let ((td (trapped-discriminator-trap-discriminator self)))
X (and td (discriminator-name td))))
X
X(defmeth add-method-internal ((self trapped-discriminator-mixin)
X (method basic-method))
X (with (self) (add-method-internal trap-discriminator method)))
X
X(ndefstruct (trapped-discriminator
X (:class class)
X (:include (trapped-discriminator-mixin discriminator))))
X
X(defun make-primitive-specializable (name trap-selector &rest options)
X (let ((trap-discriminator
X (apply #'make-specializable trap-selector arglist)))
X (setf (discriminator-named name)
X (make 'trapped-discriminator
X :name name
X :trap-discriminator trap-discriminator))))
X
X
END_OF_FILE
if test 2353 -ne `wc -c <'trapd.l'`; then
echo shar: \"'trapd.l'\" unpacked with wrong size!
fi
# end of 'trapd.l'
fi
if test -f 'vaxl-low.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'vaxl-low.l'\"
else
echo shar: Extracting \"'vaxl-low.l'\" \(1932 characters\)
sed "s/^X//" >'vaxl-low.l' <<'END_OF_FILE'
X;;; -*- Mode: LISP; Syntax: Common-lisp; Package: (PCL Lisp 1000); Base: 10. -*-
X;;;
X;;; *******************************************************************************
X;;; Copyright (c) 1985 Xerox Corporation. All rights reserved.
X;;;
X;;; Use and copying of this software and preparation of derivative works based upon
X;;; this software are permitted. Any distribution of this software or derivative
X;;; works must comply with all applicable United States export control laws.
X;;;
X;;; This software is made available AS IS, and Xerox Corporation makes no warranty
X;;; about the software, its performance or its conformity to any specification.
X;;;
X;;; Any person obtaining a copy of this software is requested to send their name
X;;; 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;;; The version of low for VAXLisp
X(in-package 'pcl)
X
X ;;
X;;;;;; Load Time Eval
X ;;
X(defmacro load-time-eval (form)
X `(progn ,form))
X
X ;;
X;;;;;; Generating CACHE numbers
X ;;
X;;; How are symbols in VAXLisp actually arranged in memory?
X;;; Should we be shifting the address?
X;;; Are they relocated?
X;;; etc.
X
X(defmacro symbol-cache-no (symbol mask)
X `(logand (the fixnum (system::%sp-pointer->fixnum ,symbol)) ,mask))
X
X(defmacro object-cache-no (object mask)
X `(logand (the fixnum (system::%sp-pointer->fixnum ,object)) ,mask))
X
X ;;
X;;;;;; printing-random-thing-internal
X ;;
X(defun printing-random-thing-internal (thing stream)
X (format stream "~O" (system::%sp-pointer->fixnum thing)))
X
X
X(defun function-arglist (fn)
X (system::function-lambda-vars (symbol-function fn)))
X
END_OF_FILE
if test 1932 -ne `wc -c <'vaxl-low.l'`; then
echo shar: \"'vaxl-low.l'\" unpacked with wrong size!
fi
# end of 'vaxl-low.l'
fi
echo shar: End of archive 1 \(of 13\).
cp /dev/null ark1isdone
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.uuuuw.l