🚀 go-pugleaf

I got PCL via FTP.

My address is:    Bruno Haible
                  Augartenstrasse 40
             D - W7500 Karlsruhe 1
                  Germany
             haible@ma2s2.mathematik.uni-karlsruhe.de

I'm trying to compile it with CLISP (my own Common Lisp implementation).
I'm getting a bunch of warnings, mainly relating to unknown declarations,
usused variables and perhaps mispelled function names. Then, during
"Loading binary of METHODS...", I get
*** - #<#<std-instance> > is not a legal class name.

This says absolutely nothing to me, as every PCL object is printed in that way
at that stage.

Can someone help me? Is this a well-known problem?

For reference, I include the modifications I made to PCL.

Later,
              Bruno Haible
              haible@ma2s2.mathematik.uni-karlsruhe.de

============================
These are the differences:

Only in pcl: clisp-low.lsp
diff -w -r -c3 pcl.orig/defs.lsp pcl/defs.lsp
*** pcl.orig/defs.lsp	Mon Apr  6 18:49:58 1992
--- pcl/defs.lsp	Thu Apr 23 22:50:39 1992
***************
*** 98,105 ****
    #+excl  (or (excl::encapsulated-basic-definition symbol)
  	      (symbol-function symbol))
    #+xerox (il:virginfn symbol)
    #+setf (fdefinition symbol)
!   #-(or Lispm Lucid excl Xerox setf) (symbol-function symbol))
  
  ;;;
  ;;; If symbol names a function which is traced or advised, redefine
--- 98,106 ----
    #+excl  (or (excl::encapsulated-basic-definition symbol)
  	      (symbol-function symbol))
    #+xerox (il:virginfn symbol)
+   #+CLISP (get symbol 'sys::traced-definition)
    #+setf (fdefinition symbol)
!   #-(or Lispm Lucid excl Xerox CLISP setf) (symbol-function symbol))
  
  ;;;
  ;;; If symbol names a function which is traced or advised, redefine
***************
*** 120,127 ****
              (setf (symbol-function symbol) new-definition)
              (when brokenp (xcl:rebreak-function symbol))
              (when advisedp (xcl:readvise-function symbol)))
    #+setf (setf (fdefinition symbol) new-definition)
!   #-(or Lispm Lucid excl Xerox setf)
    (setf (symbol-function symbol) new-definition)
    
    new-definition)
--- 121,136 ----
              (setf (symbol-function symbol) new-definition)
              (when brokenp (xcl:rebreak-function symbol))
              (when advisedp (xcl:readvise-function symbol)))
