Compiling 2/8/90 PCL beta on EnvOS Medley

[Henrik Eriksson <her@ida.liu.se>]

Here comes a set of patches which make 2/8/90 beta PCL compile on
EnvOS Medley, at least on the 1186. Changes are marked with ****.
I hope this won't introduce other problems.

-- Henrik



;----------------
;from cache.lisp

(defun find-free-cache-line (primary field cache)
  (declare (values line empty?))
  (with-local-cache-functions (cache)
    (let ((limit (funcall (limit-fn) (nlines)))
	  (wrappedp nil))
      (when (line-reserved-p primary) (setq primary (next-line primary)))
      (labels (;;
       ;; Try to find a free line starting at <start>.  <primary>
       ;; is the primary line of the entry we are finding a free
       ;; line for, it is used to compute the seperations.
       ;;
       (find-free (p s)
	 (do* ((line s (next-line line))
	       (nsep (line-separation p s) (1+ nsep)))
	      (())
	   (if (null (line-valid-p line))	;If this line is empty or
	       (return (values line t))	        ;invalid, just use it.
	       (let ((osep (line-separation (line-primary field line) line)))
		 (if (and wrappedp (>= line primary))
		     ;;
		     ;; have gone all the way around the cache, time to quit
		     ;; 
		     (return (values line nil))
			     
		     (when (cond ((or (= nsep limit)) t)
				 ((= nsep osep) (zerop (random 2)))
				 ((> nsep osep) t)
				 (t nil))
		       ;;
		       ;; Try to displace what is in this line so that we
		       ;; can use the line.
		       ;; 
		       ;; **** Due to a bug in the Medley compiler.
			  (return (values line (displace line)))))))
		   
	   (if (= line (1- (nlines))) (setq wrappedp t))))
       ;;
       ;; Given a line, attempt to free up that line by moving its
       ;; contents elsewhere. Returns nil when it wasn't possible to
       ;; move the contents of the line without dumping something on
       ;; the floor.  
       ;; 
       (displace (line)
	 (if (= line (1- (nlines))) (setq wrappedp t))
	 (multiple-value-bind (dline dempty?)
	     (find-free (line-primary field line) (next-line line))
	   (when dempty? (copy-line line dline) t))))
	
  (find-free primary primary)))))



;----------------
;from defs.lisp

(defun do-standard-defsetf-1 (function-name)
  (unless (setfboundp function-name)
    (let* ((setf-function-name (get-setf-function-name function-name)))
    
      #+Genera
      (let ((fn #'(lambda (form)
		    (lt::help-defsetf
		      '(&rest accessor-args) '(new-value) function-name 'nil
		      `(`(,',setf-function-name ,new-value .,accessor-args))
		      form))))
	(setf (get function-name 'lt::setf-method) fn
	      (get function-name 'lt::setf-method-internal) fn))

      #+Lucid
      (lucid::set-simple-setf-method 
	function-name
	#'(lambda (form new-value)
	    (let* ((bindings (mapcar #'(lambda (x) `(,(gensym) ,x))
				     (cdr form)))
		   (vars (mapcar #'car bindings)))
	      ;; This may wrap spurious LET bindings around some form,
	      ;;   but the PQC compiler will unwrap then.
	      `(LET (,.bindings)
		 (,setf-function-name ,new-value . ,vars)))))
      
      #+kcl
      (let ((helper (gensym)))
	;;
	;; KCL's setf macro generates better code when setf methods are
	;; defined by (defsetf x y) than when they are defined by the
	;; long form of defsetf or by define-setf-method.
	;; 
	(setf (macro-function helper)
	      #'(lambda (form env &aux (args (cdr form)))
		  (declare (ignore env))
		  `(,setf-function-name ,(car (last args)) ,@(butlast args))))
	(eval `(defsetf ,function-name ,helper)))
      
      ;; Due to wrong arguments: (this makes sense to me)
      ;; **** name -> function-name
      ;; **** expander-name -> setf-method-expander
      #+Xerox
      (flet ((setf-expander (body env)
	       (declare (ignore env))
	       (let ((temps
		       (mapcar #'(lambda (x) (declare (ignore x)) (gensym))
			       (cdr body)))
		     (forms (cdr body))
		     (vars (list (gensym))))
		 (values temps
			 forms
			 vars
			 `(,setf-function-name ,@vars ,@temps)
			 `(,function-name ,@temps)))))
	(let ((setf-method-expander (intern (concatenate 'string
						  (symbol-name function-name)
						  "-setf-expander")
				     (symbol-package function-name))))
	  (setf (get function-name :setf-method-expander) setf-method-expander
		(symbol-function setf-method-expander) #'setf-expander)))
      
      #-(or Genera Lucid kcl Xerox)
      (eval `(defsetf ,function-name (&rest accessor-args) (new-value)
	       `(,',setf-function-name ,new-value ,@accessor-args)))
      
      )))


;----------------
;from fin.lisp

(defvar *mattress-pad-code* 
	(binary-assemble
		#+MC68000
		'(#x2A6D #x11 #x246D #x1 #x4EEA #x5)
		#+SPARC
		(ecase (lucid::procedure-length #'lucid::false)
		  (5
		   '(#xFA07 #x6012 #xDE07 #x7FFE #x81C3 #xFFFE #x100 #x0))
		  (8
		   `(#xFA07 #x601E #xDE07 #x7FFE #x81C3 #xFFFE #x100 #x0)))
		;; **** Due to a bug in the Medley reader
		#+(and BSP (not LCL3.0))  ; ****
		'(#xCD33 #x11 #xCDA3 #x1 #xC19A #x5 #xE889)
		#+(and BSP LCL3.0)        ; ****
		'(#x7733 #x7153 #xC155 #x5 #xE885)
		#+I386
		'(#x87 #xD2 #x8B #x76 #xE #xFF #x66 #xFE)
		#+VAX
		'(#xD0 #xAC #x11 #x5C #xD0 #xAC #x1 #x57 #x17 #xA7 #x5)
		#+PA
		'(#x4891 #x3C #xE461 #x6530 #x48BF #x3FF9)
		#-(or MC68000 SPARC BSP I386 VAX PA)
		'(0 0 0 0)))




;----------------
;from plap.lisp

; **** Due to misspelled function name
(defun index-value->index (index-value) index-value)

;----------------
;from pcl-env.lisp

; **** object -> standard-object
(defmethod il:inspect/as/function ((name standard-object) stkp window)
  (when (il:menu (il:|create| il:menu
		     il:items il:_ '(("Inspect" t "Inspect this object"))))
    (inspect name)))
-------