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 / utabs.scm < prev    next >
Text File  |  1999-01-02  |  8KB  |  224 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: utabs.scm,v 14.13 1999/01/02 06:19:10 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. ;;;; Microcode Name <-> Code Maps
  23. ;;; package: (runtime microcode-tables)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (re-read-microcode-tables!)
  28.   (let ((file-name ((ucode-primitive microcode-tables-filename))))
  29.     (if (file-exists? file-name)
  30.     (read-microcode-tables! file-name)
  31.     (let ((new-identification ((ucode-primitive microcode-identify))))
  32.       (let ((new-vector (vector-copy new-identification))
  33.         (old-vector (vector-copy identification-vector)))
  34.         (let loop ((fields '(CONSOLE-WIDTH CONSOLE-HEIGHT)))
  35.           (if (not (null? fields))
  36.           (let ((slot
  37.              (microcode-identification-vector-slot (car fields))))
  38.             (vector-set! old-vector slot false)
  39.             (vector-set! new-vector slot false)
  40.             (loop (cdr fields)))))
  41.         (if (not (equal? new-vector old-vector))
  42.         (error
  43.          "re-read-microcode-tables!: Missing microcode description"
  44.          file-name)
  45.         (begin
  46.           (set! identification-vector new-identification)
  47.           (set! microcode-id/tty-x-size
  48.             (microcode-identification-item 'CONSOLE-WIDTH))
  49.           (set! microcode-id/tty-y-size
  50.             (microcode-identification-item 'CONSOLE-HEIGHT))
  51.           unspecific)))))))
  52.  
  53. (define (read-microcode-tables! #!optional filename)
  54.   (set! microcode-tables-identification
  55.     (scode-eval ((ucode-primitive binary-fasload)
  56.              (if (default-object? filename)
  57.              ((ucode-primitive microcode-tables-filename))
  58.              filename))
  59.             system-global-environment))
  60.   (set! identification-vector ((ucode-primitive microcode-identify)))
  61.   (set! errors-slot (fixed-object/name->code 'MICROCODE-ERRORS-VECTOR))
  62.   (set! identifications-slot
  63.     (fixed-object/name->code 'MICROCODE-IDENTIFICATION-VECTOR))
  64.   (set! returns-slot (fixed-object/name->code 'MICROCODE-RETURNS-VECTOR))
  65.   (set! terminations-slot
  66.     (fixed-object/name->code 'MICROCODE-TERMINATIONS-VECTOR))
  67.   (set! types-slot (fixed-object/name->code 'MICROCODE-TYPES-VECTOR))
  68.   (set! non-object-slot (fixed-object/name->code 'NON-OBJECT))
  69.   (set! system-call-names-slot (fixed-object/name->code 'SYSTEM-CALL-NAMES))
  70.   (set! system-call-errors-slot (fixed-object/name->code 'SYSTEM-CALL-ERRORS))
  71.   (set! microcode-id/version
  72.     (microcode-identification-item 'MICROCODE-VERSION))
  73.   (set! microcode-id/modification
  74.     (microcode-identification-item 'MICROCODE-MODIFICATION))
  75.   (set! microcode-id/release-string
  76.     (microcode-identification-item 'SYSTEM-RELEASE-STRING))
  77.   (set! char:newline (microcode-identification-item 'NEWLINE-CHAR))
  78.   (set! microcode-id/floating-mantissa-bits
  79.     (microcode-identification-item 'FLONUM-MANTISSA-LENGTH))
  80.   (set! microcode-id/floating-epsilon
  81.     (microcode-identification-item 'FLONUM-EPSILON))
  82.   (let ((name (microcode-identification-item 'OS-NAME-STRING)))
  83.     (set! microcode-id/operating-system (intern name))
  84.     (set! microcode-id/operating-system-name name))
  85.   (set! microcode-id/operating-system-variant
  86.     (microcode-identification-item 'OS-VARIANT-STRING))
  87.   (set! microcode-id/stack-type
  88.     (let ((string (microcode-identification-item 'STACK-TYPE-STRING)))
  89.       (cond ((string? string) (intern string))
  90.         ((not string) 'STANDARD)
  91.         (else (error "illegal stack type" string)))))
  92.   (set! microcode-id/tty-x-size
  93.     (microcode-identification-item 'CONSOLE-WIDTH))
  94.   (set! microcode-id/tty-y-size
  95.     (microcode-identification-item 'CONSOLE-HEIGHT))
  96.   unspecific)
  97.  
  98. (define microcode-tables-identification)
  99. (define microcode-id/version)
  100. (define microcode-id/modification)
  101. (define microcode-id/release-string)
  102. (define char:newline)
  103. (define microcode-id/tty-x-size)
  104. (define microcode-id/tty-y-size)
  105. (define microcode-id/floating-mantissa-bits)
  106. (define microcode-id/floating-epsilon)
  107. (define microcode-id/operating-system)
  108. (define microcode-id/operating-system-name)
  109. (define microcode-id/operating-system-variant)
  110. (define microcode-id/stack-type)
  111.  
  112. (define-integrable fixed-objects-slot 15)
  113. (define non-object-slot)
  114.  
  115. (define (fixed-object/name->code name)
  116.   (microcode-table-search fixed-objects-slot name))
  117.  
  118. (define (fixed-object/code->name code)
  119.   (microcode-table-ref fixed-objects-slot code))
  120.  
  121. (define (fixed-object/code-limit)
  122.   (vector-length (vector-ref (get-fixed-objects-vector) fixed-objects-slot)))
  123.  
  124. (define (fixed-objects-vector-slot name)
  125.   (or (fixed-object/name->code name)
  126.       (error "FIXED-OBJECTS-VECTOR-SLOT: Unknown name" name)))
  127.  
  128. (define (fixed-objects-item name)
  129.   (vector-ref (get-fixed-objects-vector) (fixed-objects-vector-slot name)))
  130.  
  131. (define (microcode-object/unassigned)
  132.   (vector-ref (get-fixed-objects-vector) non-object-slot))
  133.  
  134. (define (microcode-table-search slot name)
  135.   (let ((vector (vector-ref (get-fixed-objects-vector) slot)))
  136.     (let ((end (vector-length vector)))
  137.       (define (loop i)
  138.     (and (not (= i end))
  139.          (let ((entry (vector-ref vector i)))
  140.            (if (if (pair? entry)
  141.                (memq name entry)
  142.                (eq? name entry))
  143.            i
  144.            (loop (1+ i))))))
  145.       (loop 0))))
  146.  
  147. (define (microcode-table-ref slot index)
  148.   (let ((vector (vector-ref (get-fixed-objects-vector) slot)))
  149.     (and (< index (vector-length vector))
  150.      (let ((entry (vector-ref vector index)))
  151.        (if (pair? entry)
  152.            (car entry)
  153.            entry)))))
  154.  
  155. (define returns-slot)
  156.  
  157. (define (microcode-return/name->code name)
  158.   (microcode-table-search returns-slot name))
  159.  
  160. (define (microcode-return/code->name code)
  161.   (microcode-table-ref returns-slot code))
  162.  
  163. (define (microcode-return/code-limit)
  164.   (vector-length (vector-ref (get-fixed-objects-vector) returns-slot)))
  165.  
  166. (define errors-slot)
  167.  
  168. (define (microcode-error/name->code name)
  169.   (microcode-table-search errors-slot name))
  170.  
  171. (define (microcode-error/code->name code)
  172.   (microcode-table-ref errors-slot code))
  173.  
  174. (define (microcode-error/code-limit)
  175.   (vector-length (vector-ref (get-fixed-objects-vector) errors-slot)))
  176.  
  177. (define terminations-slot)
  178.  
  179. (define (microcode-termination/name->code name)
  180.   (microcode-table-search terminations-slot name))
  181.  
  182. (define (microcode-termination/code->name code)
  183.   (microcode-table-ref terminations-slot code))
  184.  
  185. (define (microcode-termination/code-limit)
  186.   (vector-length (vector-ref (get-fixed-objects-vector) terminations-slot)))
  187.  
  188. (define types-slot)
  189.  
  190. (define (microcode-type/name->code name)
  191.   (microcode-table-search types-slot name))
  192.  
  193. (define (microcode-type/code->name code)
  194.   (microcode-table-ref types-slot code))
  195.  
  196. (define (microcode-type/code-limit)
  197.   (vector-length (vector-ref (get-fixed-objects-vector) types-slot)))
  198.  
  199. (define identifications-slot)
  200. (define identification-vector)
  201.  
  202. (define (microcode-identification-vector-slot name)
  203.   (or (microcode-table-search identifications-slot name)
  204.       (error "Unknown microcode identification item" name)))
  205.  
  206. (define (microcode-identification-item name)
  207.   (vector-ref identification-vector
  208.           (microcode-identification-vector-slot name)))
  209.  
  210. (define system-call-names-slot)
  211.  
  212. (define (microcode-system-call/name->code name)
  213.   (microcode-table-search system-call-names-slot name))
  214.  
  215. (define (microcode-system-call/code->name code)
  216.   (microcode-table-ref system-call-names-slot code))
  217.  
  218. (define system-call-errors-slot)
  219.  
  220. (define (microcode-system-call-error/name->code name)
  221.   (microcode-table-search system-call-errors-slot name))
  222.  
  223. (define (microcode-system-call-error/code->name code)
  224.   (microcode-table-ref system-call-errors-slot code))