;;; -*- 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.
;;; *************************************************************************
;;; 
;;; This is the Lucid lisp version of the file portable-low.
;;;
;;; Lucid:               (415)329-8400
;;; 

(in-package 'pcl)

;;; First, import some necessary "internal" or Lucid-specific symbols

(eval-when (eval compile load)

(#-LCL3.0 progn #+LCL3.0 lcl:handler-bind 
    #+LCL3.0 ((lcl:warning #'(lambda (condition)
			       (declare (ignore condition))
			       (lcl:muffle-warning))))
(let ((importer
        #+LCL3.0 #'sys:import-from-lucid-pkg
	#-LCL3.0 (let ((x (find-symbol "IMPORT-FROM-LUCID-PKG" "LUCID")))
		   (if (and x (fboundp x))
		       (symbol-function x)
		       ;; Only the #'(lambda (x) ...) below is really needed, 
		       ;;  but when available, the "internal" function 
		       ;;  'import-from-lucid-pkg' provides better checking.
		       #'(lambda (name)
			   (import (intern name "LUCID")))))))
  ;;
  ;; We need the following "internal", undocumented Lucid goodies:
  (mapc importer '("%POINTER" "DEFSTRUCT-SIMPLE-PREDICATE"
		   #-LCL3.0 "LOGAND&" "%LOGAND&" #+VAX "LOGAND&-VARIABLE"))

  ;;
  ;; For without-interrupts.
  ;; 
  #+LCL3.0
  (mapc importer '("*SCHEDULER-WAKEUP*" "MAYBE-CALL-SCHEDULER"))

  ;;
  ;; We import the following symbols, because in 2.1 Lisps they have to be
  ;;  accessed as SYS:<foo>, whereas in 3.0 lisps, they are homed in the
  ;;  LUCID-COMMON-LISP package.
  (mapc importer '("ARGLIST" "NAMED-LAMBDA" "*PRINT-STRUCTURE*"))
  ;;
  ;; We import the following symbols, because in 2.1 Lisps they have to be
  ;;  accessed as LUCID::<foo>, whereas in 3.0 lisps, they have to be
  ;;  accessed as SYS:<foo>
  (mapc importer '(
		   "NEW-STRUCTURE"   	"STRUCTURE-REF"
		   "STRUCTUREP"         "STRUCTURE-TYPE"  "STRUCTURE-LENGTH"
		   "PROCEDUREP"     	"PROCEDURE-SYMBOL"
		   "PROCEDURE-REF" 	"SET-PROCEDURE-REF" 
		   ))
; ;;
; ;;  The following is for the "patch" to the general defstruct printer.
; (mapc importer '(
; 	           "OUTPUT-STRUCTURE" 	  "DEFSTRUCT-INFO"
;		   "OUTPUT-TERSE-OBJECT"  "DEFAULT-STRUCTURE-PRINT" 
;		   "STRUCTURE-TYPE" 	  "*PRINT-OUTPUT*"
;		   ))
  ;;
  ;; The following is for a "patch" affecting compilation of %logand&.
  ;; On APOLLO, Domain/CommonLISP 2.10 does not include %logand& whereas
  ;; Domain/CommonLISP 2.20 does; Domain/CommonLISP 2.20 includes :DOMAIN/OS
  ;; on *FEATURES*, so this conditionalizes correctly for APOLLO.
  #-(or (and APOLLO DOMAIN/OS) LCL3.0 VAX) 
  (mapc importer '("COPY-STRUCTURE"  "GET-FDESC"  "SET-FDESC"))
  
  nil))

;; end of eval-when

)
	

;;;
;;; Patch up for the fact that the PCL package creation in defsys.lisp
;;;  will probably have an explicit :use list ??
;;;
;;;  #+LCL3.0 (use-package *default-make-package-use-list*)




