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 / scode.scm < prev    next >
Text File  |  1999-01-02  |  8KB  |  287 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: scode.scm,v 14.16 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. ;;;; SCode Abstraction
  23. ;;; package: (runtime scode)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (initialize-package!)
  28.   (set! scode-constant/type-vector (make-scode-constant/type-vector))
  29.   unspecific)
  30.  
  31. ;;;; Constant
  32.  
  33. (define scode-constant/type-vector)
  34.  
  35. (define (scode-constant? object)
  36.   (if (vector-ref scode-constant/type-vector (object-type object))
  37.       true
  38.       (and (compiled-code-address? object)
  39.        (not (eq? (compiled-entry-type object) 'COMPILED-EXPRESSION)))))
  40.  
  41. (define (make-scode-constant/type-vector)
  42.   (let ((type-vector (make-vector (microcode-type/code-limit) false)))
  43.     (for-each (lambda (name)
  44.         (vector-set! type-vector (microcode-type name) true))
  45.           '(BIGNUM
  46.         CHARACTER
  47.         COMPILED-CODE-BLOCK
  48.         CONTROL-POINT
  49.         DELAYED
  50.         ENTITY
  51.         ENVIRONMENT
  52.         EXTENDED-PROCEDURE
  53.         FLONUM
  54.         HUNK3-A
  55.         INTERNED-SYMBOL
  56.         NEGATIVE-FIXNUM
  57.         NON-MARKED-VECTOR
  58.         NULL
  59.         PAIR
  60.         POSITIVE-FIXNUM
  61.         PRIMITIVE
  62.         PROCEDURE
  63.         QUAD
  64.         RATNUM
  65.         RECNUM
  66.         REFERENCE-TRAP
  67.         RETURN-CODE
  68.         STRING
  69.         TRIPLE
  70.         TRUE
  71.         UNINTERNED-SYMBOL
  72.         VECTOR
  73.         VECTOR-16B
  74.         VECTOR-1B))
  75.     type-vector))
  76.  
  77. ;;;; Quotation
  78.  
  79. (define-integrable (make-quotation expression)
  80.   (&typed-singleton-cons (ucode-type quotation) expression))
  81.  
  82. (define-integrable (quotation? object)
  83.   (object-type? (ucode-type quotation) object))
  84.  
  85. (define-integrable (quotation-expression quotation)
  86.   (&singleton-element quotation))
  87.  
  88. ;;;; Variable
  89.  
  90. (define-integrable (make-variable name)
  91.   (system-hunk3-cons (ucode-type variable) name true '()))
  92.  
  93. (define-integrable (variable? object)
  94.   (object-type? (ucode-type variable) object))
  95.  
  96. (define-integrable (variable-name variable)
  97.   (system-hunk3-cxr0 variable))
  98.  
  99. (define-integrable (variable-components variable receiver)
  100.   (receiver (variable-name variable)))
  101.  
  102. ;;;; Definition/Assignment
  103.  
  104. (define (make-definition name #!optional value)
  105.   (&typed-pair-cons (ucode-type definition)
  106.             name
  107.             (if (default-object? value)
  108.             (make-unassigned-reference-trap)
  109.             value)))
  110.  
  111. (define-integrable (definition? object)
  112.   (object-type? (ucode-type definition) object))
  113.  
  114. (define-integrable (definition-name definition)
  115.   (system-pair-car definition))
  116.  
  117. (define-integrable (definition-value definition)
  118.   (&pair-cdr definition))
  119.  
  120. (define (definition-components definition receiver)
  121.   (receiver (definition-name definition)
  122.         (definition-value definition)))
  123.  
  124. (define-integrable (assignment? object)
  125.   (object-type? (ucode-type assignment) object))
  126.  
  127. (define (make-assignment-from-variable variable #!optional value)
  128.   (&typed-pair-cons (ucode-type assignment)
  129.             variable
  130.             (if (default-object? value)
  131.             (make-unassigned-reference-trap)
  132.             value)))
  133.  
  134. (define-integrable (assignment-variable assignment)
  135.   (system-pair-car assignment))
  136.  
  137. (define-integrable (assignment-value assignment)
  138.   (&pair-cdr assignment))
  139.  
  140. (define (assignment-components-with-variable assignment receiver)
  141.   (receiver (assignment-variable assignment)
  142.         (assignment-value assignment)))
  143.  
  144. (define (make-assignment name #!optional value)
  145.   (make-assignment-from-variable (make-variable name)
  146.                  (if (default-object? value)
  147.                      (make-unassigned-reference-trap)
  148.                      value)))
  149.  
  150. (define-integrable (assignment-name assignment)
  151.   (variable-name (assignment-variable assignment)))
  152.  
  153. (define (assignment-components assignment receiver)
  154.   (receiver (assignment-name assignment)
  155.         (assignment-value assignment)))
  156.  
  157. ;;;; Comment
  158.  
  159. (define-integrable (make-comment text expression)
  160.   (&typed-pair-cons (ucode-type comment) expression text))
  161.  
  162. (define-integrable (comment? object)
  163.   (object-type? (ucode-type comment) object))
  164.  
  165. (define-integrable (comment-text comment)
  166.   (system-pair-cdr comment))
  167.  
  168. (define-integrable (set-comment-text! comment text)
  169.   (system-pair-set-cdr! comment text))
  170.  
  171. (define-integrable (comment-expression comment)
  172.   (&pair-car comment))
  173.  
  174. (define-integrable (set-comment-expression! comment expression)
  175.   (&pair-set-car! comment expression))
  176.  
  177. (define (comment-components comment receiver)
  178.   (receiver (comment-text comment)
  179.         (comment-expression comment)))
  180.  
  181. ;;;; Declaration
  182.  
  183. (define-integrable (make-declaration text expression)
  184.   (make-comment (cons declaration-tag text) expression))
  185.  
  186. (define (declaration? object)
  187.   (and (comment? object)
  188.        (let ((text (comment-text object)))
  189.      (and (pair? text)
  190.           (eq? (car text) declaration-tag)))))
  191.  
  192. (define-integrable declaration-tag
  193.   ((ucode-primitive string->symbol) "#[declaration]"))
  194.  
  195. (define-integrable (declaration-text declaration)
  196.   (cdr (comment-text declaration)))
  197.  
  198. (define-integrable (set-declaration-text! declaration text)
  199.   (set-cdr! (comment-text declaration) text))
  200.  
  201. (define-integrable (declaration-expression declaration)
  202.   (comment-expression declaration))
  203.  
  204. (define-integrable (set-declaration-expression! declaration expression)
  205.   (set-comment-expression! declaration expression))
  206.  
  207. (define (declaration-components declaration receiver)
  208.   (receiver (declaration-text declaration)
  209.         (declaration-expression declaration)))
  210.  
  211. ;;;; The-Environment
  212.  
  213. (define-integrable (make-the-environment)
  214.   (object-new-type (ucode-type the-environment) 0))
  215.  
  216. (define-integrable (the-environment? object)
  217.   (object-type? (ucode-type the-environment) object))
  218.  
  219. ;;;; Access
  220.  
  221. (define-integrable (make-access environment name)
  222.   (&typed-pair-cons (ucode-type access) environment name))
  223.  
  224. (define-integrable (access? object)
  225.   (object-type? (ucode-type access) object))
  226.  
  227. (define (access-environment expression)
  228.   (&pair-car expression))
  229.  
  230. (define-integrable (access-name expression)
  231.   (system-pair-cdr expression))
  232.  
  233. (define (access-components expression receiver)
  234.   (receiver (access-environment expression)
  235.         (access-name expression)))
  236.  
  237. ;;;; Absolute Reference
  238.  
  239. (define (make-absolute-reference name . rest)
  240.   (let loop ((reference (make-access system-global-environment name))
  241.          (rest rest))
  242.     (if (null? rest)
  243.     reference
  244.     (loop (make-access reference (car rest)) (cdr rest)))))
  245.  
  246. (define (absolute-reference? object)
  247.   (and (access? object)
  248.        (system-global-environment? (access-environment object))))
  249.  
  250. (define-integrable (absolute-reference-name reference)
  251.   (access-name reference))
  252.  
  253. (define (absolute-reference-to? object name)
  254.   (and (absolute-reference? object)
  255.        (eq? (absolute-reference-name object) name)))
  256.  
  257. ;;;; In-Package
  258.  
  259. (define-integrable (make-in-package environment expression)
  260.   (&typed-pair-cons (ucode-type in-package) environment expression))
  261.  
  262. (define-integrable (in-package? object)
  263.   (object-type? (ucode-type in-package) object))
  264.  
  265. (define-integrable (in-package-environment expression)
  266.   (&pair-car expression))
  267.  
  268. (define-integrable (in-package-expression expression)
  269.   (&pair-cdr expression))
  270.  
  271. (define (in-package-components expression receiver)
  272.   (receiver (in-package-environment expression)
  273.         (in-package-expression expression)))
  274.  
  275. ;;;; Delay
  276.  
  277. (define-integrable (make-delay expression)
  278.   (&typed-singleton-cons (ucode-type delay) expression))
  279.  
  280. (define-integrable (delay? object)
  281.   (object-type? (ucode-type delay) object))
  282.  
  283. (define-integrable (delay-expression expression)
  284.   (&singleton-element expression))
  285.  
  286. (define-integrable (delay-components expression receiver)
  287.   (receiver (delay-expression expression)))