;;; -*- mode:lisp;package:user;base:10.;fonts:cptfontb -*- ;;; $Header: /ct/ctlisp/ctflav.l,v 1.25 84/08/16 16:25:26 penny Exp $ ;;; $Log: /ct/ctlisp/ctflav.l,v $ ;;; ;;; Hacked 14 August 1985 Richard Mark Soley for Lambda port. ;;; ;;;Revision 1.25 84/08/16 16:25:26 penny ;;;Fixed -> THE LAST BUG <- in KEYWORDIFY. Soley. ;;; ;;;Revision 1.24 84/08/15 19:07:35 penny ;;;Fix GET-IV and SET-IV (and CT_CSEND) to use the new KEYWORDIFY ;;;properly. I hope nobody else uses KEYWORDIFY! Soley. ;;; ;;;Revision 1.23 84/08/15 15:06:36 bill ;;;Yet another change to KEYWORDIFY, to insure that any valid answer ;;;it returns is quotified (viva Release 4.5!). Soley. ;;; ;;;Revision 1.22 84/08/15 11:34:32 alfred ;;;fix ct_defmethod to work with the new keywordify ;;; ;;;Revision 1.20 84/08/13 17:33:10 bill ;;;Correct bug & clarify compiler warning in KEYWORDIFY ;;;for use by CT_SEND and CT_DEFMETHOD. Richard Mark Soley. ;;; ;;;Revision 1.19 84/08/02 14:24:21 bill ;;;Put the keywordify hack in ct_ctsend. ;;; ;;;Revision 1.18 84/08/01 18:46:28 penny ;;;made get-iv and set-iv keywordify the iv-vars ;;; ;;;Revision 1.17 84/08/01 16:50:17 penny ;;;REALLY define ct_make_instance this time. ;;; ;;;Revision 1.16 84/08/01 11:15:21 alfred ;;;add keyword hacks for Release 5.1: ;;;keywordify, ct_make_instance: new functions ;;;ct_send, ct_defmethod: redefined ;;; ;;;Revision 1.15 83/12/14 16:27:54 john ;;;Removed one localf declaration. ;;; ;;;Revision 1.14 83/12/09 11:00:51 john ;;;Added optional quote facility to get-iv, set-iv, ct_csend. ;;;Added localf declarations. ;;; ;;;Revision 1.13 83/12/08 13:08:10 john ;;;Added error checking to get-iv, set-iv, made them work interpreted. ;;; ;;;Revision 1.12 83/12/06 12:52:13 john ;;;Rewrote ct_csend to expand to <- when not compiled. THis allows ;;;interpreted files to work correctly. ;;; ;;;Revision 1.11 83/12/03 14:20:07 bill ;;;Added ct_csend and associate compile time method resolution code. ;;; ;;;Revision 1.10 83/12/02 10:41:21 penny ;;;Fixed set-iv to return the new value. ;;; ;;;Revision 1.9 83/12/01 18:59:02 john ;;;Added macros get-iv and set-iv to allow quick access to ;;;instance variables. ;;; ;;;Revision 1.8 83/11/01 17:55:35 john ;;;Added (ct_make_instance ....) ;;; ;;;Revision 1.7 83/10/25 11:27:46 bill ;;;Remove extra definition of massage-args. ;;; ;;;Revision 1.6 83/10/19 14:55:40 john ;;;Fixed massage-args to correctly deal with &optional, etc. ;;; ;;;Revision 1.5 83/10/17 08:31:22 john ;;;modified franz version of defmethod to put &optional in front ;;;of each optional arg. ;;; ;;;Revision 1.4 83/10/10 14:03:13 john ;;;Removed (progn 'compile ...) wrapper for franz versions. ;;; ;;;Revision 1.3 83/09/08 16:04:30 john ;;;Removed unnecessary loading of 'time, which was causing ct_load loops. ;;; ;;;Revision 1.2 83/07/06 09:53:31 penny ;;;repositioned the mode line ;;; ;;;Revision 1.1 83/06/22 13:30:27 penny ;;;Initial revision ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ct_flav ;;; ;;; Paul Robertson February 20, 1983 ;;; ;;; ;;; ;;; Edited by John Shelton April 8, 1983 ;;; ;;; Edited by Jim Miller: new ct_defflavor May 13, 1983 ;;; ;;; ;;; ;;; ;;; ;;; This file is part of a proprietary software project. Source ;;; ;;; code and documentation describing implementation details are ;;; ;;; available on a confidential, non-disclosure basis only. These ;;; ;;; materials, including this file in particular, are trade secrets ;;; ;;; of Computer * Thought Corporation. ;;; ;;; ;;; ;;; (c) Copyright 1982 and 1983, Computer * Thought Corporation. ;;; ;;; All Rights Reserved. ;;; ;;; ;;; ;;; Reference materials: ;;; ;;; Foderaro and Sklower, The FRANZ LISP Manual, September 1981. ;;; ;;; Weinreb and Moon, LISP MACHINE MANUAL, Symbolics, July 1981. ;;; ;;; Charniak et al., 1980. Artificial Intelligence Programming. ;;; ;;; Miller, 1982. The C*T Ada Tutor: Guide to the Implementation. ;;; ;;; The following code assumes familiarity with these materials. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Ensure presence of needed files. (comment Assumes ct_load and some suitable ct_daba are present) (eval-when (compile load eval) (ct_load 'aip)) ;AIP macros pkg. (eval-when (compile load eval) (ct_load 'compat)) ;Franz/LM compat pkg. #+franz (eval-when (compile load eval) (ct_load 'loop)) ;loop macro ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Compiler Declarations and Global Variables -- #+franz (declare (macros t)) (defvar *complain-about-flavor-incompatibility* nil "If T, report defflavor options that are not present in Franz lisp: see CT_DEFFLAVOR.") ;;; Declare these functions local for cheapitude. #+franz (declare (localf instance-variable-position massage-args )) ;;; **************************************************************** ;;; Externally Call-able Functions/Macros -- ;;; **************************************************************** ;;; **************** ;;; Make-instance ;;; **************** ;;; These new definitions allow flavors to be initialized in franz as ;;; well as Zetalisp. #+franz (defmacro ct_make_instance (flavor &rest options) `(let ((inst (make-instance ,flavor ,@options))) (ct_if (get-handler-for inst ':init) (ct_send inst ':init)) inst)) #+franz (defun ct_send macro(l) (selfinsertmacro l #+lispm `(send ,@(cdr l)) ; lispm version of message passing. #+franz `(<- ,@(cdr l)) ; franz/maryland version. )) #+franz (defun ct_defmethod macro (l) ; bitrot insurance #+lispm (selfinsertmacro l `(progn 'compile (defmethod ,@(cdr l)))) #+franz (selfinsertmacro l `(defmethod ,(cadr l) ,(massage-args (caddr l)) ,@(cdddr l)))) #+lispm (defun keywordify (symbol) (and (listp symbol) (= (length symbol) 2) (eq (car symbol) 'quote) (setq symbol (second symbol))) (cond ((not (symbolp symbol)) #+Symbolics (compiler:warn (list ':function compiler:default-warning-function) "Computed message: ~S." symbol) #+LMI (compiler:warn 'message-not-keyword :implausible "Computed message: ~S." symbol) `(intern (string ,symbol) si:pkg-keyword-package)) ((eq (symbol-package symbol) si:pkg-keyword-package) (list 'quote symbol)) (T (list 'quote (intern (string symbol) si:pkg-keyword-package))))) #+lispm (defmacro ct_send (object message &rest arguments) `(send ,object ,(keywordify message) . ,arguments)) #+lispm (defmacro ct_defmethod ((flavor . method) arglist &body body) `(defmethod (,flavor ,@(mapcar #'(lambda (l) (second (keywordify l))) method)) ,arglist . ,body)) #+lispm (defmacro ct_make_instance (flavor &rest init-options) `(make-instance ,flavor ,@(loop for (keyword value) on init-options by #'cddr collect (keywordify keyword) collect value))) ;;;CT_DEFFLAVOR: Supports LISPM flavor definitions in both Lispm and Franz. ;;;jrm, 5/13/83 (defun ct_defflavor macro (l) (selfinsertmacro l ;;On the lisp machines: ;;Check the option list to make sure that no options are being ;;used that Franz flavors won't understand. If any are found, ;;beep and print a message. The "offending" options will NOT ;;be deleted; this is just a warning. Reports are conditional ;;on the value of *COMPLAIN-ABOUT-FRANZ-FLAVOR-INCOMPATIBILITY*. #+lispm `(progn 'compile (defflavor ,(second l) ;instance vars ,(third l) ;mixins ;;Check the options... ,@(loop for opt in (nthcdr 3 l) collect (let ((sym (cond ((consp opt) (car opt)) (t opt)))) (cond ((and *complain-about-flavor-incompatibility* (member sym '(:init-keywords :default-init-plist :required-instance-variables :required-flavors :default-handler :ordered-instance-variables :outside-accessible-instance-variables :accessor-prefix :select-method-order :method-combination))) (beep) (format t "~&Warning: definition of flavor ~a ~ uses option ~a, which will not be ~ recognized by the Franz flavor ~ system." (first l) sym))) opt)))) ;;On Franz lisp: ;;Make sure that all Franz options are in the proper format -- such as ;;:INCLUDED-FLAVORS being an unembedded list in Franz -- and that no ;;unrecognized and unnecessary options -- such as ;;:INITABLE-INSTANCE-VARIABLES are present. #+franz `(defflavor ,(second l) ;instance vars ,(third l) ;mixins ;;Check the options: ,@(loop for opt in (nthcdr 3 l) append (cond ;;If OPT is a list of :INCLUDED-FLAVORS, ;;splice the items into the list of ;;options -- that's why this loop is APPENDing. ((and (consp opt) (eq (car opt) ':included-flavors)) opt) ;;If OPT is :INITABLE-INSTANCE-VARIABLES, splice ;;it out: all variables are initable in Franz, and ;;Franz's DEFFLAVOR will complain if this option ;;is present ((eq opt ':initable-instance-variables) nil) ;;Otherwise, put it into the list of options. (t (list opt))))))) ;;; **************************************************************** ;;; Stuff to allow efficient access to instance variables. ;;; **************************************************************** ;;; ;;; If you know in advance that a (ct_send 'IV) message ;;; will be requesting an instance variable from instances of a constant ;;; flavor, it is safe to replace the whole mess with (cxr n ) ;;; if you know the right thing to do. We can do this if we use the ;;; following macros: ;;; ;;; (get-iv ) ;;; ;;; and ;;; ;;; (set-iv ) ;;; ;;; the names of instance variables may now be quoted. ;;; First, we need a way to get the position of an instance variable ;;; in a flavor object. ;;; Fortunately, a flavor has a property-list with the instance-variables ;;; hanging. Each one is a list of the iv-name, cxr-position, and default. #+franz (defun instance-variable-position (iv-name flavor) (or (get flavor 'combined?) (combine-flavor flavor)) (or (cadr (assq iv-name (get flavor 'instance-variables))) (format t "~%Warning. Can't find instance variable <~A> for flavor <~A>." iv-name flavor) nil)) ;;; Here is how to access an instance-variable. #+franz (defmacro get-iv (flav-name instance iv-name) ;; First, change (quote foo) to foo. (and (listp iv-name) (setq iv-name (cadr iv-name))) (cond ((status feature complr) `(cxr ,(instance-variable-position iv-name flav-name) ,instance)) (t `(<- ,instance ',iv-name)))) ;;; Here is how to set an instance-variable. #+franz (defmacro set-iv (flav-name instance iv-name new-val) ;; First, change (quote foo) to foo. (and (listp iv-name) (setq iv-name (cadr iv-name))) (cond ((status feature complr) `(let ((nv ,new-val)) (rplacx ,(instance-variable-position iv-name flav-name) ,instance nv) nv)) (t `(<- ,instance ',(intern (concat "set-" iv-name)) ,new-val)))) ;;; Now, for the lisp machine, don't do anything fancy. #+lispm (defmacro get-iv (flav-name instance iv-name) ;; First, change (quote foo) to foo. (and (listp iv-name) (setq iv-name (cadr iv-name))) `(send ,instance ,(keywordify iv-name))) #+lispm (defmacro set-iv (flav-name instance iv-name new-val) ;; First, change (quote foo) to foo. (and (listp iv-name) (setq iv-name (cadr iv-name))) `(send ,instance ,(keywordify (intern (string-append "SET-" iv-name))) ,new-val)) ;;; **************************************************************** ;;; Compile time resolution of method name. ;;; **************************************************************** ;;; ;;; If you know in advance that a (ct_send ...) message ;;; is to a flavor and method that can be resolved at compile time then ;;; the send can be replaced by a call to the function which impliments ;;; the method. ; A function to find the function name which will be used to perform ; "method" in "flavor". We look in the method table for flavor. If we ; don't find it then we try to combine the flavor. If that doesn't help ; then signal an error. ; ; ct_get_method ; returns the method for a given flavor and message ; if none exists prints error message and traps (if flag set) ; returns nil or value from error. Trys to combine the flavor if it ; is not already combined and checks again. #+franz (defun ct_get_method (flavor message) (or (cadr (assq message (get flavor 'method-table))) ; success (if (null (get flavor 'combined?)) (combine-flavor flavor) ; combine and try again (cadr (assq message (get flavor 'method-table))) ) (progn (format t "~%Cannot resolve method ~a in flavor ~a." message flavor) nil ) ) ) ; A macro to do the expansion at compile time. We look up the method function ; and expand into a call to it. Pass the instance (self). ;;; This new, improved ct_csend expands to a regular <- for interpreted ;;; code. That way, it should work correctly without any special effort. #+franz (defmacro ct_csend (flavor instance message &rest args) ;; First, change (quote foo) to foo (and (listp message) (setq message (cadr message))) (cond ((status feature complr) `(,(ct_get_method flavor message) ,instance ,@args)) (t `(<- ,instance ',message ,@args)))) ; Don't do anything special on the lispm's. Just expand into a normal send. #+lispm (defmacro ct_csend (flavor instance message &rest args) ;; First, change (quote foo) to foo. (and (listp message) (setq message (cadr message))) `(send ,instance ,(keywordify message) ,@args) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Internal Use Only Functions/Macros -- ;;; For franz lisp, massages the arguments in an argument list. ;;; Specifically, turns (... &optional foo bar ...) into ;;; (... &optional foo &optional bar ...) (defun massage-args (arglist) (loop for arg in arglist with optional = nil if (eq arg '&optional) do (setq optional t) if (memq arg '("e &rest &eval &aux)) do (setq optional nil) if (and optional (not (eq arg '&optional))) collect '&optional unless (eq arg '&optional) collect arg))