#+lcl3.0
(progn

(defvar *saved-compilation-speed* 3)

; the production compiler sometimes
; screws up vars within labels

(defmacro dont-use-production-compiler ()
  '(eval-when (compile)
     (setq *saved-compilation-speed* (if LUCID:*USE-SFC* 3 0))
     (proclaim '(optimize (compilation-speed 3)))))

(defmacro use-previous-compiler ()
  `(eval-when (compile)
     (proclaim '(optimize (compilation-speed ,*saved-compilation-speed*)))))

)

(defmacro %logand (x y)
  #-VAX `(%logand& ,x ,y)
  #+VAX `(logand&-variable ,x ,y))

;;; Fix for VAX LCL
#+VAX
(defun logand&-variable (x y)
  (logand&-variable x y))

;;; Fix for other LCLs
#-(or (and APOLLO DOMAIN/OS) LCL3.0 VAX)
(eval-when (compile load eval)

(let* ((logand&-fdesc (get-fdesc 'logand&))
       (%logand&-fdesc (copy-structure logand&-fdesc)))
  (setf (structure-ref %logand&-fdesc 0 t) '%logand&)
  (setf (structure-ref %logand&-fdesc 7 t) nil)
  (setf (structure-ref %logand&-fdesc 8 t) nil)
  (set-fdesc '%logand& %logand&-fdesc))

(eval-when (load)
  (defun %logand& (x y) (%logand& x y)))

(eval-when (eval)
  (compile '%logand& '(lambda (x y) (%logand& x y))))

);#-(or LCL3.0 (and APOLLO DOMAIN/OS) VAX)

;;;
;;; From: JonL
;;; Date: November 28th, 1988
;;; 
;;;  Here's a better attempt to do the without-interrupts macro for LCL3.0.
;;;  For the 2.1  release, maybe you should just ignore it (i.e, turn it 
;;;  into a PROGN and "take your chances") since there isn't a uniform way
;;;  to do inhibition.  2.1 has interrupts, but no multiprocessing.
;;;
;;;  The best bet for protecting the cache is merely to inhibit the
;;;  scheduler, since asynchronous interrupts are only run when "scheduled".
;;;  Of course, there may be other interrupts, which can cons and which 
;;;  could cause a GC; but at least they wouldn't be running PCL type code.
;;;
;;;  Note that INTERRUPTS-ON shouldn't arbitrarily enable scheduling again,
;;;  but rather simply restore it to the state outside the scope of the call
;;;  to WITHOUT-INTERRUPTS.  Note also that an explicit call to 
;;;  MAYBE-CALL-SHEDULER must be done when "turning interrupts back on", if
;;;  there are any interrupts/schedulings pending; at least the test to see
;;;  if any are pending is very fast.

#+LCL3.0
(defmacro without-interrupts (&body body)
  `(macrolet ((interrupts-on  ()
		`(when (null outer-scheduling-state)
		   (setq lcl:*inhibit-scheduling* nil)
		   (when *scheduler-wakeup* (maybe-call-scheduler))))
	      (interrupts-off () 
		'(setq lcl:*inhibit-scheduling* t)))
     (let ((outer-scheduling-state lcl:*inhibit-scheduling*))
       (prog1 (let ((lcl:*inhibit-scheduling* t)) . ,body)
	      (when (and (null outer-scheduling-state) *scheduler-wakeup*)
		(maybe-call-scheduler))))))


;;; The following should override the definitions provided by lucid-low.
;;;
#+(or LCL3.0 (and APOLLO DOMAIN/OS))
(progn
(defstruct-simple-predicate std-instance std-instance-p)
(defstruct-simple-predicate fast-method-call fast-method-call-p)
(defstruct-simple-predicate method-call method-call-p)
)



(defun set-function-name-1 (fn new-name ignore)
  (declare (ignore ignore))
  (if (not (procedurep fn))
      (error "~S is not a procedure." fn)
      (if (compiled-function-p fn)
	  ;; This is one of:
	  ;;   compiled-function, funcallable-instance, compiled-closure
	  ;;   or a macro.
	  ;; So just go ahead and set its name.
	  ;; Only change the name when necessary: maybe it is read-only.
	  (unless (eq new-name (procedure-ref fn procedure-symbol))
	    (set-procedure-ref fn procedure-symbol new-name))
	  ;; This is an interpreted function.
	  ;; Seems like any number of different things can happen depending
	  ;; vaguely on what release you are running.  Try to do something
	  ;; reasonable.
	  (let ((symbol (procedure-ref fn procedure-symbol)))
	    (cond ((symbolp symbol)
		   ;; In fact, this is the name of the procedure.
		   ;; Just set it.
		   (set-procedure-ref fn procedure-symbol new-name))
		  ((and (listp symbol)
			(eq (car symbol) 'lambda))
		   (setf (car symbol) 'named-lambda
			 (cdr symbol) (cons new-name (cdr symbol))))
		  ((eq (car symbol) 'named-lambda)
		   (setf (cadr symbol) new-name))))))		  
  fn)

(defun function-arglist (fn)
  (arglist fn))

  ;;   
;;;;;; printing-random-thing-internal
  ;;
(defun printing-random-thing-internal (thing stream)
  (format stream "~O" (%pointer thing)))


;;;
;;; 16-Feb-90 Jon L White
;;;
;;; A Patch provide specifically for the benefit of PCL, in the Lucid 3.0
;;;  release environment.  This adds type optimizers for FUNCALL so that
;;;  forms such as:
;;;
;;;     (FUNCALL (THE PROCEDURE F) ...)
;;;
;;;  and:
;;;
;;;     (LET ((F (Frobulate)))
;;;       (DECLARE (TYPE COMPILED-FUNCTION F))
;;;       (FUNCALL F ...))
;;;
;;;  will just jump directly to the procedure code, rather than waste time
;;;  trying to coerce the functional argument into a procedure.
;;;


(in-package "LUCID")


;;; (DECLARE-MACHINE-CLASS COMMON)
(set-up-compiler-target 'common)


(set-function-descriptor 'FUNCALL
  :TYPE  'LISP
  :PREDS 'NIL
  :EFFECTS 'T
  :OPTIMIZER  #'(lambda (form &optional environment) 
		  (declare (ignore form environment))
		  (let* ((fun (second form))
			 (lambdap (and (consp fun) 
				       (eq (car fun) 'function)
				       (consp (second fun))
				       (memq (car (second fun))
					     '(lambda internal-lambda)))))
		    (if (not lambdap) 
			form
			(alphatize 
			  (cons (second fun) (cddr form)) environment))))
  :FUNCTIONTYPE '(function (function &rest t) (values &rest t))
  :TYPE-DISPATCH `(((PROCEDURE &REST T) (VALUES &REST T)
		    ,#'(lambda (anode fun &rest args) 
			 (declare (ignore anode fun args))
			 `(FAST-FUNCALL ,fun ,@args)))
		   ((COMPILED-FUNCTION &REST T)  (VALUES &REST T)
		    ,#'(lambda (anode fun &rest args) 
			 (declare (ignore anode fun args))
			 `(FAST-FUNCALL ,fun ,@args))))
  :LAMBDALIST '(FN &REST ARGUMENTS)
  :ARGS '(1 NIL)
  :VALUES '(0 NIL)
  )

(def-compiler-macro fast-funcall (&rest args &environment env)
  (if (COMPILER-OPTION-SET-P :READ-SAFETY ENV)
      `(FUNCALL-SUBR . ,args)
      `(&FUNCALL . ,args)))



(setf (symbol-function 'funcall-subr) #'funcall)


;;; (UNDECLARE-MACHINE-CLASS)
(restore-compiler-params)


(in-package 'pcl)

(pushnew :structure-wrapper *features*)

(defun structure-functions-exist-p ()
  t)

(defun structure-instance-p (x)
  (and (structurep x)
       (not (eq 'std-instance (structure-type x)))))

(defvar *structure-type* nil)
(defvar *structure-length* nil)

(defun structure-type-p (type)
  (declare (special lucid::*defstructs*))
  (let ((s-data (gethash type lucid::*defstructs*)))
    (or (and s-data 
	     (eq 'structure (structure-ref s-data 1 'defstruct))) ; type - Fix this
	(and type (eq *structure-type* type)))))

(defun structure-type-included-type-name (type)
  (declare (special lucid::*defstructs*))
  (let ((s-data (gethash type lucid::*defstructs*)))
    (and s-data (structure-ref s-data 6 'defstruct)))) ; include - Fix this

(defun structure-type-slot-description-list (type)
  (declare (special lucid::*defstructs*))
  (let ((s-data (gethash type lucid::*defstructs*)))
    (if s-data
	(nthcdr (let ((include (structure-ref s-data 6 'defstruct)))
		  (if include
		      (let ((inc-s-data (gethash include lucid::*defstructs*)))
			(if inc-s-data
			    (length (structure-ref inc-s-data 7 'defstruct))
			    0))
		      0))
		(map 'list
		     #'(lambda (slotd)
			 (let* ((ds 'lucid::defstruct-slot)
				(slot-name (system:structure-ref slotd 0 ds))
				(position (system:structure-ref slotd 1 ds))
				(accessor (system:structure-ref slotd 2 ds))
				(read-only-p (system:structure-ref slotd 5 ds)))
			   (list slot-name accessor
				 #'(lambda (x)
				     (system:structure-ref x position type))
				 (unless read-only-p
				   #'(lambda (v x)
				       (setf (system:structure-ref x position type)
					     v))))))
		     (structure-ref s-data 7 'defstruct))) ; slots  - Fix this
	(let ((result (make-list *structure-length*)))
	  (dotimes (i *structure-length* result)
	    (let* ((name (format nil "SLOT~D" i))
		   (slot-name (intern name (or (symbol-package type) *package*)))
		   (i i))
	      (setf (elt result i) (list slot-name nil
					 #'(lambda (x)
					     (system:structure-ref x i type))
					 nil))))))))

(defun structure-slotd-name (slotd)
  (first slotd))

(defun structure-slotd-accessor-symbol (slotd)
  (second slotd))

(defun structure-slotd-reader-function (slotd)
  (third slotd))

(defun structure-slotd-writer-function (slotd)
  (fourth slotd))