LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760032825. :SYSTEM-TYPE :LOGICAL :VERSION 1. :TYPE "LISP" :NAME "DFUN-TEMPL" :DIRECTORY ("REL3-PUBLIC" "PUBLIC" "PCL") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-PUBLIC\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2756388096. :AUTHOR "REL3" :LENGTH-IN-BYTES 8415. :LENGTH-IN-BLOCKS 9. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                         ;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-;;;;;; *************************************************************************;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.;;;;;; Use and copying of this software and preparation of derivative works;;; based upon this software are permitted.  Any distribution of this;;; software or derivative works must comply with all applicable United;;; States export control laws.;;; ;;; This software is made available AS IS, and Xerox Corporation makes no;;; warranty about the software, its performance or its conformity to any;;; specification.;;; ;;; Any person obtaining a copy of this software is requested to send their;;; name and post office or electronic mail address to:;;;   CommonLoops Coordinator;;;   Xerox Artifical Intelligence Systems;;;   2400 Hanover St.;;;   Palo Alto, CA 94303;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa);;;;;; Suggestions, comments and requests for improvements are also welcome.;;; *************************************************************************;;;(in-package 'pcl);;; ;;; A caching discriminating function looks like:;;;   (lambda (arg-1 arg-2 arg-3 &rest rest-args);;;     (prog* ((class-1 (class-of arg-1));;;             (class-2 (class-of arg-2));;;             method-function);;;        (and (cached-method method-function CACHE MASK class-1 class-2);;;             (go hit));;;      miss;;;        (setq method-function;;;              (cache-method GENERIC-FUNCTION;;;                            (lookup-method-function GENERIC-FUNCTION;;;                                                    class-1;;;                                                    class-2)));;;      hit;;;        (if method-function;;;            (return (apply method-function arg-1 arg-2 arg-3 rest-args));;;            (return (no-matching-method GENERIC-FUNCTION)))));;;;;; The upper-cased variables are the ones which are lexically bound.;;; There is a great deal of room to play here.  This open codes the;;; test to see if the instance is iwmc-class-p.  Only if it isn't is;;; there a function call to class-of.  This is done because we only have;;; a default implementation of make-discriminating-function, we don't;;; have one which is specific to generic-function-class;;; STANDARD-GENERIC-FUNCTION and meta-class CLASS.;;;;;; Of course a real implementation of CommonLoops wouldn't even do a;;; real function call to get to the discriminating function.(eval-when (compile load eval)(defun default-make-class-of-form-fn (arg)  `(class-of-1 ,arg))(defvar *make-class-of-form-fn* #'default-make-class-of-form-fn))(define-function-template caching-discriminating-function                          (required restp    specialized-positions    lookup-function    mask)                          '(.GENERIC-FUNCTION. .CACHE.)  (let* ((args (iterate ((i from 0 below required))                 (collect (make-symbol (format nil "Disc-Fn-Arg ~D" i)))))         (class-bindings   ;; *** Pay careful attention to what is going on here.  What is   ;; *** going on here, is that if a position is not specialized,   ;; *** then we just let its class (THE CLASS THAT WE WILL PASS   ;; *** TO THE LOOKUP FUNCTION), be NIL.  This is done for two   ;; *** reasons:   ;; ***    1. speed, if we don't need the class, why bother to   ;; ***       compute it.   ;; ***    2. Bootstrapping reasons.  During Booting, there are   ;; ***       times when we can't compute the class of something,   ;; ***       but it is a T specialized argument (the new value   ;; ***       argument to a setf of an accessor.   (iterate ((i from 0 to (apply #'max specialized-positions)))          (collect       (list (make-symbol (format nil "Class of ARG ~D" i))     (if (member i specialized-positions) (funcall *make-class-of-form-fn* (nth i args)) nil)))))         (classes (remove nil (mapcar #'car class-bindings)))         (method-function-var (make-symbol "Method Function"))         (rest-arg-var (and restp (make-symbol "Disc-Fn-&Rest-Arg"))))    `(function       (lambda (,@args ,@(and rest-arg-var (list '&rest rest-arg-var)))         (prog ((,method-function-var nil),@class-bindings)   (and (setq ,method-function-var      (cached-method .CACHE. ,mask ,@classes))(go hit))   (and (setq ,method-function-var      (cache-method .CACHE.    ,mask    (,lookup-function .GENERIC-FUNCTION.      ,@classes)    ,@classes))(go hit))   (no-matching-method .GENERIC-FUNCTION.)hit (return      ,(if restp   `(apply ,method-function-var ,@args ,rest-arg-var)   `(funcall ,method-function-var ,@args))))))))(eval-when (compile)(defmacro pre-make-caching-discriminating-functions (specs)  `(progn . ,(iterate ((spec in specs))       (collect `(pre-make-templated-function-constructor   caching-discriminating-function   ,@spec   ,(make-generic-function-cache-mask      (length (caddr spec)))))))))(eval-when (load)  (pre-make-caching-discriminating-functions    ((2 NIL (1) LOOKUP-MULTI-METHOD);setf of accessor gfuns     (2 NIL (0 1) LOOKUP-MULTI-METHOD)     (4 NIL (0) LOOKUP-CLASSICAL-METHOD)     (5 NIL (0) LOOKUP-CLASSICAL-METHOD)     (1 T (0) LOOKUP-CLASSICAL-METHOD)     (3 NIL (0 1) LOOKUP-MULTI-METHOD)     (4 T (0) LOOKUP-CLASSICAL-METHOD)     (3 T (0) LOOKUP-CLASSICAL-METHOD)     (3 NIL (0) LOOKUP-CLASSICAL-METHOD)     (1 NIL (0) LOOKUP-CLASSICAL-METHOD)     (2 NIL (0) LOOKUP-CLASSICAL-METHOD))))  ;;   ;;;;;;   ;;(eval-when (compile load eval)(defun make-checking-discriminating-function-1 (check-positions)  (iterate ((pos in check-positions))    (collect (if (null pos) 'ignore (intern (format nil "Check ~D" pos)))))))(define-function-template checking-discriminating-function(required restp defaultp checks)`(generic-function method-function default-function,@(make-checking-discriminating-function-1 checks))  (let* ((arglist (make-discriminating-function-arglist required restp)))    `(function       (lambda ,arglist (declare (optimize (speed 3) (safety 0))) generic-function default-function ;ignorable         (if (and ,@(iterate ((check in     (make-checking-discriminating-function-1       checks))                              (arg in arglist))                      (when (neq check 'ignore)(collect  `(memq ,check; (let ((.class. (class-of ,arg)));   (get-slot--class .class.;    'class-precedence-list)) #| (get-static-slot--class   ,(funcall *make-class-of-form-fn* arg)   ,(slotd-position 'class-precedence-list    *bootstrap-slots*)) |# (get-slot--class   ,(funcall *make-class-of-form-fn* arg)   'class-precedence-list)  )))))             ,(if restp                  `(apply method-function ,@(remove '&rest arglist))                  `(funcall method-function ,@arglist))             ,(if defaultp                  (if restp                      `(apply default-function ,@(remove '&rest arglist))                      `(funcall default-function ,@arglist))                  `(no-matching-method generic-function)))))))(eval-when (compile)(defmacro pre-make-checking-discriminating-functions (specs)  `(progn . ,(iterate ((spec in specs))       (collect `(pre-make-templated-function-constructor   checking-discriminating-function   ,@spec))))))(eval-when (load)  (pre-make-checking-discriminating-functions ((2 NIL NIL (0 1))       (2 NIL NIL (NIL 1))       (2 T   NIL (0))       (3 NIL NIL (0 1))       (7 NIL NIL (0 1))       (5 NIL NIL (0 1))       (3 NIL NIL (0 NIL 2))       (6 NIL NIL (0))       (5 NIL NIL (0))       (4 T NIL (0))       (3 T NIL (0))       (1 T NIL (0))       (4 NIL NIL (0))       (3 NIL NIL (0))       (3 NIL T (0 1))       (2 NIL T (0))       (5 NIL T (0 1))       (1 T T (0))       (1 NIL T (0))       (2 NIL T (0 1))       (3 NIL T (0))       (2 T T (0))       (6 NIL T (0 1))       (3 NIL T (0 NIL 2))       (4 NIL T (0 1))       (4 NIL T (0))       (5 NIL T (0))       (1 NIL NIL (0))       (2 NIL NIL (0)))))re (ignore d))       (format s "#<Module ~A>" (module-name m)))))  name  load-env  comp-env  recomp-reasons)(defun make-modules (system-description)  (let ((modules ()))    (labels ((get-module (name)       (or (find name modules :key #'module-name)   (progn (setq modules (cons (make-module name) modules))  (car modules))))     (parse-spec (spec)       (if (eq spec 't)   (reverse (cdr modules))   (mapcar #'get-module spec))))      (dolist (file system-description)(let* ((name (car file))       (module (get-module name)))  (setf (module-load-env module) (parse-spec (cadr file))(module-comp-env module) (parse-spec (caddr file))(module-recomp-reasons module) (parse-spec (cadddr file))))))    (reverse modules)))(defun make-transformations (modules f