;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 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 PARC
;;;   3333 Coyote Hill Rd.
;;;   Palo Alto, CA 94304
;;; (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)

;;;
;;; The reason these are here is because the KCL compiler does not allow
;;; LET to return FIXNUM values as values of (c) type int, hence the use
;;; of LOCALLY (which expands into (LET () (DECLARE ...) ...)) forces
;;; conversion of ints to objects.
;;; 
(defmacro %logand (&rest args)
  (reduce-variadic-to-binary 'logand args 0 t 'fixnum))

;(defmacro %logxor (&rest args)
;  (reduce-variadic-to-binary 'logxor args 0 t 'fixnum))

(defmacro %+ (&rest args)
  (reduce-variadic-to-binary '+ args 0 t 'fixnum))

;(defmacro %- (x y)
;  `(the fixnum (- (the fixnum ,x) (the fixnum ,y))))

(defmacro %* (&rest args)
  (reduce-variadic-to-binary '* args 1 t 'fixnum))

(defmacro %/ (x y)
  `(the fixnum (/ (the fixnum ,x) (the fixnum ,y))))

(defmacro %1+ (x)
  `(the fixnum (1+ (the fixnum ,x))))

(defmacro %1- (x)
  `(the fixnum (1- (the fixnum ,x))))

(defmacro %svref (vector index)
  `(svref (the simple-vector ,vector) (the fixnum ,index)))

(defsetf %svref (vector index) (new-value)
  `(setf (svref (the simple-vector ,vector) (the fixnum ,index))
         ,new-value))


;;;
;;; std-instance-p
;;;
(si:define-compiler-macro std-instance-p (x)
  (once-only (x)
    `(and (si:structurep ,x)
	  (eq (si:structure-name ,x) 'std-instance))))

(dolist (inline '((si:structurep
		    ((t) compiler::boolean nil nil "type_of(#0)==t_structure")
		    compiler::inline-always)
		  (si:structure-name
		    ((t) t nil nil "(#0)->str.str_name")
		    compiler::inline-unsafe)))
  (setf (get (first inline) (third inline)) (list (second inline))))

(setf (get 'cclosure-env 'compiler::inline-always)
      (list '((t) t nil nil "(#0)->cc.cc_env")))

;;;
;;; turbo-closure patch.  See the file kcl-mods.text for details.
;;;
#+:turbo-closure
(progn
(CLines
  "object tc_cc_env_nthcdr (n,tc)"
  "object n,tc;                        "
  "{return (type_of(tc)==t_cclosure&&  "
  "         tc->cc.cc_turbo!=NULL&&    "
  "         type_of(n)==t_fixnum)?     "
  "         tc->cc.cc_turbo[fix(n)]:   " ; assume that n is in bounds
  "         Cnil;                      "
  "}                                   "
  )

(defentry tc-cclosure-env-nthcdr (object object) (object tc_cc_env_nthcdr))

(setf (get 'tc-cclosure-env-nthcdr 'compiler::inline-unsafe)
      '(((fixnum t) t nil nil "(#1)->cc.cc_turbo[#0]")))
)


;;;; 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 eval)

(defmacro define-cstruct-accessor (accessor structure-type field value-type
					    field-type tag-name)
  (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))
	(vtype (intern (string-upcase value-type))))
    `(progn
       (CLines ,(format nil "~A ~A(~A)                ~%~
                             object ~A;               ~%~
                             { return ((~A) ~A->~A.~A); }       ~%~
                                                      ~%~
                             ~A ~A(~A, new)           ~%~
                             object ~A;               ~%~
                             ~A new;                  ~%~
                             { return ((~A)(~A->~A.~A = ~Anew)); } ~%~
                            "
			value-type caccessor structure-type 
			structure-type
			value-type structure-type tag-name field
			value-type csetf structure-type
			structure-type 
			value-type 
			value-type structure-type tag-name field field-type
			))

       (defentry ,accessor (object) (,vtype ,caccessor))
       (defentry ,setf (object ,vtype) (,vtype ,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  */
;;; };
;;; add field-type tag-name
(define-cstruct-accessor cfun-name  "cfun" "cf_name"  "object" "(object)" "cf")
(define-cstruct-accessor cfun-self  "cfun" "cf_self"  "int" "(int (*)())" 
                         "cf")
(define-cstruct-accessor cfun-data  "cfun" "cf_data"  "object" "(object)" "cf")
(define-cstruct-accessor cfun-start "cfun" "cf_start" "int" "(char *)" "cf")
(define-cstruct-accessor cfun-size  "cfun" "cf_size"  "int" "(int)" "cf")

(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"
                         "(object)" "cc")          
(define-cstruct-accessor cclosure-self "cclosure"  "cc_self"  "int" 
                         "(int (*)())" "cc")
(define-cstruct-accessor cclosure-data "cclosure"  "cc_data"  "object"
                          "(object)" "cc")
(define-cstruct-accessor cclosure-start "cclosure" "cc_start" "int" 
                         "(char *)" "cc")
(define-cstruct-accessor cclosure-size "cclosure"  "cc_size"  "int"
			 "(int)" "cc")
(define-cstruct-accessor cclosure-env "cclosure"   "cc_env"   "object"
                         "(object)" "cc")


(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 load-time-eval (form)
  (read-from-string (format nil "'#,~S" 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)




#|
(defconstant most-positive-small-fixnum 1024)  /* should be supplied */
(defconstant most-negative-small-fixnum -1024) /* by ibuki */

(defmacro symbol-cache-no (symbol mask)
  (if (constantp mask)
      (if (and (> mask 0)
	       (< mask most-positive-small-fixnum))
	  (if (constantp symbol)
	      `(load-time-eval (coffset ,symbol ,mask 2))
	    `(coffset ,symbol ,mask 2))
	(if (constantp symbol)
	    `(load-time-eval 
	       (logand (ash (the fixnum (si:address ,symbol)) -2) ,mask))
	  `(logand (ash (the fixnum (si:address ,symbol)) -2) ,mask)))
    `(logand (ash (the fixnum (si:address ,symbol)) -2) ,mask)))


(defmacro object-cache-no (object mask)
  (if (and (constantp mask)
	   (> mask 0)
	   (< mask most-positive-small-fixnum))
      `(coffset ,object ,mask 4)
    `(logand (ash (the fixnum (si:address ,object)) -4) ,mask)))

(CLines
  "object pcl_coffset (sym,mask,lshift)"
  "object sym,mask,lshift;"
  "{"
  "	return(small_fixnum(((int)sym >> fix(lshift)) & fix(mask)));"
  "}"
  )

(defentry coffset (object object object) (object pcl_coffset))


|#