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


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

;  (unless (fboundp 'excl::_fn_symdef)
;    (setf (symbol-function 'excl::_fn_symdef)
;	  (symbol-function 'excl::fn_symdef))
;    (defsetf excl::_fn_symdef (x) (y) `(setf (excl::fn_symdef ,x) ,y)))
;
;  (unless (fboundp 'excl::_fn_locals)
;    (setf (symbol-function 'excl::_fn_locals)
;	  (symbol-function 'excl::fn_locals))
;    (defsetf excl::_fn_locals (x) (y) `(setf (excl::fn_locals ,x) ,y)))

  )

(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))))))

(defmacro load-time-eval (form)
  (cond ((and sys:*macroexpand-for-compiler* sys:*compile-to-core*)
	 `',(eval form))
	((and sys:*macroexpand-for-compiler* sys:*compile-to-file*)
	 `'(,compiler::*eval-when-load-marker* . ,form))
	(t
	 `(progn ,form))))

(defmacro symbol-cache-no (symbol mask)
  (if (and (constantp symbol)
	   (constantp mask))
      `(load-time-eval (logand (ash (excl::sy_hash ,symbol) -1) ,mask))
      `(logand (ash (the fixnum (excl::sy_hash ,symbol)) -1)
	       (the fixnum ,mask))))

(defmacro object-cache-no (object mask)
  `(logand (the fixnum (excl::pointer-to-fixnum ,object))
	   (the fixnum ,mask)))

(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)
  (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)))