;;; -*- 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 EXCL (Franz) lisp version of the file portable-low.
;;; 
;;; This is for version 1.1.2.  Many of the special symbols now in the lisp
;;; package (e.g. lisp::pointer-to-fixnum) will be in some other package in
;;; a later release so this will need to be changed.
;;; 

(in-package 'pcl)

(defmacro without-interrupts (&body body)
  `(let ((outer-interrupts excl::*without-interrupts*)
	 (excl::*without-interrupts* 0))
     (macrolet ((interrupts-on  ()
		  '(unless outer-interrupts
		     (setq excl::*without-interrupts* nil)))
		(interrupts-off ()
		  '(setq excl::*without-interrupts* 0)))
       ,.body)))

(eval-when (compile load eval)
  (unless (fboundp 'excl::sy_hash)
    (setf (symbol-function 'excl::sy_hash)
	  (symbol-function 'excl::_sy_hash-value)))
  )

(defmacro memq (item list)
  (let ((list-var (gensym))
	(item-var (gensym)))
    `(prog ((,list-var ,list)
	    (,item-var ,item))
	start
	   (cond ((null ,list-var)
		  (return nil))
		 ((eq (car ,list-var) ,item-var)
		  (return ,list-var))
		 (t
		  (pop ,list-var)
		  (go start))))))

(defun std-instance-p (x)
  (and (excl::structurep x)
       (locally
	 (declare #.*optimize-speed*)
	 (eq (svref x 0) 'std-instance))))

(excl::defcmacro std-instance-p (x)
  (once-only (x)
    `(and (excl::structurep ,x)
	  (locally
	    (declare #.*optimize-speed*)
	    (eq (svref ,x 0) 'std-instance)))))

(excl::defcmacro fast-method-call-p (x)
  (once-only (x)
    `(and (excl::structurep ,x)
	  (locally
	    (declare #.*optimize-speed*)
	    (eq (svref ,x 0) 'fast-method-call)))))

(defmacro %std-instance-wrapper (x)
  `(svref ,x 1))

(defmacro %std-instance-slots (x)
  `(svref ,x 2))

(defun printing-random-thing-internal (thing stream)
  (format stream "~O" (excl::pointer-to-fixnum thing)))

#-vax
(defun set-function-name-1 (fn new-name ignore)
  (declare (ignore ignore))
  (cond ((excl::function-object-p fn)
	 (setf (excl::fn_symdef fn) new-name))
	(t nil))
  fn)

(defun function-arglist (f)
  (excl::arglist f))

(defun symbol-append (sym1 sym2 &optional (package *package*))
   ;; This is a version of symbol-append from macros.cl
   ;; It insures that all created symbols are of one case and that
   ;; case is the current prefered case.
   ;; This special version of symbol-append is not necessary if all you
   ;; want to do is compile and run pcl in a case-insensitive-upper 
   ;; version of cl.  
   ;;
   (let ((string (string-append sym1 sym2)))
      (case excl::*current-case-mode*
	 ((:case-insensitive-lower :case-sensitive-lower)
	  (setq string (string-downcase string)))
	 ((:case-insensitive-upper :case-sensitive-upper)
	  (setq string (string-upcase string))))
      (intern string package)))

;;; Define inspector hooks for PCL object instances.

(defun (:property pcl::std-instance :inspector-function) (object)
  (let ((class (class-of object)))
    (cons (inspect::make-field-def "class" #'class-of :lisp)
	  (mapcar #'(lambda (slot)
		      (inspect::make-field-def
		       (string (slot-definition-name slot))
		       #'(lambda (x)
			   (slot-value-using-class class x slot))
		       :lisp))
		  (slots-to-inspect class object)))))

(defun (:property pcl::std-instance :inspector-type-function) (x)
  (class-name (class-of x)))
