home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / pcl-src.zoo / clisp-low.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1992-09-13  |  2.9 KB  |  97 lines
  1. ;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;;
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;;
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27. ;;; The version of low for CLISP.
  28.  
  29. (in-package 'pcl)
  30.  
  31. (defun printing-random-thing-internal (thing stream)
  32.   (format stream "#x~8,'0X" (sys::address-of thing))
  33. )
  34.  
  35. (defconstant *slot-unbound* '..slot-unbound..)
  36.  
  37. (defsetf sys::%record-ref sys::%record-store)
  38.  
  39. (defun function-arglist (function)
  40.   (if (sys::closurep function)
  41.     (let ((h (sys::%record-ref function 1))) ; lambdabody or code-vector
  42.       (if (consp h)
  43.         (car h) ; lambda list
  44.         nil ; unknown
  45.     ) )
  46.     nil ; unknown
  47. ) )
  48.  
  49. (defun function-pretty-arglist (function)
  50.   (function-arglist function)
  51. )
  52.  
  53. (defsetf function-pretty-arglist set-function-pretty-arglist)
  54.  
  55. (defun set-function-pretty-arglist (function new-value)
  56.   (if (sys::closurep function)
  57.     (let ((h (sys::%record-ref function 1))) ; lambdabody or code-vector
  58.       (if (consp h)
  59.         (setf (car h) new-value) ; replace lambda list
  60.     ) )
  61.   )
  62.   new-value
  63. )
  64.  
  65. (defun set-function-name-1 (function new-name uninterned-name)
  66.   (declare (ignore uninterned-name))
  67.   (if (sys::closurep function)
  68.     (setf (sys::%record-ref function 0) new-name)
  69.   )
  70.   function
  71. )
  72.  
  73. (defconstant *compiler-present-p* (if (member 'COMPILER *features*) t nil))
  74.  
  75. (defvar *compiler-speed* :SLOW)
  76.  
  77. (defvar *compiler-reentrant-p* t)
  78.  
  79. (defun in-the-compiler-p () sys::*compiling*)
  80.  
  81. (defun compile-lambda-uncompiled (uncompiled)
  82.   (eval `(function ,uncompiled))
  83. )
  84.  
  85. (defmacro define-compiler-macro (name lambdalist &body body)
  86.   (let ((handler (gensym))
  87.         (dummyname (gensym)))
  88.     `(EVAL-WHEN (COMPILE)
  89.        (DEFMACRO ,dummyname ,lambdalist ,@body)
  90.        (DEFUN ,handler ()
  91.          (COMPILER::C-FORM (CONS ',dummyname (CDR COMPILER::*FORM*)))
  92.        )
  93.        (SETF (GETHASH ',name COMPILER::C-FORM-TABLE) ',handler)
  94.      )
  95. ) )
  96.  
  97.