cgit.sxemacs.org Git - packages/blob - xemacs-packages/ilisp/cormanlisp.lisp

   1 ;;; -*- Mode: Lisp; tab-width: 4 -*-
   2 ;;; cormanlisp.lisp --
   3
   4 ;;; This file is part of ILISP.
   5 ;;; Version: 5.8 - 5.10
   6 ;;;
   7 ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell
   8 ;;;               1993, 1994 Ivan Vasquez
   9 ;;;               1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker
  10 ;;;               1996 Marco Antoniotti and Rick Campbell
  11 ;;;                           2000 Reini Urban
  12 ;;;
  13 ;;; Other authors' names for which this Copyright notice also holds
  14 ;;; may appear later in this file.
  15 ;;;
  16 ;;; ILISP is freely redistributable under the terms found in the file
  17 ;;; COPYING.
  18
  19 ;;;
  20 ;;; Cormanlisp initializations
  21 ;;; Author: Reini Urban <rurban@x-ray.at>
  22 ;;;
  23 (in-package "ILISP")
  24
  25 (defun ilisp-source-files (symbol package type)
  26   "Print each file for PACKAGE:SYMBOL's TYPE definition on a line and
  27 return T if successful."
  28   (declare (ignore type))
  29   (ilisp-errors
  30    (let* ((symbol (ilisp-find-symbol symbol package))
  31           (type t)
  32           ;;(type (if (equal type "any") t (ilisp-find-symbol type "keyword")))
  33           (paths (when symbol (debug::function-source-file symbol))))
  34      (if paths
  35          (progn
  36            (if (eq type t)
  37                (dolist (path (remove-duplicates paths
  38                                                 :key #'cdr :test #'equal))
  39                  (print (namestring (cdr path))))
  40                (print (namestring paths)))
  41            t)
  42          nil))))
  43
  44 (export '(ilisp-source-files))
  45
  46 ;;; ILISP Patches for cormanlisp <= 2.0
  47
  48 (in-package :common-lisp)
  49
  50 (defun inspect (symbol)
  51   (describe symbol))
  52
  53 ;; not really needed with my cl-ilisp.lisp patch, but for legacy sake
  54 (defun special-form-p (symbol)
  55   (special-operator-p symbol))
  56
  57 (unless (fboundp 'compile-file-pathname)
  58
  59 (defvar fasl-file-extension ".fasl")
  60 ;;;
  61 ;;; Common Lisp COMPILE-FILE-PATHNAME function.
  62 ;;;
  63 ;;; CLtL2: "If an implementation supports additional keyword arguments to
  64 ;;; compile-file, compile-file-pathname must accept the same arguments."
  65 ;;;
  66 (defun compile-file-pathname (input-file &key
  67                                          (output-file nil)
  68                                          (verbose *compile-verbose*)
  69                                          (print *compile-print*)
  70                                          (external-format :default))
  71   (create-pathname-from-string
  72    (compile-file-name  (namestring (pathname input-file))
  73                                           :output-file output-file
  74                                           :verbose     verbose
  75                                           :print       print
  76                                           :external-format external-format)))
  77
  78 (defun compile-file-name (input-file &key
  79                                                                          (output-file nil)
  80                                                                          (verbose *compile-verbose*)
  81                                                                          (print *compile-print*)
  82                                                                          (external-format :default))
  83   "Returns the compiled filename string for the input-file string"
  84   (declare (ignore verbose external-format print))
  85   (if (null output-file)
  86       (if (string-equal
  87            (subseq input-file
  88                    (- (length input-file)(length lisp-file-extension))
  89                    (length input-file))
  90            lisp-file-extension)
  91           (concatenate 'string
  92                        (subseq input-file
  93                                0
  94                                (- (length input-file)
  95                                                                   (length lisp-file-extension)))
  96                        fasl-file-extension)
  97         (concatenate 'string input-file fasl-file-extension))
  98      (namestring (pathname output-file))))
  99
 100 ) ; eof compile-file-pathname patch
 101
 102 (unless (fboundp 'readtable-case)
 103
 104 ;;;
 105 ;;; Common Lisp READTABLE-CASE accessor
 106 ;;;
 107 ;;; Note: at booting check-type,warn,defun setf are not defined
 108 ;;;
 109 (defun readtable-case (readtbl)
 110   (if (macro-function 'check-type)      ; booting
 111           (check-type readtbl readtable)
 112         ;; else
 113     (if (not (readtablep readtbl))
 114                 (error "Argument is no valid readtable: ~A" readtbl)))
 115   (uref readtbl readtable-case-offset))
 116
 117 (defun set-readtable-case (readtbl value)
 118   "For compatibility only. All values except :UPCASE are ignored."
 119   (let ((valid-case '(:upcase))
 120                 (ignored-case '(:downcase :preserve :invert)))
 121         (if (macro-function 'check-type)        ; booting
 122                 (progn
 123                   (check-type readtbl readtable)
 124                   (check-type value symbol)))
 125         (cond
 126          ((member value valid-case)
 127           (setf (uref readtbl readtable-case-offset) value))
 128          ((member value ignored-case)
 129           (error "SET-READTABLE-CASE: only :UPCASE supported: ~A"
 130                         value))
 131          (T
 132           (error "Argument is no valid readtable-case: ~A, expected ~A"
 133                          value valid-case)))))
 134
 135 ;;; bootstrapping
 136 (set-readtable-case *readtable* ':upcase)
 137 (set-readtable-case *common-lisp-readtable* ':upcase)
 138
 139 (defsetf readtable-case set-readtable-case)
 140
 141 )  ; eof readtable-case patch
 142
 143 (in-package :ilisp)