+   #+CLISP (let ((traced (get symbol 'sys::traced-definition)))
+             (if traced
+               (if (consp traced)
+                 (progn
+                   (sys::untrace2 symbol)
+                   (setf (symbol-function symbol) new-definition))
+                 (setf (get symbol 'sys::traced-definition) new-definition))
+               (setf (symbol-function symbol) new-definition)))
    #+setf (setf (fdefinition symbol) new-definition)
!   #-(or Lispm Lucid excl Xerox CLISP setf)
    (setf (symbol-function symbol) new-definition)
    
    new-definition)
***************
*** 313,320 ****
  	#+ExCL
  	(setf (get name 'excl::deftype-expander) expand-fn)
  	#+:coral
! 	(setf (get name 'ccl::deftype-expander) expand-fn)))
!   #-(or :Genera (and :Lucid (not :Prime)) ExCL :coral)
    ;; This is the default for ports for which we don't know any
    ;; better.  Note that for most ports, providing this definition
    ;; should just speed up class definition.  It shouldn't have an
--- 322,332 ----
  	#+ExCL
  	(setf (get name 'excl::deftype-expander) expand-fn)
  	#+:coral
! 	(setf (get name 'ccl::deftype-expander) expand-fn)
!         #+CLISP
!         (setf (get name 'sys::deftype-expander) expand-fn)
!   ) )
!   #-(or :Genera (and :Lucid (not :Prime)) ExCL :coral CLISP)
    ;; This is the default for ports for which we don't know any
    ;; better.  Note that for most ports, providing this definition
    ;; should just speed up class definition.  It shouldn't have an
diff -w -r -c3 pcl.orig/defsys.lsp pcl/defsys.lsp
*** pcl.orig/defsys.lsp	Wed Apr  8 03:24:34 1992
--- pcl/defsys.lsp	Thu Apr 23 21:48:28 1992
***************
*** 233,239 ****
            #+HP-HPLabs            HP-HPLabs
            #+:gclisp              gclisp
            #+pyramid              pyramid
!           #+:coral               coral))
  
  ;;;
  ;;; When you get a copy of PCL (by tape or by FTP), the sources files will
--- 233,240 ----
            #+HP-HPLabs            HP-HPLabs
            #+:gclisp              gclisp
            #+pyramid              pyramid
!           #+:coral               coral
!           #+CLISP                CLISP))
  
  ;;;
  ;;; When you get a copy of PCL (by tape or by FTP), the sources files will
***************
*** 287,294 ****
  	 #+:gclisp                           ("LSP"   . "F2S")
  	 #+pyramid                           ("clisp" . "o")
  	 #+:coral                            ("lisp"  . "fasl")
  	 #-(or symbolics (and dec common vax) KCL IBCL Xerox 
! 	       lucid excl :CMU HP TI :gclisp pyramid coral)
  	                                     ("lisp"  . "lbin"))))
  
  (defvar *pathname-extensions*
--- 288,297 ----
  	 #+:gclisp                           ("LSP"   . "F2S")
  	 #+pyramid                           ("clisp" . "o")
  	 #+:coral                            ("lisp"  . "fasl")
+          #+(and CLISP UNIX)                  ("lsp"   . "fas")
+          #+(and CLISP (not UNIX))            ("LSP"   . "FAS")
  	 #-(or symbolics (and dec common vax) KCL IBCL Xerox 
! 	       lucid excl :CMU HP TI :gclisp pyramid coral CLISP)
  	                                     ("lisp"  . "lbin"))))
  
  (defvar *pathname-extensions*
***************
*** 495,500 ****
--- 498,504 ----
  		 (unless print-only
  		   (let  ((name (module-name m)))
  		     (compile-file (make-source-pathname name)
+                                    #+CLISP :listing #+CLISP t
  				   :output-file
  				   (make-pathname :defaults
  						  (make-binary-pathname name)
***************
*** 532,538 ****
  				(:binary (cdr *system-directory*)))))))
           (pathname
             (make-pathname
!              :name (string-downcase (string name))
               :type extension
               :defaults directory)))
  
--- 536,546 ----
  				(:binary (cdr *system-directory*)))))))
           (pathname
             (make-pathname
!              :name #-(and CLISP (or ATARI DOS)) (string-downcase (string name))
!                    #+(and CLISP (or ATARI DOS))
!                    (let ((name (remove #\- (string-upcase (string name)))))
!                      (if (> (length name) 8) (subseq name 0 8) name)
!                    )
               :type extension
               :defaults directory)))
  
***************
*** 579,587 ****
      ;;
      #+LUCID (or lucid::*source-pathname* (bad-time))
      #+akcl   si:*load-pathname*
!     #-(or Lispm excl Xerox (and dec vax common) LUCID akcl) nil))
  
! #-(or cmu Symbolics)
  (defvar *pcl-directory*
  	(or (load-truename t)
  	    (error "Because load-truename is not implemented in this port~%~
--- 587,596 ----
      ;;
      #+LUCID (or lucid::*source-pathname* (bad-time))
      #+akcl   si:*load-pathname*
!     #+CLISP (first (sys::search-file "defsys.lsp" nil))
!     #-(or Lispm excl Xerox (and dec vax common) LUCID akcl CLISP) nil))
  
! #-(or cmu Symbolics CLISP)
  (defvar *pcl-directory*
  	(or (load-truename t)
  	    (error "Because load-truename is not implemented in this port~%~
***************
*** 609,614 ****
--- 618,630 ----
  #+Cloe-Runtime
  (defvar *pcl-directory* (pathname "/usr3/hornig/pcl/"))
  
+ #+CLISP
+ (defvar *pcl-directory*
+ 	(or (load-truename t)
+             #+UNIX            (pathname "~/lisp/pcl/")
+             #+(or ATARI DOS)  (pathname "D:\\LISP\\PCL\\")
+ )       )
+ 
  (defsystem pcl	   
             *pcl-directory*
    ;;
***************
*** 651,656 ****
--- 667,673 ----
     (gold-low       (low)         (low)        (low)            gclisp) 
     (pyr-low        (low)         (low)        (low)            pyramid) 
     (coral-low      (low)         (low)        (low)            coral)
+    (clisp-low      (low)         (low)        (low)            CLISP)
     
     (fin         t                                   t (low))
     (defclass    t                                   t (low))
diff -w -r -c3 pcl.orig/fin.lsp pcl/fin.lsp
*** pcl.orig/fin.lsp	Sun Apr  5 03:25:27 1992
--- pcl/fin.lsp	Thu Apr 23 21:05:16 1992
***************
*** 1610,1615 ****
--- 1610,1663 ----
  
  
  ;;;
+ ;;; In CLISP, compiled functions (also called compiled closures) are just
+ ;;; a vector of constants, with one slot containing the bytecode. This means
+ ;;; that constants and closure variables are intermixed in the procedure
+ ;;; vector.
+ ;;;
+ #+CLISP
+ (progn
+   (let* ((mother-fin
+            #'(lambda (&rest args) (declare (compile)) (apply '#:G0 args))
+          )
+          (mother-fin-code
+            (sys::make-code-vector (sys::closure-codevec mother-fin))
+         ))
+     (defun allocate-funcallable-instance-1 ()
+       (sys::%make-closure 'FUNCALLABLE-INSTANCE mother-fin-code
+                           '#.(make-list (+ 1 (length funcallable-instance-data)) #| :initial-element nil |# )
+     ) )
+     (proclaim '(inline funcallable-instance-p))
+     (defun funcallable-instance-p (obj)
+       (and (sys::closurep obj) (eq (sys::%record-ref obj 1) mother-fin-code))
+     )
+   )
+   (defun set-funcallable-instance-function (fin new-value)
+     (let ((dummy-sym '#:G0))
+       (setf (symbol-function dummy-sym) new-value) ; zu einer Funktion coercen
+       (setf (sys::%record-ref fin 2) (symbol-function dummy-sym))
+     )
+     new-value
+   )
+   (defmacro funcallable-instance-data-1 (instance-form data-form)
+     (let ((position-form
+             (if (and (consp data-form)
+                      (eq (car data-form) 'quote)
+                      (boundp 'funcallable-instance-data)
+                 )
+               (or (position (cadr data-form) funcallable-instance-data :test #'eq)
+                   (progn
+                     (warn "Unknown funcallable-instance data: ~S." (cadr data-form))
+                     `(error "Unknown funcallable-instance data: ~S." ',(cadr data-form))
+               )   )
+               `(position ,data-form funcallable-instance-data :test #'eq)
+          )) )
+       `(sys::%record-ref ,instance-form (+ 3 ,position-form))
+   ) )
+ )
+ 
+ 
+ ;;;
  ;;; In H.P. Common Lisp
  ;;; This code was originally written by:
  ;;;    kempf@hplabs.hp.com     (James Kempf)
diff -w -r -c3 pcl.orig/macros.lsp pcl/macros.lsp
*** pcl.orig/macros.lsp	Sun Apr  5 22:31:11 1992
--- pcl/macros.lsp	Mon Jul 27 01:53:50 1992
***************
*** 619,625 ****
    #+:coral (or (get symbol 'ccl::setf-inverse)
  	       (get symbol 'ccl::setf-method-expander))
    #+cmu (fboundp `(setf ,symbol))
!   #-(or Genera Lucid KCL Xerox :coral cmu) nil)
  
  );eval-when
  
--- 619,626 ----
    #+:coral (or (get symbol 'ccl::setf-inverse)
  	       (get symbol 'ccl::setf-method-expander))
    #+cmu (fboundp `(setf ,symbol))
!   #+CLISP (get symbol 'sys::setf-expander)
!   #-(or Genera Lucid KCL Xerox :coral cmu CLISP) nil)
  
  );eval-when
  
diff -w -r -c3 pcl.orig/methods.lsp pcl/methods.lsp
*** pcl.orig/methods.lsp	Wed Apr  8 01:41:19 1992
--- pcl/methods.lsp	Thu Apr 23 22:58:29 1992
***************
*** 1045,1052 ****
  		    (specl2 (nth index (method-specializers method2)))
  		    (order (order-specializers 
  			     specl1 specl2 index compare-classes-function)))
! 	       (when order
! 		 (return-from sorter (eq order specl1)))))))
      (stable-sort methods #'sorter)))
  
  (defun map-all-orders (methods precedence function)
--- 1045,1051 ----
  		    (specl2 (nth index (method-specializers method2)))
  		    (order (order-specializers 
  			     specl1 specl2 index compare-classes-function)))
! 	       (when order (return (eq order specl1)))))))
      (stable-sort methods #'sorter)))
  
  (defun map-all-orders (methods precedence function)
diff -w -r -c3 pcl.orig/walk.lsp pcl/walk.lsp
*** pcl.orig/walk.lsp	Thu Mar 26 07:26:08 1992
--- pcl/walk.lsp	Thu Apr 23 21:07:03 1992
***************
*** 617,622 ****
--- 617,669 ----
  );#+(or KCL IBCL)
  
  
+ ;;;
+ ;;; In CLISP Common Lisp, the macroexpansion environment has the form
+ ;;;   NIL  or  #(sym1 def1 ... symn defn next-env)
+ ;;; where next-env is an macroexpansion environment of the same form.
+ ;;; A def entry herein is a cons (SYS::MACRO . macroexpansion-function)
+ ;;; for macros, and a symbol (a gensym in compiler, or NIL during
+ ;;; interpretation of LABELS) or a function object for functions.
+ ;;;
+ 
+ #+CLISP
+ (progn
+   (defmacro with-augmented-environment
+             ((new-env old-env &key functions macros) &body body)
+     `(let ((,new-env (with-augmented-environment-internal
+                        ,old-env ,functions ,macros
+           ))         )
+        ,@body
+      )
+   )
+   (defun with-augmented-environment-internal (env functions macros)
+     (let* ((new-env (make-array (+ (* (+ (length functions) (length macros)) 2) 1)))
+            (i 0))
+       (dolist (f functions)
+         (setf (svref new-env i) f) (incf i)
+         (setf (svref new-env i) #'unbound-lexical-function) (incf i)
+       )
+       (dolist (m macros)
+         (setf (svref new-env i) (first m)) (incf i)
+         (setf (svref new-env i) (cons 'sys::macro (second m))) (incf i)
+       )
+       (setf (svref new-env i) env)
+       new-env
+   ) )
+   (defun environment-function (env fn)
+     (let ((h (sys::fenv-assoc fn env)))
+       (or (eq h 'T) ; fenv-assoc didn't find anything
+           (sys::closurep h) (symbolp h)
+   ) ) )
+   (defun environment-macro (env macro)
+     (let ((h (sys::fenv-assoc macro env)))
+       (if (and (consp h) (eq (car h) 'sys::macro))
+         (cdr h) ; macroexpansion-function
+         nil ; anything
+   ) ) )
+ );#+CLISP
+ 
+ 
  ;;;   --- TI Explorer --
  
  ;;; An environment is a two element list, whose car we can ignore and

And here is the file clisp-low.lsp :

;;;-*-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.
;;; *************************************************************************
;;;
;;; The version of low for CLISP.

(in-package 'pcl)

(defconstant *slot-unbound* '..slot-unbound..)

(defsetf sys::%record-ref sys::%record-store)

(defun function-arglist (function)
  (if (sys::closurep function)
    (let ((h (sys::%record-ref function 1))) ; Lambdabody oder Codevektor
      (if (consp h)
        (car h) ; Lambdaliste
        nil ; unbekannt
    ) )
    nil ; unbekannt
) )

(defun function-pretty-arglist (function)
  (function-arglist function)
)

(defsetf function-pretty-arglist set-function-pretty-arglist)

(defun set-function-pretty-arglist (function new-value)
  (if (sys::closurep function)
    (let ((h (sys::%record-ref function 1))) ; Lambdabody oder Codevektor
      (if (consp h)
        (setf (car h) new-value) ; Lambdaliste ersetzen
    ) )
  )
  new-value
)

(defun set-function-name-1 (function new-name uninterned-name)
  (declare (ignore uninterned-name))
  (if (sys::closurep function)
    (setf (sys::%record-ref function 0) new-name)
  )
  function
)

(defconstant *compiler-present-p* (if (member 'COMPILER *features*) t nil))

(defvar *compiler-speed* :SLOW)

(defvar *compiler-reentrant-p* t) ; ??

(defun in-the-compiler-p () sys::*compiling*)

(defun compile-lambda-uncompiled (uncompiled)
  (eval `(function ,uncompiled))
)
============================