LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760032840. :SYSTEM-TYPE :LOGICAL :VERSION 1. :TYPE "LISP" :NAME "KCL-LOW" :DIRECTORY ("REL3-PUBLIC" "PUBLIC" "PCL") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-PUBLIC\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2756388156. :AUTHOR "REL3" :LENGTH-IN-BYTES 7058. :LENGTH-IN-BLOCKS 7. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                            ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: (PCL Lisp 1000); Base: 10. -*-;;;;;; *************************************************************************;;; Copyright (c) 1985, 1986, 1987 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.;;; *************************************************************************;;;;;; The version of low for Kyoto Common Lisp (KCL)(in-package 'pcl);;;; low level stuff to hack compiled functions and compiled closures.;;;;;; The primary client for this is fsc-low, but since we make some use of;;; it here (e.g. to implement set-function-name) it all appears here.;;;(eval-when (compile)(defmacro define-cstruct-accessor (accessor structure-type field value-type)  (let ((setf (intern (concatenate 'string "SET-" (string accessor))))(caccessor (format nil "pcl_get_~A_~A" structure-type field))(csetf     (format nil "pcl_set_~A_~A" structure-type field)))    `(progn       (CLines ,(format nil "~A ~A(~A)                ~%~                             struct ~A *~A;           ~%~                             { return ~A->~A; }       ~%~                                                      ~%~                             ~A ~A(~A, new)           ~%~                             struct ~A *~A;           ~%~                             ~A new;                  ~%~                             { return ~A->~A = new; } ~%~                            "value-type caccessor structure-typestructure-type structure-typestructure-type fieldvalue-type csetf structure-typestructure-type structure-typevalue-typestructure-type field))       (defentry ,accessor (object) (object ,caccessor))       (defentry ,setf (object object) (object ,csetf))       (defsetf ,accessor ,setf)       ))));;; ;;; struct cfun {                   /*  compiled function header  */;;;         short   t, m;;;;         object  cf_name;        /*  compiled function name  */;;;         int     (*cf_self)();   /*  entry address  */;;;         object  cf_data;        /*  data the function uses  */;;;                                 /*  for GBC  */;;;         char    *cf_start;      /*  start address of the code  */;;;         int     cf_size;        /*  code size  */;;; };;;;(define-cstruct-accessor cfun-name  "cfun" "cc_name"  "object")(define-cstruct-accessor cfun-self  "cfun" "cc_self"  "int")(define-cstruct-accessor cfun-data  "cfun" "cc_data"  "object")(define-cstruct-accessor cfun-start "cfun" "cc_start" "char")(define-cstruct-accessor cfun-size  "cfun" "cc_size"  "int")(CLines  "object pcl_cfunp (x)              "  "object x;                         "  "{if(x->c.t == (int) t_cfun)       "  "  return (Ct);                    "  "  else                            "  "    return (Cnil);                "  "  }                               "  )(defentry cfunp (object) (object pcl_cfunp));;; ;;; struct cclosure {               /*  compiled closure header  */;;;         short   t, m;;;;         object  cc_name;        /*  compiled closure name  */;;;         int     (*cc_self)();   /*  entry address  */;;;         object  cc_env;         /*  environment  */;;;         object  cc_data;        /*  data the closure uses  */;;;                                 /*  for GBC  */;;;         char    *cc_start;      /*  start address of the code  */;;;         int     cc_size;        /*  code size  */;;; };;;; (define-cstruct-accessor cclosure-name "cclosure"  "cc_name"  "object")(define-cstruct-accessor cclosure-self "cclosure"  "cc_self"  "int")(define-cstruct-accessor cclosure-data "cclosure"  "cc_data"  "object")(define-cstruct-accessor cclosure-start "cclosure" "cc_start" "char")(define-cstruct-accessor cclosure-size "cclosure"  "cc_size"  "int")(define-cstruct-accessor cclosure-env "cclosure"   "cc_env"   "object")(CLines  "object pcl_cclosurep (x)          "  "object x;                         "  "{if(x->c.t == (int) t_cclosure)   "  "  return (Ct);                    "  "  else                            "  "   return (Cnil);                 "  "  }                               "  )(defentry cclosurep (object) (object pcl_cclosurep))  ;;   ;;;;;; Load Time Eval  ;;;;; ;;; This doesn't work because it looks at a global variable to see if it is;;; in the compiler rather than looking at the macroexpansion environment.;;; ;;; The result is that if in the process of compiling a file, we evaluate a;;; form that has a call to load-time-eval, we will get faked into thinking;;; that we are compiling that form.;;;;;; THIS NEEDS TO BE DONE RIGHT!!!;;; ;(defmacro load-time-eval (form);  ;; In KCL there is no compile-to-core case.  For things that we are ;  ;; "compiling to core" we just expand the same way as if were are;  ;; compiling a file since the form will be evaluated in just a little;  ;; bit when gazonk.o is loaded.;  (if (and (boundp 'compiler::*compiler-input*)  ;Hack to see of we are;   compiler::*compiler-input*)  ;in the compiler!;      `'(si:|#,| . ,form);      `(progn ,form)))  ;;   ;;;;;; Generating CACHE numbers  ;;;;; This needs more work to be sure it is going as fast as possible.;;;   -  The calls to si:address should be open-coded.;;;   -  The logand should be open coded.;;;   (defmacro symbol-cache-no (symbol mask)  (if (and (constantp symbol)   (constantp mask))      `(load-time-eval (logand (ash (si:address ,symbol) -2) ,mask))      `(logand (ash (the fixnum (si:address ,symbol)) -2) ,mask)))(defmacro object-cache-no (object mask)  `(logand (the fixnum (si:address ,object)) ,mask))(defmacro memory-block-ref (block offset)  `(svref ,block ,offset))  ;;   ;;;;;; printing-random-thing-internal  ;;(defun printing-random-thing-internal (thing stream)  (format stream "~O" (si:address thing)))(defun set-function-name (fn new-name)  (cond ((cclosurep fn) (setf (cclosure-name fn) new-name))((cfunp fn) (setf (cfun-name fn) new-name))((and (listp fn)      (eq (car fn) 'lambda-block)) (setf (cadr fn) new-name))((and (listp fn)      (eq (car fn) 'lambda)) (setf (car fn) 'lambda-block       (cdr fn) (cons new-name (cdr fn)))))  new-name)ommon) keywordp)(define-built-in-class array (common) arrayp)(define-built-in-class vector (sequence array)