;;; -*- Mode:LISP; Package:(PCL Lisp 1000); Base:10.; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; 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.
;;; *************************************************************************
;;;
;;; This is the 1100 (Xerox version) of the file portable-low.
;;;

(in-package 'pcl)

(defmacro load-time-eval (form)
  `(il:LOADTIMECONSTANT ,form))

  ;;   
;;;;;; Memory block primitives.
  ;;

; what I have done is to replace all calls to il:\\RPLPTR with a call to
; RPLPTR (in the PCL) package.  RPLPTR is a version which does some error
; checking and then calls il:\\RPLPTR.  As follows:

;(defun rplptr (block index value)
;  (if (< index (* (il:\\#blockdatacells block) 2))
;      (il:\\rplptr block index value)
;      (error "bad args to rplptr")))

(defmacro make-memory-block (size &optional area)
  `(il:\\allocblock ,size T))

(defmacro memory-block-ref (block offset)
  `(il:\\GETBASEPTR ,block (* ,offset 2)))

(defsetf memory-block-ref (memory-block offset) (new-value)
  `(il:\\rplptr ,memory-block (* ,offset 2) ,new-value))

(defmacro memory-block-size (block)
  ;; this returns the amount of memory allocated for the block --
  ;; it may be larger than size passed at creation
  `(il:\\#BLOCKDATACELLS ,block))

(defmacro CLEAR-memory-block (block start)
  (once-only (block)
    `(let ((end (* (il:\\#blockdatacells ,block) 2)))
       (do ((index (* ,start 2) (+ index 2)))
	   ((= index end))
	 (il:\\rplptr ,block index nil)))))

  ;;   
;;;;;; Static slot storage primitives
  ;;   

;;;
;;; Once everything sees to work, uncomment this back into play and remove
;;; the * 2 in the other places.
;;;
(eval-when (compile load eval)
  (if nil ;if this is T, then %convert-slotd-position-to-slot-index
          ;will do the multiplication.  Otherwise it will happen at
          ;at each access.  This is on an easy switch like this to
          ;make it easier to debug the code that caches the converted
          ;index.
      (progn (defmacro convert-to-index-1 (i) `(* ,i 2))
	     (defmacro convert-to-index-2 (i) i))
      (progn (defmacro convert-to-index-1 (i) i)
	     (defmacro convert-to-index-2 (i) `(* ,i 2))))
  )

(defmacro %convert-slotd-position-to-slot-index (slotd-position)
  `(convert-to-index-1 ,slotd-position))

(defmacro %allocate-static-slot-storage--class (no-of-slots)
  `(IL:\\ALLOCBLOCK ,no-of-slots t))

(defmacro %static-slot-storage-slot-value--class (static-slot-storage
						slot-index)
  `(IL:\\GETBASEPTR ,static-slot-storage (convert-to-index-2 ,slot-index)))

(defsetf %static-slot-storage-slot-value--class
	 (static-slot-storage slot-index)
	 (new-value)
  `(IL:\\RPLPTR ,static-slot-storage
		(convert-to-index-2 ,slot-index)
		,new-value))



  ;;   
;;;;;; FUNCTION-ARGLIST
  ;;

(defun function-arglist (x) (il:arglist x))

  ;;   
;;;;;; Generating CACHE numbers
  ;;

(defmacro symbol-cache-no (symbol mask)
  `(logand (il:llsh (logand #o17777 (il:\\loloc ,symbol)) 2) ,mask))

(defmacro object-cache-no (object mask)
  `(logand (il:\\loloc ,object) ,mask))


  ;;   
;;;;;; printing-random-thing-internal
  ;;

(defun printing-random-thing-internal (thing stream)
  (princ (il:\\hiloc thing) stream)
  (princ "," stream)
  (princ (il:\\loloc thing) stream))

(defun record-definition (name type &optional parent-name parent-type)
  (declare (ignore type parent-name))
  ())




;;;
;;; FSC-LOW uses this too!
;;;
(eval-when (compile load eval)
  (il:datatype il:compiled-closure (il:fnheader il:environment))

  (il:blockrecord closure-overlay ((funcallable-instance-p il:flag)))  

  )

(defun compiled-closure-fnheader (compiled-closure)
  (il:fetch (il:compiled-closure il:fnheader) il:of compiled-closure))

(defun set-compiled-closure-fnheader (compiled-closure nv)
  (il:replace (il:compiled-closure il:fnheader) il:of compiled-closure nv))

(defsetf compiled-closure-fnheader set-compiled-closure-fnheader)

;;;
;;; In Lyric, and until the format of FNHEADER changes, getting the name from
;;; a compiled closure looks like this:
;;; 
;;; (fetchfield '(nil 4 xpointer)
;;;             (fetch (compiled-closure fnheader) closure))
;;;
;;; Of course this is completely non-robust, but it will work for now.  This
;;; is not the place to go into a long tyrade about what is wrong with having
;;; record package definitions go away when you ship the sysout; there isn't
;;; enough diskspace.
;;;             
(defun set-function-name-1 (fn new-name uninterned-name)
  (cond ((typep fn 'il:compiled-closure)
	 (il:replacefield '(nil 4 il:xpointer)
			  (compiled-closure-fnheader fn)
			  new-name)
	 (when (and (listp uninterned-name)
		    (eq (car uninterned-name) 'method))
	   (let ((debug (si::compiled-function-debugging-info fn)))
	     (when debug (setf (cdr debug) uninterned-name)))))
	(t nil))
  fn)