;;; -*- 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-1) 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-type
structure-type structure-type
structure-type field
value-type csetf structure-type
structure-type structure-type
value-type
structure-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" "cf←name" "object")
(define-cstruct-accessor cfun-self "cfun" "cf←self" "int")
(define-cstruct-accessor cfun-data "cfun" "cf←data" "object")
(define-cstruct-accessor cfun-start "cfun" "cf←start" "char")
(define-cstruct-accessor cfun-size "cfun" "cf←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)))
(defmacro memory-block-ref (block offset)
`(svref (the simple-vector ,block) (the fixnum ,offset)))
;;
;;;;;; 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))
;;
;;;;;; printing-random-thing-internal
;;
(defun printing-random-thing-internal (thing stream)
(format stream "~O" (si:address thing)))
(defun set-function-name-1 (fn new-name ignore)
(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)))))
fn)