1. xemacs
  2. ilisp

Source

ilisp / cl-ilisp.lisp

Diff from to

File cl-ilisp.lisp

 ;;; -*- Mode: Lisp -*-
 
 ;;; cl-ilisp.lisp --
-
-;;; This file is part of ILISP.
-;;; Version: 5.10.1
-;;;
-;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell
-;;;               1993, 1994 Ivan Vasquez
-;;;               1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker
-;;;               1996-2000 Marco Antoniotti and Rick Campbell
-;;;
-;;; Other authors' names for which this Copyright notice also holds
-;;; may appear later in this file.
-;;;
-;;; Send mail to 'majordomo@cons.org' to be included in the
-;;; ILISP mailing list. 'ilisp@cons.org' is the general ILISP
-;;; mailing list were bugs and improvements are discussed.
-;;;
-;;; ILISP is freely redistributable under the terms found in the file
-;;; COPYING.
-
-
-
 ;;; Common Lisp initializations
 ;;; Author: Chris McConnell, ccm@cs.cmu.edu
+;;;
+;;; This file is part of ILISP.
+;;; Please refer to the file COPYING for copyrights and licensing
+;;; information.
+;;; Please refer to the file ACKNOWLEGDEMENTS for an (incomplete) list
+;;; of present and past contributors.
+;;;
+;;; $Id$
 
+
+;;; Old history log.
 ;;;
 ;;; ange-ftp hack added by ivan Wed Mar 10 12:30:15 1993
 ;;; ilisp-errors *gc-verbose* addition ivan Tue Mar 16 03:21:51 1993
 
 (defvar *ilisp-message-addon-string* "ILISP:")
 
+(defmacro the-symbol-if-defined ((if-symbol
+                                  if-package
+                                  &optional else-symbol else-package)
+                                 &body body)
+  (let* ((sym-if (and (find-package if-package)
+                      (find-symbol (symbol-name if-symbol)
+                                   (find-package if-package))))
+          (sym-else
+           (unless sym-if
+             (and else-symbol
+                  (find-package else-package)
+                  (find-symbol (symbol-name else-symbol)
+                               (find-package else-package))))))
+    (if (consp (first body))
+      `(let ((the-symbol ,(or sym-if sym-else)))
+        ,@body)
+      `',(or sym-if  sym-else))))
+                   
+(defmacro the-function-if-defined ((if-function
+                                    if-package
+                                    &optional else-function else-package)
+                                   &body body)
+  (let* ((fun-if
+           (ignore-errors
+             (find-symbol (symbol-name if-function)
+                          (find-package if-package))))
+         (fun-else
+           (unless fun-if
+             (ignore-errors
+               (and else-function
+                    (find-symbol (symbol-name else-function)
+                                 (find-package else-package)))))))
+    (when (or fun-if fun-else)
+      (if (and (consp body) (not (consp (first body))))
+        `(,(or fun-if fun-else) ,@body)
+        `(let ((the-function (symbol-function ',(or fun-if fun-else))))
+          ,@body)))))
+      
+
 ;;; Martin Atzmueller 2000-01-15
 ;;; ilisp-message was mostly set up because Clisp expects an
 ;;; ~& or ~% before the message-string, otherwise it does not display anything!"
   ;; Marco Antoniotti: Jan 2 1995.
   #-lucid
   (ilisp-eval
-   (format nil "(funcall (compile nil '(lisp:lambda () ~A)))"
+   (format nil "(funcall (compile nil '(lambda () ~A)))"
 	   form)
    package
    filename)
-  
-  ;; The following piece of conditional code is left in the
-  ;; distribution just for historical purposes.
-  ;; It will disappear in the next release.
-  ;; Marco Antoniotti: Jan 2 1995.
-  #+lucid-ilisp-5.6
-  (labels ((compiler (form env)
-		     (if (and (consp form)
-			      (eq (first form) 'function)
-			      (consp (second form)))
-			 #-LCL3.0
-		       (evalhook `(compile nil ,form) nil nil env)
-		       #+LCL3.0
-		       ;; If we have just compiled a named-lambda, and the
-		       ;; name didn't make it in to the procedure object,
-		       ;; then stuff the appropriate symbol in to the
-		       ;; procedure object.
-		       (let* ((proc (evalhook `(compile nil ,form)
-					      nil nil env))
-			      (old-name (and proc (sys:procedure-ref proc 1)))
-			      (lambda (second form))
-			      (name (and (eq (first lambda)
-					     'lucid::named-lambda)
-					 (second lambda))))
-			 (when (or (null old-name)
-				   (and (listp old-name)
-					(eq :internal (car old-name))))
-			       (setf (sys:procedure-ref proc 1) name))
-			 proc)
-		       (evalhook form #'compiler nil env))))
-	  (let ((*evalhook* #'compiler))
-	    (ilisp-eval form package filename)))
   #+lucid
   ;; Following form is a patch provided by Christopher Hoover
   ;; <ch@lks.csi.com>
     (terpri)
     (values)))
 
-#| Original version
-(defun print-function-arglist (fn)
-  "Pretty arglist printer"
-  (let* ((a (get-function-arglist fn))
- 	 (arglist (ldiff a (member '&aux a))))
-	 (desc (ilisp-function-short-description fn)))
-    (break "sun la")
-    (format t "~&~s~a" fn (or desc ""))
-    (write-string ": ")
-    (if arglist
-	(write arglist :case :downcase :escape nil)
-      (write-string "()"))
-    (terpri)
-    (values)))
-|#
-
-
-
 (defun ilisp-generic-function-p (symbol)
   (let ((generic-p
 	 (find-symbol "GENERIC-FUNCTION-P"
 	   #+:sbcl
 	   (arglist symbol (symbol-package symbol))
 	   
-	   #-(or allegro lucid kcl ibcl ecl clisp cmu :sbcl)
+	   #-(or allegro lucid kcl ibcl ecl gcl lispworks clisp cmu :sbcl)
 	   (documentation symbol 'function)))))
 
 
 	 (*print-length* nil)
 	 (*print-level* nil)
 	 (*package* (ilisp-find-package package)))
-     ;; (break "Cheking ILISP-PRINT-INFO-MESSAGE")
      (cond ((null real-symbol)
 	    (format t "")
 	    ;; (ilisp-message t "symbol ~S not present in ~S." symbol package)
 
 (eval-when (load eval)
   (when
-      #+(and :CMU :CMU17)
+      #+(and :CMU (or :CMU17 :CMU18))
       (eval:interpreted-function-p #'ilisp-matching-symbols)
-      #-(and :CMU :CMU17)
+      #-(and :CMU (or :CMU17 :CMU18))
       (not (compiled-function-p #'ilisp-matching-symbols))
       (ilisp-message *standard-output*
 		     "File is not compiled, use M-x ilisp-compile-inits")))