rs@uunet.UU.NET (Rich Salz) (08/04/87)
Submitted-by: Roy D'Souza <dsouza%hplabsc@hplabs.HP.COM>
Posting-number: Volume 10, Issue 87
Archive-name: comobj.lisp/Part13
#! /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 13 (of 13)."
# Contents: co-parse.l
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'co-parse.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'co-parse.l'\"
else
echo shar: Extracting \"'co-parse.l'\" \(56836 characters\)
sed "s/^X//" >'co-parse.l' <<'END_OF_FILE'
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; File: co-parse.l
X; RCS: $Revision: 1.1 $
X; SCCS: %A% %G% %U%
X; Description: Commonobjects parser for the Commonobjects-Commonloops
X; interface.
X; Author: Roy D'Souza, HPL/DCC
X; Created: 20-Nov-86
X; Modified: 4-Mar-87 11:22:29 (James Kempf)
X; Mode: Lisp
X; Package: COMMON-OBJECTS-PARSER
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;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; Preliminaries
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X(provide "co-parse")
X
X;;;Package COMMON-OBJECTS-PARSER contains the parser. For ease of
X;;; typing, CO-PARSER can be used.
X
X;;;These symbols from the COMMON-OBJECTS package are needed at compile
X;;; time. Create the package if not there. Note that I don't want
X;;; to export them, because a user of the COMMON-OBJECTS package
X;;; shouldn't know about them. I therefore use fully qualified
X;;; symbols in the code.
X
X(in-package :common-objects :nicknames '(co) :use '(lisp pcl))
X(intern "ASSIGNEDP")
X(intern "METHOD-ALIST")
X(intern "SELF")
X(intern "INIT-KEYWORDS")
X(intern "LEGAL-PARENT-P")
X(in-package 'common-objects-parser :nicknames '(co-parser) :use '(lisp pcl))
X
X;;Export functions needed for parsing
X
X(export
X '(
X co-parse-define-type-call
X co-parse-method-macro-call
X co-parse-call-to-method
X co-process-var-options
X co-parse-options
X co-deftype-error
X co-legal-type-or-method-name
X $UNDEFINED-TYPE-NAME
X $TYPE-INFO-SLOT
X $TYPE-NAME-SLOT
X $VARIABLE-NAMES-SLOT
X $INITABLE-VARIABLES-SLOT
X $SETTABLE-VARIABLES-SLOT
X $GETTABLE-VARIABLES-SLOT
X $PARENT-TYPES-SLOT
X $PARENTS-INFO-SLOT
X $A-LIST-METHOD-TABLE-SLOT
X $TREAT-AS-VARIABLES-SLOT
X $INIT-KEYWORDS-SLOT
X $NO-INIT-KEYWORD-CHECK-SLOT
X $METHODS-TO-NOT-DEFINE-SLOT
X $METHODS-TO-INHERIT-SLOT
X $LET-PSEUDO-INFO-SLOT
X $INFO-NUMBER-OF-SLOTS
X
X )
X)
X
X;;Need the PCL and pcl-patches module
X(require "pcl")
X(require "pcl-patches")
X
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; Constant Definition
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;Type names are set to this when types are undefined.
X
X(defconstant $UNDEFINED-TYPE-NAME '*now-an-undefined-type*)
X
X;;Offsets into the vector used to parse type definitions.
X
X(defconstant $TYPE-INFO-SLOT 0)
X
X(defconstant $TYPE-NAME-SLOT 1)
X
X(defconstant $VARIABLE-NAMES-SLOT 2)
X
X(defconstant $INITABLE-VARIABLES-SLOT 3)
X
X(defconstant $SETTABLE-VARIABLES-SLOT 4)
X
X(defconstant $GETTABLE-VARIABLES-SLOT 5)
X
X(defconstant $PARENT-TYPES-SLOT 6)
X
X(defconstant $PARENTS-INFO-SLOT 7)
X
X(defconstant $A-LIST-METHOD-TABLE-SLOT 8)
X
X(defconstant $TREAT-AS-VARIABLES-SLOT 9)
X
X(defconstant $INIT-KEYWORDS-SLOT 10)
X
X(defconstant $NO-INIT-KEYWORD-CHECK-SLOT 11)
X
X(defconstant $METHODS-TO-NOT-DEFINE-SLOT 12)
X
X(defconstant $METHODS-TO-INHERIT-SLOT 13)
X
X(defconstant $LET-PSEUDO-INFO-SLOT 14)
X
X(defconstant $EXPLICITLY-LISTED-METHODS-SLOT 15)
X
X;;List of all universal method names
X
X(defconstant
X $DEFINE-TYPE-UNIVERSAL-METHODS
X '(:describe
X :print
X :initialize
X :initialize-variables
X :init
X :eql
X :equal
X :equalp
X :typep
X :copy
X :copy-state
X :copy-instance)
X)
X
X;;Size of the vector used in type definition parsing.
X
X(defconstant $INFO-NUMBER-OF-SLOTS 16)
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; General Macro Definitions
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X(defmacro get-parents-info (type-info)
X
X; Allow for more convenient access of parent information.
X
X `(aref ,type-info $parents-info-slot))
X
X(defmacro set-parents-info (type-info new-value)
X `(setf (aref ,type-info $parents-info-slot) ,new-value))
X
X(defmacro co-deftype-error (format &rest arguments)
X
X `(error (concatenate 'simple-string
X "DEFINE-TYPE: In type '~s', "
X ,format)
X ,@arguments))
X
X
X(defmacro define-method-error (format &rest arguments)
X
X `(error
X (format nil
X (concatenate 'simple-string "DEFINE-METHOD: " ,format)
X ,@arguments)))
X
X(defmacro return-keyword-from-variable (var)
X `(intern ,var (find-package "KEYWORD"))
X)
X
X;;type-partially-defined?-Find out if a CommonLoops class is
X;; defined and return the class object if so.
X
X(defmacro type-partially-defined? (name)
X
X `(class-named ,name T))
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; General Function and Method Definitions
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;type-name-Return the name of the type
X
X(defun type-name (tinfo)
X
X (if (%instancep tinfo)
X (class-name tinfo)
X (svref tinfo $TYPE-NAME-SLOT)
X )
X
X) ;type-name
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; Top Level Type Definition
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X
X(defun co-parse-define-type-call
X (define-type-call type-name doc-string options-list)
X
X; Parse the various pieces of the call to DEFINE-TYPE. Return multiple values
X; of the form: (TYPE-NAME DOC-STRING OPTIONS-LIST) OPTIONS-LIST doesn't have to
X; exist. If it doesn't, NIL is returned for it value (assuming NIL is
X; given as their initial value passed into the routine). In either
X; case it is disreguarded. Example call, DEFINE-TYPE-CALL =
X; (DEFINE-TYPE NOSE (:INHERIT-FROM PARENT)).
X
X (setf define-type-call (cdr define-type-call))
X
X; This should now be the list of arguments to the DEFINE-TYPE.
X; Example define-type-call = (NOSE (:INHERIT-FROM PARENT)).
X
X (unless (proper-list define-type-call)
X
X ; THEN The call to DEFINE-TYPE is not a proper list.
X
X (error
X (format nil
X "DEFINE-TYPE: The call,~% (DEFINE-TYPE '~S'),~% is missing arguments or is not a proper list."
X define-type-call)))
X
X; Get the name of the type
X
X (setf type-name (first define-type-call))
X (setf define-type-call (cdr define-type-call))
X
X; see if there is a documentation string
X
X (when
X (setq doc-string
X (and (consp define-type-call)
X (stringp (car (the cons define-type-call)))
X (list (car (the cons define-type-call)))
X ; list form for ,@ substitution
X ))
X (setf define-type-call (cdr define-type-call)))
X
X; Example, define-type-call = ((:INHERIT-FROM PARENT)).
X; Now look for options.
X
X (when (consp define-type-call)
X
X ; THEN We have options.
X
X (setf options-list define-type-call))
X
X; Return the parsed fields as a list for MULTIPLE-VALUE-SETQ
X
X (values type-name doc-string options-list)
X
X) ;co-parse-define-type-call
X
X;;proper-list-Return T if X is a proper list, i.e., no dotted tail
X
X(defun proper-list (x)
X
X; Return T on if x is a proper list (i.e., not (a b c . d)). NIL is
X; not considered a proper list.
X
X (and (consp x) (not (cdr (last x)))))
X
X(defun co-process-var-options
X (type-info options-list var-names var-assignments)
X
X; Returns multiple values. These values are:
X; (VAR-NAMES VAR-ASSIGNMENTS OPTIONS-LIST)
X; Go through OPTIONS-LIST and find all the :VAR options. Take
X; these and process them producing the list of variable names, the
X; variable assignment code and the list of options without the :VAR
X; options.
X
X (let
X (
X (variable nil)
X (var-assignment nil)
X (new-options-list nil)
X (option-name nil)
X (option-info nil)
X )
X;;;; (Declare (ignore option-name))
X
X (dolist (option options-list
X (values var-names var-assignments new-options-list)
X )
X
X (multiple-value-setq (option-name option-info)
X (option-ok? option type-info 'regular-option)
X )
X
X ; Will only return to here if we didn't get an error.
X
X ; Check if spec is an instance variable spec
X
X (if (not (member 'variable-option (cdr option-info) :test #'eq))
X
X ;;THEN Add this non-:VAR option to the options list
X
X (setf new-options-list (nconc new-options-list (list option)))
X
X
X
X ; ELSE We have a instance variable specification.
X ; Now return the name of the variable and initialization
X ; code.
X
X
X (progn
X (multiple-value-setq (variable var-assignment)
X (parse-option
X type-info
X var-names
X option
X option-info
X )
X )
X
X
X (setf var-names (nconc var-names (list variable)))
X
X (when var-assignment
X
X ; THEN Add the assignment to the list of assignments.
X
X (setf var-assignments
X (nconc var-assignments (list var-assignment))
X )
X ) ;when
X
X ) ;progn
X
X ) ;if
X ); dolist
X
X ) ;let
X
X); end co-process-var-options
X
X(defun co-parse-options (type-info var-names options)
X
X; It is legal for OPTIONS to be NIL.
X; Example: OPTIONS = ((:REDEFINED-METHODS m1 m2 m3)
X; :ALL-INITABLE)
X
X (let ((options-so-far nil)
X (option-name nil)
X (option-info nil))
X
X (dolist (option options)
X
X ; OPTION-INFO will be NIL if OPTION-NAME is not a legal
X ; option, or a list of information that tells what
X ; characteristics this option has. Note that currently, if an
X ; error occurs in OPTION-OK? we will NOT return to this
X ; function. The check for '(WHEN OPTION-INFO...' is for future
X ; continuable errors. If 'ONCE' is on this list, it means the
X ; option can only occur once.
X
X (multiple-value-setq (option-name option-info)
X (option-ok? option type-info 'regular-option))
X (when option-info
X
X ; THEN The OPTION is a real one.
X ; Now make sure it doesn't occur more then once.
X
X (if
X (and (member option-name options-so-far :test #'eq)
X
X (member 'once (cdr option-info) :test #'eq))
X
X ; THEN We have duplicate options. Give an error.
X
X (co-deftype-error
X "duplicate option,~% '~s',~% specified."
X (type-name type-info)
X option)
X
X ; ELSE Everything is ok.
X
X (progn
X (setf options-so-far (cons option-name options-so-far))
X (parse-option type-info var-names option option-info)))))
X ))
X
X(defun parse-option (type-info var-names option option-info)
X
X; This routine calls the right function to parse OPTION. This
X; function is the first element of OPTION-INFO. Example: OPTION =
X; (:REDEFINED-METHODS M1 M2 M3) The option given is either a symbol
X; or a list. When a list, the rest of the arguments will be passed to
X; the function (may be NIL). If a symbol, NIL is passed as arguments.
X; NOTE: Should make sure that the value returned by the option is
X; the value of this routine, since some code may want to use
X; the value returned (like the caller of the :VAR option).
X
X (apply (car option-info)
X (list var-names (if (consp option) (cdr option) nil) type-info)))
X
X(defun option-ok? (option type-info type-of-option)
X
X; Return the information about this option or NIL. Return the name of
X; the option followed by the information for the option as a pair. If
X; the option is not of the correct form give an error message. Check
X; to make sure the option exists. Also check that the form of option
X; is legal according to the information returned. This includes
X; whether the option is allowed as a symbol or in list form. And
X; whether it is allowed to not have any arguments when in the list
X; form. Also if a list, check if each element is a symbol, and not NIL.
X; This is done if CHECK-ARGUMENTS was included in the option
X; information. If the KEYWORDS option is also included with
X; CHECK-ARGUMENTS, each of the symbols given must also be in the
X; keyword package. If VARIABLES is included in the option information,
X; SELF is also checked for each option element. The
X; option CAN-HAVE-LIST-ELEMENTS causes list element arguments to be
X; ignored. If this option is not there and a list element is
X; found, an error message is issued. Type-info is used strictly for
X; error messages. Will return NIL for the error conditions. Sample,
X;
X; OPTION = '(:REDEFINED-METHODS A B C)' or ':ALL-SETTABLE'
X;
X; TYPE-OF-OPTION is used to decide wheter we are dealing with an
X; option or a suboption of :INHERIT-FROM. NOTE: Currently, this
X; function will never return if an error occurs but we prepare for
X; future continuable errors.
X
X (let*
X ((option-info
X (if (consp option)
X
X ; THEN Use the first element of the option as the option name.
X
X (return-option-info (car option) type-of-option)
X
X ; ELSE Use the option itself as the option name.
X
X (return-option-info option type-of-option)))
X
X (type-name (type-name type-info))
X (check-as-variables (member 'variable option-info :test #'eq))
X (can-have-list-elements
X (member 'can-have-list-elements option-info :test #'eq))
X (keyword-arguments (member 'keywords option-info :test #'eq)))
X
X
X (unless option-info
X
X ; THEN We have an illegal option.
X
X (co-deftype-error
X "no such option (or suboption) as:~% '~s'."
X type-name
X option))
X
X ; We have a real option. Make sure it is of the right form.
X
X (if (consp option)
X
X ; THEN Check to make sure it can be a pair.
X
X (if
X (not (member 'list (cdr option-info) :test #'eq))
X
X ; THEN Wrong form for option.
X
X (co-deftype-error
X "option,~% '~S',~% must occur as a symbol."
X type-name
X option)
X
X ; ELSE Ok so far. Make sure the list form is a proper list.
X ; Now check if the option has no arguments and if
X ; if does make sure it can.
X
X (progn
X (unless (proper-list option)
X ; THEN Not a proper list.
X (co-deftype-error
X "the option,~% '~S',~% must be a proper list."
X type-name
X option))
X (if
X (and (not (cdr option))
X (not (member 'no-arguments (cdr option-info) :test #'eq)))
X
X ; THEN Arguments must be specified to option.
X
X (co-deftype-error
X "option,~% '~S',~% requires arguments."
X type-name
X option)
X
X ; ELSE Check each element of the list, if necessary, to
X ; make sure it is a symbol, not NIL. Also check for
X ; SELF if VARIABES is in the
X ; option info.
X ; Return the information.
X
X (progn
X (when (member 'check-arguments (cdr option-info) :test #'eq)
X
X ; THEN Check the arguments.
X
X (dolist (option-arg (cdr option))
X (if (consp option-arg)
X (unless can-have-list-elements
X
X ; THEN List arguments are not allowed.
X
X (co-deftype-error
X "illegal argument '~S' found in option,~% '~S'."
X type-name
X option-arg
X option))
X
X ; ELSE Check if a correct symbol.
X
X (if
X (or
X (not (co-legal-type-or-method-name option-arg))
X (and check-as-variables
X (not
X (legal-instance-variable))))
X
X ; THEN Illegal argument in option.
X
X (co-deftype-error
X "illegal argument '~S' found in option,~% '~S'."
X type-name
X option-arg
X option)
X
X ; ELSE Check if the option-arg must be a keyword.
X
X (when
X (and keyword-arguments
X (not (keywordp option-arg)))
X
X ; THEN We have a DEFINE-TYPE in which the
X ; arguments must all be symbols in the
X ; keyword package.
X (co-deftype-error
X "'~S' of the option,~%'~S'~%is illegal. Must be a symbol from the keyword package."
X type-name
X option-arg
X option))))))
X (values (car option) option-info)))))
X
X ; ELSE We have the symbol form of the option.
X
X (if (member 'symbol (cdr option-info) :test #'eq)
X
X ; THEN Return the information.
X
X (values option option-info)
X
X ; ELSE Wrong form for option.
X
X (co-deftype-error
X "option,~% '~S',~% must occur in list form."
X type-name
X option)))))
X
X
X(defun co-legal-type-or-method-name (type-or-method-name)
X
X; Return T only if the name given is a non-nil symbol.
X
X (and (symbolp type-or-method-name) type-or-method-name))
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; Detailed Option Parsing
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X(defun return-option-info (option-name option-type)
X
X; Whenever a new option is added, this function must be updated.
X; Should return NIL, if garbage option-names are given. The option
X; information returned has the form:
X; (FUNCTION-NAME . INFORMATION).
X; FUNCTION-NAME is the name of the function to call that parses the
X; given option. INFORMATION is a list of information to use in
X; syntaxing the option. This list includes:
X; SYMBOL - option can occur in symbol form.
X; LIST - option can occur in list form.
X; CHECK-ARGUMENTS - When an option is in list form, this specifies that
X; each element of the option list is to be checked to
X; be a symbol which is not NIL.
X; KEYWORDS - An addition to the CHECK-ARGUMENTS option, this says
X; that each element must be a symbol from the keyword
X; package. Must occur with the CHECK-ARGUMENTS option.
X; NO-ARGUMENTS - This specifies that a list form of the option can
X; occur without any arguments (i.e.,
X; (:METHODS).
X; VARIABLE - The items in this options list are instance variables.
X; Check that they are not SELF or MYSELF.Make sure
X; they are not symbols from the
X; keyword package.
X; CAN-HAVE-LIST-ELEMENTS - This option says that having list elements is
X; legal. These elements are simply ignored.
X; ONCE - This option can only occur once.
X; VARIABLE-OPTION - Currently used in the :VAR option. Tells whether
X; an option is a variable option (:VAR) without
X; using the name of the option. This allows easy
X; renaming of the :VAR option.
X; VALUE-RETURNED-SUBOPTION - States that this suboption returns a
X; value that is needed. A test is made
X; to save the return value when a suboption
X; has this characteristic.
X;
X; Note that this list is used for parsing suboptions as well as
X; options. The handling of suboptions and options in the same way is
X; done for flexibility and understandability even though some of the
X; options may not currently apply to both options and suboptions.
X;
X
X (case option-type
X
X (var-suboption (return-var-suboption-info option-name))
X
X (inherit-from-suboption
X (return-inherit-from-suboption-info option-name))
X
X (regular-option (return-regular-option-info option-name))))
X
X(defun return-var-suboption-info (option-name)
X
X; Return information as stated in comments of RETURN-OPTION-INFO
X; about the suboptions of the :VAR option.
X
X (case option-name
X
X (:init '(parse-var-init-suboption list once value-returned-suboption))
X
X (:type '(parse-var-type-suboption list once))
X
X (:initable '(parse-var-initable-suboption symbol once))
X
X (:settable '(parse-var-settable-suboption symbol once))
X
X (:gettable '(parse-var-gettable-suboption symbol once))
X
X (otherwise nil)
X ))
X
X(defun parse-var-initable-suboption (args initable-variable type-info)
X (declare (ignore args))
X
X; ARGS will always be NIL.
X
X (setf (svref type-info $initable-variables-slot)
X (add-to-set
X (svref type-info $initable-variables-slot)
X initable-variable)))
X
X(defun parse-var-gettable-suboption (args gettable-variable type-info)
X (declare (ignore args))
X
X; ARGS will always be NIL.
X
X (setf (svref type-info $gettable-variables-slot)
X (add-to-set
X (svref type-info $gettable-variables-slot)
X gettable-variable)))
X
X(defun parse-var-settable-suboption (args settable-variable type-info)
X (declare (ignore args))
X
X; ARGS will always be NIL.
X
X (setf (svref type-info $initable-variables-slot)
X (add-to-set
X (svref type-info $initable-variables-slot)
X settable-variable))
X
X (setf (svref type-info $gettable-variables-slot)
X (add-to-set
X (svref type-info $gettable-variables-slot)
X settable-variable))
X
X (setf (svref type-info $settable-variables-slot)
X (add-to-set
X (svref type-info $settable-variables-slot)
X settable-variable)))
X
X(defun add-to-set (set new-elements)
X
X; Add the elements in NEW-ELEMENTS to SET if they are not already
X; there. NEW-ELEMENTS can be a list of id's or an id. It is assumed
X; that the order of the elements within the set is NOT important. If
X; NEW-ELEMENTS is NIL, simply return set.
X
X (cond ((null new-elements) set)
X ((symbolp new-elements)
X
X ; THEN Add the element to the set, if necessary.
X
X (adjoin new-elements set :test #'eq))
X
X (t
X
X ; ELSE Add each element of the list of elements.
X
X (let ((new-set set))
X (dolist (element new-elements)
X (setf new-set (adjoin element new-set :test #'eq)))
X new-set))))
X
X
X(defun parse-var-type-suboption (args variable type-info)
X
X; Example, ARGS = (FIXNUM). A declaration like (:TYPE FIXNUM) =>
X; (DECLARE (TYPE FIXNUM A)).
X
X (unless (and (consp args) (= (length args) 1)) ;rds 3/8 eq->=
X
X ; THEN We have something like (:TYPE . 2).
X
X (co-deftype-error
X "'~S'~% is an illegal form of :TYPE suboption."
X (type-name type-info)
X (cons :type args)))
X
X; Add this declaration to the list of declarations.
X; Note that more will be added to this slot when :VARIABLES suboptions are
X; parsed, and at the end parsing the type. :VARIABLES is, however,
X; currently unsupported.
X
X (setf (svref type-info $let-pseudo-info-slot)
X (nconc (svref type-info $let-pseudo-info-slot)
X (list `(declare (type ,(car args) ,variable))))))
X
X
X(defun parse-var-init-suboption (args variable type-info)
X
X; Return the variable initialization form. For example, if VARIABLE =
X; REAL-PART and ARGS = (0.0), would return:
X; (unless
X; (assignedp real-part)
X; (setf real-part 0.0))
X
X (unless (and (consp args) (= (length args) 1)) ;rds 3/8 eq->=
X
X ; THEN We have something like (:INIT 1 2).
X
X (co-deftype-error
X "illegal initialization form,~%'~S',~%given for instance variable '~S'."
X (type-name type-info)
X (cons :init args)
X variable))
X
X (let ((default-value (first args)))
X `(unless
X (co::assignedp ,variable)
X
X ; THEN
X
X (setf ,variable ,default-value))))
X
X(defun return-inherit-from-suboption-info (option-name)
X
X; Return information as stated in comments of RETURN-OPTION-INFO
X; about the suboptions of the :INHERIT-FROM option.
X
X (case option-name
X
X (:init-keywords
X '(parse-init-keywords-suboption
X symbol
X list
X once
X check-arguments
X keywords))
X
X ;;:VARIABLES suboption not allowed in COOL. This is due to
X ;; lack of code walker hooks.
X
X#|
X (:variables
X '(parse-variables-suboption
X list
X once
X no-arguments
X check-arguments
X variable
X can-have-list-elements))
X|#
X
X (:methods
X '(parse-methods-suboption list once check-arguments no-arguments))
X
X (otherwise nil)))
X
X(defun return-regular-option-info (option-name)
X
X; Return information as stated in comments of RETURN-OPTION-INFO
X; about the options of DEFINE-TYPE.
X
X (case option-name
X
X
X ;;:FAST-METHODS not supported in COOL. Implementation dependent.
X
X#|
X (:fast-methods
X '(parse-fast-methods-option list once check-arguments no-arguments))
X|#
X
X ;;In line methods are not supported in COOL. Implementation dependent.
X
X#|
X (:inline-methods
X '(parse-inline-methods-option list once check-arguments no-arguments))
X
X (:notinline-methods
X '(parse-notinline-methods-option
X list
X once
X check-arguments
X no-arguments))
X
X|#
X
X (:init-keywords
X '(parse-init-keywords-option
X list
X once
X check-arguments
X no-arguments
X keywords))
X
X (:no-init-keyword-check
X '(parse-no-init-keyword-check-option symbol once))
X
X (:inherit-from '(parse-inherit-from-option list))
X
X (:var '(parse-var-option list variable-option))
X
X (:redefined-methods
X '(parse-redefined-methods-option
X list
X once
X check-arguments
X no-arguments))
X
X (:all-settable '(parse-all-settable-option symbol once))
X
X (:all-gettable '(parse-all-gettable-option symbol once))
X
X (:all-initable '(parse-all-initable-option symbol once))
X
X (otherwise nil)))
X
X(defun parse-init-keywords-suboption (type-info parent-type-info args)
X
X; If ARGS is NIL, we have the symbol form. If ARGS is a list, we have
X; the list form. Examples: ARGS = NIL
X; ARGS = (:EXCEPT j k l), (:EXCEPT)
X; (:INIT-KEYWORDS :EXCEPT) is treated as all keywords. If this
X; function returns, then everything went ok as far as errors. If ARGS
X; is a list, we know it is proper, and each init keyword is a symbol and
X; not NIL. This function may change the $INIT-KEYWORDS-SLOT of
X; type-info.
X
X (let*
X ((parent-init-keywords
X (co::init-keywords parent-type-info))
X (keywords-to-add parent-init-keywords))
X
X (when args
X
X ; THEN We have the except form.
X ; Check and make sure the :EXCEPT is found.
X
X (if
X (not (eq (car args) ':except))
X
X ; THEN We have an error.
X
X (co-deftype-error
X "~%'~S'~% was found following the :INIT-KEYWORDS suboption, expected to see 'EXCEPT'."
X (type-name type-info)
X (car args))
X
X ; ELSE ok so far.
X
X (progn (setq args (cdr args))
X (when (consp args)
X
X ; THEN There is something following the :EXCEPT.
X
X (dolist (keyword args)
X
X ; See if the keyword is in the list of REAL
X ; keywords for the parent.
X
X (if
X (not
X (member keyword
X parent-init-keywords
X :test
X #'eq))
X
X ; THEN Print a warning message is ignore.
X
X (warn
X (format
X NIL
X "DEFINE-TYPE: Init keyword, '~A', is not a keyword of '~A' in :INIT-KEYWORDS suboption."
X keyword
X (type-name parent-type-info)))
X
X ; ELSE The keyword is legit.
X
X (setf keywords-to-add
X (remove keyword
X keywords-to-add
X :test
X #'eq
X :count
X 1))))))))
X
X ; keywords-to-add should be correctly setup now.
X ; Add the elements of this list that are not already there, to the
X ; existing list of keywords for this type.
X
X (setf (svref type-info $INIT-KEYWORDS-SLOT)
X (add-to-set
X (svref type-info $INIT-KEYWORDS-SLOT)
X keywords-to-add))))
X
X(defun parse-methods-suboption (type-info parent-type-info args)
X
X; At this point, we know that ARGS is a proper list where each element
X; is a symbol that is not NIL. Sample, args = (:EXCEPT M1 M2 M3),
X; (:EXCEPT), (). If method names are duplicated, the duplicates are
X; ignored. This function should change the $METHODS-TO-INHERIT-SLOT as
X; in the following example:
X; PARENT-TYPE-INFO for PARENT2 and the total methods for PARENT2
X; are M1, M2,...,M6 and if ARGS = (:EXCEPT M1 M2 M3), and if
X; $METHODS-TO-INHERIT-SLOT looked like:
X; ((<parent1 type info object> .(M1 M2 M3))), then
X; $METHODS-TO-INHERIT-SLOT would look like:
X; ((<parent1 type info object> . (M1 M2 M3))
X; (<parent2 type info object> . (M4 M5 M6)))
X; after this routine completes. When this routine finishes, we are
X; guaranteed that each method added to the $METHODS-TO-INHERIT-SLOT is an
X; existing methods of the parent.
X
X (let
X ((parent-methods
X (co::method-alist parent-type-info))
X (methods-to-inherit nil)
X (except-form?
X (when (and args (eq (car args) ':except))
X
X ; THEN Skip over the :EXCEPT argument.
X
X (setf args (cdr args))
X t)))
X
X ; ARGS will be NIL or a list at this point. If NIL, we have (:METHODS)
X ; or (:METHODS :EXCEPT).
X
X (dolist (method args)
X (unless (assoc method parent-methods :test #'eq)
X
X ; THEN The method doesn't exits, give a warning.
X
X (warn
X (format nil
X "DEFINE-TYPE: Method '~S' of the :METHODS suboption doesn't~% exist in parent '~S'."
X method
X (type-name parent-type-info)))))
X
X (if except-form?
X
X ; THEN We have the :EXCEPT form. List all methods that are not
X ; specified and are not universal methods. If
X ; (:METHODS :EXCEPT), all methods not universal methods are
X ; added.
X
X (dolist (method-function-pair parent-methods)
X
X ; As long as the method is not an exception (:EXCEPT)
X ; and not a universal method of the parent, inherit it.
X
X (unless
X (or (member (car method-function-pair) args :test #'eq)
X (member (car method-function-pair)
X $DEFINE-TYPE-UNIVERSAL-METHODS
X :test
X #'eq))
X
X ; THEN The method we are looking at is desired
X ; for inheritance.
X
X (setf methods-to-inherit
X (add-to-set
X methods-to-inherit
X (car method-function-pair)))))
X
X ; ELSE We have the normal form. If some of the args were not real
X ; methods. If (:METHODS), nothing is done.
X
X (dolist (method args)
X (when (assoc method parent-methods :test #'eq)
X
X ; THEN The method really exists.
X
X (setf methods-to-inherit
X (add-to-set methods-to-inherit method))
X
X ; Add to the list of explicitly stated methods to inherit.
X ; This is used for error checking with methods to not
X ; redefine later.
X
X (setf
X (svref type-info $EXPLICITLY-LISTED-METHODS-SLOT)
X (add-to-set
X (svref type-info
X $EXPLICITLY-LISTED-METHODS-SLOT)
X method)))))
X
X ; Now add this list of methods to the type-info vector.
X ; 'methods-to-inherit' may be NIL.
X
X (setf (svref type-info $METHODS-TO-INHERIT-SLOT)
X (append (svref type-info $METHODS-TO-INHERIT-SLOT)
X (list (cons parent-type-info methods-to-inherit))))))
X
X
X(defun parse-var-option (var-names args type-info)
X
X; ARGS = (IV1 (:TYPE INTEGER) (:INIT 0.0) :SETTABLE) Return something
X; of the form:
X; (VARIABLE-NAME . VAR-ASSIGNMENT)
X; VARIABLE-NAME is the name of the instance variable. VAR-ASSIGNMENT
X; is the code needed to initialize this instance variable.
X
X (unless (and (consp args) (symbolp (car args)))
X
X ; THEN We have an error.
X
X (co-deftype-error
X "a symbol must follow a :VAR option."
X (type-name type-info)))
X
X (let ((variable (car args))
X (var-assignment nil))
X
X ; Make sure the instance variable name is legal.
X
X (instance-variable-ok? variable var-names (type-name type-info))
X
X ; Now parse all the suboptions of the :VAR option.
X ; VAR-ASSIGNMENT will be NIL if there is no :INIT suboption.
X
X (setf var-assignment
X (parse-var-suboptions type-info (cdr args) variable))
X (values variable var-assignment)))
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; Detailed :VAR Suboption Parsing
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X(defun parse-var-suboptions (type-info suboptions variable)
X
X; This routine returns the code for initialization of the instance
X; variable VARIABLE. It is legal for suboptions to be NIL. For
X; understandibility, expandability, and consistancy the parsing of
X; suboptions uses the same techniques with the same keywords that option
X; option parsing does. This is true even though some of the option
X; information may not be shared between options and suboptions. See
X; CO-PARSE-OPTIONS and its constituent routines.
X;
X; Example: SUBOPTIONS = ((:INIT 0.0)
X; (:TYPE INTEGER)
X; :SETTABLE)
X
X (let ((suboptions-so-far nil)
X (suboption-name nil)
X (suboption-info nil)
X (init-info nil)
X )
X
X (dolist (suboption suboptions)
X
X ; SUBOPTION-INFO will be NIL if SUBOPTION-NAME is not a
X ; legal suboption, or a list of information that tells what
X ; characteristics this suboption has. Note that currently,
X ; if an error occurs in SUBOPTION-OK? we will NOT return
X ; to this function. The check for '(WHEN SUBOPTION-INFO...)'
X ; is for future continuable errors. If 'ONCE' is on this
X ; list, it means the suboption can only occur once.
X
X (multiple-value-setq (suboption-name suboption-info)
X (option-ok?
X suboption
X type-info
X 'var-suboption))
X (when suboption-info
X
X ; THEN The suboption is a real one.
X ; Now make sure it doesn't occur more then once.
X
X (if
X (and
X (member suboption-name suboptions-so-far :test #'eq)
X (member 'once (cdr suboption-info) :test #'eq))
X
X ; THEN We have duplicate suboptions. Give an error.
X
X (co-deftype-error
X "duplicate suboption,~% '~S',~% specified to :VAR option."
X (type-name type-info)
X suboption)
X
X ; ELSE Everything is ok.
X
X (progn
X (setf suboptions-so-far
X (cons suboption-name suboptions-so-far))
X (if
X (member 'value-returned-suboption
X (cdr suboption-info)
X :test
X #'eq)
X
X ; THEN We must save the return value.
X
X (setf init-info
X (parse-var-suboption
X type-info
X variable
X suboption
X suboption-info))
X
X ; ELSE We don't care about the return value.
X
X (parse-var-suboption
X type-info
X variable
X suboption
X suboption-info)))))
X
X ) ;dolist
X
X ;;Return the init-info
X
X init-info
X
X ) ;let
X
X) ;end parse-var-suboptions
X
X(defun parse-var-suboption (type-info variable suboption suboption-info)
X
X; This routine calls the right function to parse SUBOPTION. This
X; function is the first element of SUBOPTION-INFO. Example:
X; SUBOPTION = (:INIT 0.0) The SUBOPTION given is either a symbol or a
X; list. When a list, the rest of the arguments will be passed to the
X; function (may be NIL). If a symbol, NIL is passed as arguments.
X; NOTE: Should make sure that the value returned by the suboption is
X; the value of this routine, since some code may want to use
X; the value returned (like the value of the :INIT suboption).
X
X (apply (car suboption-info)
X (list (if (consp suboption) (cdr suboption) nil)
X variable
X type-info)))
X
X
X(defun instance-variable-ok? (variable list-of-variables type-name)
X
X; Signal a standard error if the variable is SELF,
X; one of the variables that are already in the list
X; of variables, or a keyword.
X; TYPE-NAME is used for error messages by CO-DEFTYPE-ERROR.
X
X (unless (legal-instance-variable variable)
X
X ; THEN error.
X
X (co-deftype-error
X "'SELF' NIL, or symbol from the keyword package~%was found as an instance variable."
X type-name))
X
X (when (member variable list-of-variables :test #'eq)
X
X ; THEN We have a duplicate variable.
X
X (co-deftype-error
X "instance variable '~S' occurs more~%than once."
X type-name
X variable)))
X
X(defun legal-instance-variable (variable)
X
X; Return T if VARIABLE satisfies restrictions on instance variables.
X; Return NIL otherwise. Currently, the variable must be a non-NIL symbol
X; that is not SELF.
X; Must also be a symbol that is NOT in the
X; keyword package.
X
X (and (symbolp variable)
X variable
X (not (eq variable 'co::self))
X (not (keywordp variable))))
X
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; Parsing of :ALL-xxx
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X(defun parse-all-initable-option (var-names args type-info)
X
X; Parses: :ALL-INITABLE. ARGS will be NIL.
X
X (parse-initable-option var-names args type-info))
X
X(defun parse-all-gettable-option (var-names args type-info)
X
X; Parses: :ALL-GETTABLE. ARGS will be NIL.
X
X (parse-gettable-option var-names args type-info))
X
X(defun parse-all-settable-option (var-names args type-info)
X
X; Parses: :ALL-SETTABLE. ARGS will be NIL.
X
X (parse-settable-option var-names args type-info))
X
X(defun parse-gettable-option (var-names args type-info)
X
X; Example ARGS = (A B C D), NIL.
X; Duplicate variables specified are ignored.
X
X (dolist (gettable-variable (or args var-names))
X
X (if (member gettable-variable var-names :test #'eq)
X
X ; THEN This variable is a real instance variable.
X
X (setf (svref type-info $gettable-variables-slot)
X (add-to-set
X (svref type-info $GETTABLE-VARIABLES-SLOT)
X gettable-variable))
X ; ELSE We have an illegal variable name.
X
X (co-deftype-error
X "variable '~S' in the settable~% options list is not an instance variable.~%"
X (type-name type-info)
X gettable-variable))))
X
X(defun parse-settable-option (var-names args type-info)
X
X; Example ARGS = (A B C D), NIL. Duplicate variables specified are
X; ignored. Each settable instance variable
X; is added to the list of gettable and initable instance variables as
X; well.
X
X (dolist (settable-variable (or args var-names))
X
X (if (not (member settable-variable var-names :test #'eq))
X
X ; THEN We have an illegal variable name.
X
X (co-deftype-error
X "variable '~S' in the settable~% options list is not an instance variable~%."
X (type-name type-info)
X settable-variable)
X
X ; ELSE This variable is a real instance variable.
X
X (progn
X (setf (svref type-info $initable-variables-slot)
X (add-to-set
X (svref type-info $initable-variables-slot)
X settable-variable))
X (setf (svref type-info $gettable-variables-slot)
X (add-to-set
X (svref type-info $gettable-variables-slot)
X settable-variable))
X (setf (svref type-info $settable-variables-slot)
X (add-to-set
X (svref type-info $settable-variables-slot)
X settable-variable))))))
X
X(defun parse-initable-option (var-names args type-info)
X
X; Example ARGS = (A B C D), NIL. Duplicate
X; variables specified are ignored.
X
X (dolist (initable-variable (or args var-names))
X
X (if (member initable-variable var-names :test #'eq)
X
X ; THEN This variable is a real instance variable.
X
X (setf (svref type-info $initable-variables-slot)
X (add-to-set
X (svref type-info $initable-variables-slot)
X
X initable-variable))
X ; ELSE We have an (svref type-info $initable-variables-serror
X "variable '~S' in the initable~% options list is not an instance variable.~%"
X (type-name type-info)
X initable-variable))))
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; Parsing of :INIT-KEYWORDS Option and Suboption and :REDEFINED-METHODS
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X(defun parse-init-keywords-option (var-names args type-info)
X (declare (ignore var-names))
X
X; Parses: (:INIT-KEYWORDS <symbol>). Doesn't use VAR-NAMES. By the
X; time this routine is called, each element of args has been checked to
X; be a symbol not equal to NIL. ARGS is also a proper list. For
X; (:INIT-KEYWORDS), ARGS will be NIL. We add the existing
X; init-keywords because we may have hit :INIT-KEYWORDS suboptions from
X; :INHERIT-FROM options.
X
X (setf (svref type-info $INIT-KEYWORDS-SLOT)
X (add-to-set (svref type-info $INIT-KEYWORDS-SLOT) args)))
X
X(defun parse-no-init-keyword-check-option (var-names args type-info)
X (declare (ignore args var-names))
X
X; Parses: :NO-INIT-KEYWORD-CHECK. VAR-NAMES is not used.
X
X (setf (svref type-info $NO-INIT-KEYWORD-CHECK-SLOT) t))
X
X(defun parse-redefined-methods-option (var-names args type-info)
X
X (declare (ignore var-names))
X
X; Parses: (:REDEFINED-METHODS M1 M2 M3), or (:REDEFINED-METHODS). ARGS
X; = (M1 M2 M3). At this point, ARGS is guaranteed to be a proper list
X; where each element is a symbol that is non-NIL. For
X; (:REDEFINED-METHODS), args is NIL. NOTE: The order of arguments are
X; stored away doesn't matter.
X
X (setf (svref type-info $methods-to-not-define-slot)
X (remove-duplicates args :test #'eq)))
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; Parsing of :INHERIT-FROM Option and Suboption
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X(defun parse-inherit-from-option (var-names args type-info)
X (declare (ignore var-names))
X
X; ARGS is the list of remaining stuff inside the :INHERIT-FROM option.
X; We know that ARGS is a proper list and that it has at least one element.
X; Sample: ARGS = (PARENT1 (:METHODS M1 M2 M3)
X; (:VARIABLES X Y Z)
X; (:INIT-KEYWORDS :EXCEPT Q))
X; VAR-NAMES is not used. Note that for error handling to be changed to
X; continuable errors, these options will have to be changed, since side
X; effects to type info can occur before a syntax error occurs. When
X; finished, the $PARENT-TYPES-SLOT and the $PARENTS-INFO-SLOT may be
X; changed.
X
X (if (and (consp args) (symbolp (car args)))
X
X ; THEN The form of the parent is ok.
X ; Now check if it is partially defined.
X
X (let ((parent-type-info (type-partially-defined? (car args)))
X (parents (svref type-info $PARENT-TYPES-SLOT))
X (new-parent (car args)))
X
X (if (not parent-type-info)
X
X ; THEN The parent isn't defined. Give an error.
X
X (co-deftype-error
X "~%the parent '~s',~s of the :INHERIT-FROM option, is not defined."
X (type-name type-info)
X new-parent)
X
X ; ELSE The parent is partially defined.
X ; First check that options specified are ok.
X ; Add the parent to the type-info slot. We must append
X ; since the order is important -- the first :INHERIT-FROM option
X ; must be the first parent.
X ; Check that we don't have something like:
X ; (INHERIT-FROM B...)
X ; (INHERIT-FROM B...) within the type definition.
X (if
X (member new-parent parents :test #'eq)
X
X ; THEN Two or more parents that are the same parent.
X
X (co-deftype-error
X "~~Sarent '~s' of type '~s'~s can only be a parent once."
X (type-name type-info)
X new-parent
X (type-name type-info))
X
X ; ELSE Everything is ok.
X ; Add the parents type-info to be used later.
X ; This is stored in the same order as the parents in the
X ; $PARENT-TYPES-SLOT for consistency.
X
X (progn
X (set-parents-info
X type-info
X (append (get-parents-info type-info)
X (list
X (list new-parent parent-type-info '*place-holder*))))
X (setf (svref type-info $PARENT-TYPES-SLOT)
X (append parents (list new-parent)))
X (parse-inherit-from-suboptions
X type-info
X parent-type-info
X (cdr args))))))
X
X ; ELSE The parent form is illegal.
X
X (co-deftype-error
X "~%a symbol must follow an :INHERIT-FROM~% option."
X (type-name type-info))))
X
X(defun parse-inherit-from-suboptions
X (type-info parent-type-info suboptions)
X
X; It is legal for SUBOPTIONS to be NIL. For understandibility,
X; expandability, and consistancy the parsing of subptions uses the same
X; techniques with the same keywords for option information. This is
X; true even though some of the option information may not be shared
X; between options and suboptions. See CO-PARSE-OPTIONS and its
X; constituent routines. NOTE: If the name of :METHODS option is ever
X; changed (in RETURN-OPTION-INFO) the references to :METHODS must be
X; changed here as well.
X;
X; Example: SUBOPTIONS = ((:VARIABLES A B)
X; (:METHODS C D)
X; (:INIT-KEYWORDS EXCEPT J))
X
X (let ((suboptions-so-far nil)
X (suboption-name nil)
X (suboption-info nil))
X
X (dolist (suboption suboptions)
X
X ; SUBOPTION-INFO will be NIL if SUBOPTION-NAME is not a
X ; legal suboption, or a list of information that tells what
X ; characteristics this suboption has. Note that currently,
X ; if an error occurs in SUBOPTON-OK? we will NOT return
X ; to this function. The check for (WHEN SUBOPTION-INFO...)
X ; is for future continuable errors. If 'ONCE' is on this
X ; list, it means the suboption can only occur once.
X
X (multiple-value-setq (suboption-name suboption-info)
X (option-ok?
X suboption
X type-info
X 'inherit-from-suboption))
X (when suboption-info
X
X ; THEN The suboption is a real one.
X ; Now make sure it doesn't occur more then once.
X
X (if
X (and (member suboption-name suboptions-so-far :test #'eq)
X (member 'once (cdr suboption-info) :test #'eq))
X
X ; THEN We have duplicate suboptions. Give an error.
X
X (co-deftype-error
X "duplicate suboption,~s '~s',~s specified to :INHERIT-FROM option."
X (type-name type-info)
X suboption)
X
X ; ELSE Everything is ok.
X
X (progn
X (setf suboptions-so-far
X (cons suboption-name suboptions-so-far))
X (parse-inherit-from-suboption
X type-info
X parent-type-info
X suboption
X suboption-info)))))
X
X ; Now check the one funny case: If the :METHODS option was NOT present.
X
X (unless (member ':methods suboptions-so-far :test #'eq)
X
X ; THEN We had no :METHODS suboption, so inherit all methods
X ; (but not universal methods). Do this by making
X ; a suboption (:METHODS :EXCEPT), and having it parsed.
X
X (multiple-value-setq (suboption-name suboption-info)
X (option-ok?
X '(:methods :except)
X type-info
X 'inherit-from-suboption))
X
X (parse-inherit-from-suboption
X type-info
X parent-type-info
X '(:methods :except)
X suboption-info))))
X
X(defun parse-inherit-from-suboption
X (type-info parent-type-info suboption suboption-info)
X
X; Example: SUBOPTION = (:INIT-KEYWORDS :EXCEPT J K L) The suboption
X; given is either a symbol or a list. When a list, the rest of the
X; arguments will be passed to the function (may be NIL). If a symbol,
X; NIL is passed as arguments.
X
X (apply (car suboption-info)
X (list type-info
X parent-type-info
X (if (consp suboption) (cdr suboption) nil))))
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; Method Definition
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X(defun co-parse-method-macro-call
X (spec argument-list body)
X
X; Make sure that the type-name and method-name are ok. Also, that the
X; call is a proper list.
X; Note that use of instance variable names as formal
X; parameter names to the method and use of SELF as a formal parameter
X; name are not checked.
X
X (let
X (
X (type-name NIL)
X (method-name NIL)
X )
X
X ; Check to be sure the body is a proper list or NIL
X
X (unless (or (null body) (proper-list body))
X
X ; THEN the method definition is not a proper list
X
X (define-method-error
X "The call,~% '(DEFINE-METHOD ~S ~S ~S)',~% is missing arguments or is an improper list."
X spec argument-list body))
X
X ; Check the spec
X
X (unless (and (proper-list spec) (= (length spec) 2)) ;rds 3/8 eq->=
X
X ; THEN The form of the (type-name method-name) is incorrect.
X
X (define-method-error
X "The type-name and method-name in the call,~% '(DEFINE-METHOD ~S ~S ~S)',~% must be a two element proper list."
X spec argument-list body))
X
X (setf method-name (second spec))
X (setf type-name (first spec))
X
X (unless (co-legal-type-or-method-name type-name)
X
X ; THEN Invalid type.
X
X (define-method-error
X "Type name '~S' in the call,~% '(DEFINE-METHOD ~S ~S ~S)',~% must be a non-NIL symbol."
X type-name
X spec
X argument-list
X body))
X
X (unless (co-legal-type-or-method-name method-name)
X
X ; THEN Invalid method.
X
X (define-method-error
X "Method name '~S' in the call,~% '(DEFINE-METHOD ~S ~S ~S)',~% must be a non-NIL symbol."
X method-name
X spec
X argument-list
X body))
X
X ; Check that the argument-list is indeed a list.
X
X (unless (or (null argument-list) (proper-list argument-list))
X (define-method-error
X "The argument list in the call,~% '(DEFINE-METHOD ~S ~S ~S)',~% is missing or must be a proper list."
X spec
X argument-list
X body))
X
X ) ;let
X) ;co-parse-method-macro-call
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; Call-Method Support
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X(defun co-parse-call-to-method (call-method-call which-func class-name)
X
X; Parse a call to a CALL-METHOD or APPLY-METHOD. Signal any
X; errors in syntax.
X; 'which-func' is either "CALL-METHOD" or "APPLY-METHOD".
X
X (let ((method-name nil)
X (rest-of-call call-method-call))
X
X (setf rest-of-call (cdr rest-of-call))
X
X ; This should now be the list of arguments
X
X (unless (proper-list rest-of-call)
X
X ; THEN The call to CALL-METHOD is not a proper list.
X
X (error
X (format nil
X "~A: The call,~% '~S',~% is missing arguments or is an improper list."
X which-func
X call-method-call)))
X
X ; If the form is APPLY-METHOD, check to be sure the argument list is
X ; not NIl
X
X (when (equalp which-func "APPLY-METHOD")
X (unless (cadr rest-of-call)
X
X (error
X (format nil
X "APPLY-METHOD: The call,~% '~S',~% has no argument list."
X call-method-call
X )
X )
X )
X )
X
X (setf method-name (first rest-of-call))
X
X (cond
X ((co-legal-type-or-method-name method-name)
X
X ; THEN We have the local form of call-method (i.e.,
X ; (CALL-METHOD MOOSE 3) ) so just return.
X
X NIL
X )
X
X ; ELSE Check if a two element list, each element a symbol.
X
X ((consp method-name)
X (unless
X (and (= (length method-name) 2)
X (proper-list method-name)
X (co-legal-type-or-method-name (first method-name))
X (co-legal-type-or-method-name (second method-name))
X (co::legal-parent-p class-name (first method-name)))
X
X ; Incorrect parent form of call-method.
X
X (error
X (format nil
X "~A: Illegal parent reference '~S' in~% '~S'.~% Must have the form: '(type-symbol operation-symbol)'."
X which-func
X method-name
X call-method-call)
X ))
X )
X
X ; Anything else is an error.
X
X (t
X (error
X (format nil
X "~A: Incorrect form '~S' in~% '~S'.~% Expecting non-NIL symbol or list or two non-NIL symbols."
X which-func
X method-name
X call-method-call))))
X
X ) ;let
X
X) ;co-parse-call-to-method
X
X(defun check-that-method-to-call-exists
X (possible-method-name child-name parent-name parent-methods)
X
X; Return the name of the method we will be calling.
X; The method name to use is determined as follows: First, always use the ':'
X; version of the name. If the method with this name is not defined,
X; check if the name without the ':' is defined. If it is, issue a
X; warning message that we are calling this method. If it isn't
X; defined, issue a warning message that the method is not defined and
X; that we will call the ':' version when it is defined. For example,
X; if we had the POSSIBLE-METHOD-NAME of A we would first check if a
X; method named :A existed in the PARENT-METHODS. If it does, we
X; return :A. If it doesn't, we see if a method with the name A
X; exists. If it does, we return this name and give a warning. If it
X; doesn't, we return :A and give a warning.
X
X (let*
X ((method-to-call
X (return-keyword-from-variable possible-method-name))
X (saved-method-to-call method-to-call))
X
X (unless (assoc method-to-call parent-methods :test #'eq)
X
X ; THEN The ':' version of the method doesn't exist.
X ; Now check if the non-colon version exists.
X
X (setf method-to-call possible-method-name)
X
X (if
X (assoc method-to-call parent-methods :test #'eq)
X
X ; THEN We are calling the non-colon version of the method.
X ; Give a warning message.
X
X (warn
X (format nil
X "DEFINE-TYPE: In type, '~A', '~A' of :VARIABLES suboption, will reference the parent method '~A'."
X child-name
X possible-method-name
X possible-method-name))
X
X ; ELSE Give a warning that we will assume calling the ':' version.
X
X (progn (setf method-to-call saved-method-to-call)
X (warn
X (format nil
X "DEFINE-TYPE: In type, '~A', '~A' of :VARIABLES suboption, has no corresponding method defined in parent '~A'. Will assume you want to call method '~A'."
X child-name
X possible-method-name
X parent-name
X method-to-call)))))
X method-to-call))
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
END_OF_FILE
if test 56836 -ne `wc -c <'co-parse.l'`; then
echo shar: \"'co-parse.l'\" unpacked with wrong size!
fi
# end of 'co-parse.l'
fi
echo shar: End of archive 13 \(of 13\).
cp /dev/null ark13isdone
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.uat c