home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume10 / comobj.lisp / part01 / excl-low.l < prev    next >
Encoding:
Text File  |  1987-07-30  |  3.8 KB  |  107 lines
  1. ;;; -*- Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
  5. ;;;
  6. ;;; Use and copying of this software and preparation of derivative works
  7. ;;; based upon this software are permitted.  Any distribution of this
  8. ;;; software or derivative works must comply with all applicable United
  9. ;;; States export control laws.
  10. ;;; 
  11. ;;; This software is made available AS IS, and Xerox Corporation makes no
  12. ;;; warranty about the software, its performance or its conformity to any
  13. ;;; specification.
  14. ;;; 
  15. ;;; Any person obtaining a copy of this software is requested to send their
  16. ;;; name and post office or electronic mail address to:
  17. ;;;   CommonLoops Coordinator
  18. ;;;   Xerox Artifical Intelligence Systems
  19. ;;;   2400 Hanover St.
  20. ;;;   Palo Alto, CA 94303
  21. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  22. ;;;
  23. ;;; Suggestions, comments and requests for improvements are also welcome.
  24. ;;; *************************************************************************
  25. ;;; 
  26. ;;; This is the EXCL (Franz) lisp version of the file portable-low.
  27. ;;; 
  28. ;;; This is for version 1.1.2.  Many of the special symbols now in the lisp
  29. ;;; package (e.g. lisp::pointer-to-fixnum) will be in some other package in
  30. ;;; a later release so this will need to be changed.
  31. ;;; 
  32.  
  33. (in-package 'pcl)
  34.  
  35. (eval-when (load)
  36.   (setq *class-of*
  37.     '(lambda (x) 
  38.        (or (and (%instancep x)
  39.             (%instance-class-of x))           
  40.           ;(%funcallable-instance-p x)
  41.            (and (stringp x) (class-named 'string))
  42.            (class-named (type-of x) t))))
  43.   )
  44.  
  45. (defmacro load-time-eval (form)
  46.   (cond ((and sys:*macroexpand-for-compiler* sys:*compile-to-core*)
  47.      `',(eval form))
  48.     ((and sys:*macroexpand-for-compiler* sys:*compile-to-file*)
  49.     ;(cerror "go ahead" "called load-time-eval in compile-to-file")
  50.      `'(,compiler::*eval-when-load-marker* . ,form))
  51.     (t
  52.      `(progn ,form))))
  53.  
  54. (eval-when (compile load eval)
  55.   (unless (fboundp 'excl::sy_hash)
  56.     (setf (symbol-function 'excl::sy_hash)
  57.       (symbol-function 'excl::_sy_hash-value))))
  58.  
  59. (defmacro symbol-cache-no (symbol mask)
  60.   (if (and (constantp symbol)
  61.        (constantp mask))
  62.       `(load-time-eval (logand (ash (excl::sy_hash ',symbol) -1) ,mask))
  63.       `(logand (ash (the fixnum (excl::pointer-to-fixnum ,symbol)) -1)
  64.            (the fixnum ,mask))))
  65.  
  66. (defmacro object-cache-no (object mask)
  67.   `(logand (the fixnum (excl::pointer-to-fixnum ,object))
  68.        (the fixnum ,mask)))
  69.  
  70. (defun printing-random-thing-internal (thing stream)
  71.   (format stream "~O" (excl::pointer-to-fixnum thing)))
  72.  
  73.  
  74. (defun function-arglist (f)
  75.   (excl::arglist f))
  76.  
  77.  
  78. (defun symbol-append (sym1 sym2 &optional (package *package*))
  79.    ;; This is a version of symbol-append from macros.cl
  80.    ;; It insures that all created symbols are of one case and that
  81.    ;; case is the current prefered case.
  82.    ;; This special version of symbol-append is not necessary if all you
  83.    ;; want to do is compile and run pcl in a case-insensitive-upper 
  84.    ;; version of cl.  
  85.    ;;
  86.    (let ((string (string-append sym1 sym2)))
  87.       (case excl::*current-case-mode*
  88.      ((:case-insensitive-lower :case-sensitive-lower)
  89.       (setq string (string-downcase string)))
  90.      ((:case-insensitive-upper :case-sensitive-upper)
  91.       (setq string (string-upcase string))))
  92.       (intern string package)))
  93.  
  94. ;(eval-when (compile load eval)
  95. ;  (let ((consts 
  96. ;      (sys:memref (symbol-function 'compiler::pa-macrolet)
  97. ;              (compiler::mdparam 'compiler::md-function-constant-adj)
  98. ;              0
  99. ;              :lisp)))
  100. ;    (dotimes (i (length consts))
  101. ;      (cond ((eq 'compiler::macro (svref consts i))
  102. ;         (setf (svref consts i) 'excl::macro)
  103. ;         (format t "fixed in slot ~s~%" i))
  104. ;        ((eq 'excl::macro (svref consts i))
  105. ;         (format t "already fixed in slot ~s~%" i))))))
  106.  
  107.