home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume10 / comobj.lisp / part01 / lucid-low.l < prev    next >
Encoding:
Text File  |  1987-07-30  |  3.6 KB  |  112 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 Lucid lisp version of the file portable-low.
  27. ;;;
  28. ;;; Lucid:               (415)329-8400
  29. ;;; Sun:     Steve Gadol (415)960-1300
  30. ;;; 
  31.  
  32. (in-package 'pcl)
  33.  
  34.   ;;   
  35. ;;;;;; Memory Block primitives.
  36.   ;;   
  37.  
  38. (defmacro make-memory-block (size &optional area)
  39.   (ignore area)
  40.   `(make-array ,size))
  41.  
  42. ;;;
  43. ;;; Reimplementation OF %INSTANCE
  44. ;;;
  45. ;;; We take advantage of the fact that Lucid defstruct doesn't depend on
  46. ;;; the fact that Common Lisp defstructs are fixed length.  This allows us to
  47. ;;; use defstruct to define a new type, but use internal structure allocation
  48. ;;; code to make structure of that type of any length we like.
  49. ;;;
  50. ;;; In our %instance datatype, the array look like
  51. ;;;
  52. ;;;  structure type: The symbol %INSTANCE, this tells the system what kind
  53. ;;;                  of structure this is.
  54. ;;;  element 0:      The meta-class of this %INSTANCE
  55. ;;;  element 1:      This is used to store the value of %instance-ref slot 0.
  56. ;;;  element 2:      This is used to store the value of %instance-ref slot 1.
  57. ;;;     .                                .
  58. ;;;     .                                .
  59. ;;;
  60. (defstruct (%instance (:print-function print-instance)
  61.               (:constructor nil)
  62.               (:predicate %instancep))
  63.   meta-class)
  64.  
  65. (defmacro %make-instance (meta-class size)
  66.   (let ((instance-var (gensym)))
  67.     `(let ((,instance-var (lucid::new-structure (1+ ,size) '%instance)))
  68.        (setf (lucid::structure-ref ,instance-var 0 '%instance) ,meta-class)
  69.        ,instance-var)))
  70.  
  71. (defmacro %instance-ref (instance index)
  72.   `(lucid::structure-ref ,instance (1+ ,index) '%instance))
  73.  
  74.  
  75.   ;;   
  76. ;;;;;; Cache No's
  77.   ;;  
  78.  
  79. ;;; Grab the top 29 bits
  80. ;;;
  81. (lucid::defsubst symbol-cache-no (symbol mask)
  82.   (logand (lucid::%field symbol 3 29) mask))
  83.  
  84. ;;; Same here
  85. ;;;
  86. (lucid::defsubst object-cache-no (object mask)
  87.   (logand (lucid::%field object 3 29) mask))
  88.  
  89.   ;;   
  90. ;;;;;; printing-random-thing-internal
  91.   ;;
  92. (defun printing-random-thing-internal (thing stream)
  93.   (format stream "~O" (lucid::%pointer thing)))
  94.  
  95.  
  96. (in-package 'lucid)
  97.  
  98. (defun output-structure (struct currlevel)
  99.   (let ((type (structure-type struct)))
  100.     (multiple-value-bind (length struct-type constructor print-function)
  101.     (defstruct-info type)
  102.       (declare (ignore struct-type constructor))
  103.       (if (not *print-structure*)
  104.       (output-terse-object struct
  105.                    (if (streamp struct) "Stream" "Structure")
  106.                    type)
  107.       (funcall (if print-function
  108.                (symbol-function print-function)
  109.                #'default-structure-print)
  110.            struct *print-output* currlevel)))))
  111.  
  112.