home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / boot.scm < prev    next >
Text File  |  1999-01-02  |  4KB  |  121 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: boot.scm,v 14.12 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1988-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Boot Time Definitions
  23. ;;; package: ()
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define standard-unparser-method)
  28. (define unparser/standard-method)
  29. (let ((make-method
  30.        (lambda (name unparser)
  31.      (lambda (state object)
  32.        (let ((port (unparser-state/port state))
  33.          (hash-string (number->string (hash object))))
  34.          (if *unparse-with-maximum-readability?*
  35.          (begin
  36.            (write-string "#@" port)
  37.            (write-string hash-string port))
  38.          (begin
  39.            (write-string "#[" port)
  40.            (if (string? name)
  41.                (write-string name port)
  42.                (with-current-unparser-state state
  43.              (lambda (port)
  44.                (write name port))))
  45.            (write-char #\space port)
  46.            (write-string hash-string port)
  47.            (if unparser (unparser state object))
  48.            (write-char #\] port))))))))
  49.   (set! standard-unparser-method
  50.     (lambda (name unparser)
  51.       (make-method name
  52.                (and unparser
  53.                 (lambda (state object)
  54.                   (with-current-unparser-state state
  55.                 (lambda (port)
  56.                   (unparser object port))))))))
  57.   (set! unparser/standard-method
  58.     (lambda (name #!optional unparser)
  59.       (make-method name
  60.                (and (not (default-object? unparser))
  61.                 unparser
  62.                 (lambda (state object)
  63.                   (unparse-char state #\space)
  64.                   (unparser state object)))))))
  65.  
  66. (define (unparser-method? object)
  67.   (and (procedure? object)
  68.        (procedure-arity-valid? object 2)))
  69.  
  70. (define-integrable interrupt-bit/stack     #x0001)
  71. (define-integrable interrupt-bit/global-gc #x0002)
  72. (define-integrable interrupt-bit/gc        #x0004)
  73. (define-integrable interrupt-bit/global-1  #x0008)
  74. (define-integrable interrupt-bit/kbd       #x0010)
  75. (define-integrable interrupt-bit/after-gc  #x0020)
  76. (define-integrable interrupt-bit/timer     #x0040)
  77. (define-integrable interrupt-bit/global-3  #x0080)
  78. (define-integrable interrupt-bit/suspend   #x0100)
  79. ;; Interrupt bits #x0200 through #x4000 inclusive are reserved
  80. ;; for the Descartes PC sampler.
  81.  
  82. ;; GC & stack overflow only
  83. (define-integrable interrupt-mask/gc-ok    #x0007)
  84.  
  85. ;; GC, stack overflow, and keyboard only
  86. (define-integrable interrupt-mask/no-background #x0017)
  87.  
  88. ;; GC, stack overflow, and timer only
  89. (define-integrable interrupt-mask/timer-ok #x0047)
  90.  
  91. ;; Absolutely everything off
  92. (define-integrable interrupt-mask/none     #x0000)
  93.  
  94. ;; Normal: all enabled
  95. (define-integrable interrupt-mask/all      #xFFFF)
  96.  
  97. (define (with-absolutely-no-interrupts thunk)
  98.   (with-interrupt-mask interrupt-mask/none
  99.     (lambda (interrupt-mask)
  100.       interrupt-mask
  101.       (thunk))))
  102.  
  103. (define (without-interrupts thunk)
  104.   (with-interrupt-mask interrupt-mask/gc-ok
  105.     (lambda (interrupt-mask)
  106.       interrupt-mask
  107.       (thunk))))
  108.  
  109. (define (without-background-interrupts thunk)
  110.   (with-interrupt-mask interrupt-mask/no-background
  111.     (lambda (interrupt-mask)
  112.       interrupt-mask
  113.       (thunk))))
  114.  
  115. (define-primitives
  116.   (object-pure? pure?)
  117.   (object-constant? constant?)
  118.   get-next-constant)
  119.  
  120. (define-integrable (future? object)
  121.   ((ucode-primitive object-type? 2) (ucode-type future) object))