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 / compiler / base / scode.scm < prev    next >
Text File  |  1999-01-02  |  6KB  |  160 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: scode.scm,v 4.10 1999/01/02 06:06:43 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 Interface
  23.  
  24. (declare (usual-integrations))
  25.  
  26. (let-syntax ((define-scode-operators
  27.            (macro names
  28.          `(BEGIN ,@(map (lambda (name)
  29.                   `(DEFINE ,(symbol-append 'SCODE/ name)
  30.                      (ACCESS ,name SYSTEM-GLOBAL-ENVIRONMENT)))
  31.                 names)))))
  32.   (define-scode-operators
  33.     make-access access? access-components
  34.     access-environment access-name
  35.     make-assignment assignment? assignment-components
  36.     assignment-name assignment-value
  37.     make-combination combination? combination-components
  38.     combination-operator combination-operands
  39.     make-comment comment? comment-components
  40.     comment-expression comment-text
  41.     make-conditional conditional? conditional-components
  42.     conditional-predicate conditional-consequent conditional-alternative
  43.     make-declaration declaration? declaration-components
  44.     declaration-expression declaration-text
  45.     make-definition definition? definition-components
  46.     definition-name definition-value
  47.     make-delay delay? delay-components
  48.     delay-expression
  49.     make-disjunction disjunction? disjunction-components
  50.     disjunction-predicate disjunction-alternative
  51.     make-in-package in-package? in-package-components
  52.     in-package-environment in-package-expression
  53.     make-lambda lambda? lambda-components
  54.     make-open-block open-block? open-block-components
  55.     primitive-procedure? procedure?
  56.     make-quotation quotation? quotation-expression
  57.     make-sequence sequence? sequence-actions sequence-components
  58.     symbol?
  59.     make-the-environment the-environment?
  60.     make-unassigned? unassigned?? unassigned?-name
  61.     make-variable variable? variable-components variable-name
  62.     ))
  63.  
  64. (define-integrable (scode/make-constant value) value)
  65. (define-integrable (scode/constant-value constant) constant)
  66. (define scode/constant? (access scode-constant? system-global-environment))
  67.  
  68. (define-integrable (scode/quotation-components quot recvr)
  69.   (recvr (scode/quotation-expression quot)))
  70.  
  71. (define comment-tag:directive
  72.   (intern "#[(compiler)comment-tag:directive]"))
  73.  
  74. (define (scode/make-directive code directive original-code)
  75.   (scode/make-comment
  76.    (list comment-tag:directive
  77.      directive
  78.      (scode/original-expression original-code))
  79.    code))
  80.  
  81. (define (scode/original-expression scode)
  82.   (if (and (scode/comment? scode)
  83.        (scode/comment-directive? (scode/comment-text scode)))
  84.       (caddr (scode/comment-text scode))
  85.       scode))
  86.  
  87. (define (scode/comment-directive? text . kinds)
  88.   (and (pair? text)
  89.        (eq? (car text) comment-tag:directive)
  90.        (or (null? kinds)
  91.        (memq (caadr text) kinds))))
  92.  
  93. (define (scode/make-let names values . body)
  94.   (scan-defines (scode/make-sequence body)
  95.     (lambda (auxiliary declarations body)
  96.       (scode/make-combination
  97.        (scode/make-lambda lambda-tag:let names '() false
  98.               auxiliary declarations body)
  99.        values))))
  100.  
  101. ;;;; Absolute variables and combinations
  102.  
  103. (define-integrable (scode/make-absolute-reference variable-name)
  104.   (scode/make-access '() variable-name))
  105.  
  106. (define (scode/absolute-reference? object)
  107.   (and (scode/access? object)
  108.        (null? (scode/access-environment object))))
  109.  
  110. (define-integrable (scode/absolute-reference-name reference)
  111.   (scode/access-name reference))
  112.  
  113. (define-integrable (scode/make-absolute-combination name operands)
  114.   (scode/make-combination (scode/make-absolute-reference name) operands))
  115.  
  116. (define (scode/absolute-combination? object)
  117.   (and (scode/combination? object)
  118.        (scode/absolute-reference? (scode/combination-operator object))))
  119.  
  120. (define-integrable (scode/absolute-combination-name combination)
  121.   (scode/absolute-reference-name (scode/combination-operator combination)))
  122.  
  123. (define-integrable (scode/absolute-combination-operands combination)
  124.   (scode/combination-operands combination))
  125.  
  126. (define (scode/absolute-combination-components combination receiver)
  127.   (receiver (scode/absolute-combination-name combination)
  128.         (scode/absolute-combination-operands combination)))
  129.  
  130. (define (scode/error-combination? object)
  131.   (or (and (scode/combination? object)
  132.        (eq? (scode/combination-operator object) error-procedure))
  133.       (and (scode/absolute-combination? object)
  134.        (eq? (scode/absolute-combination-name object) 'ERROR-PROCEDURE))))
  135.  
  136. (define (scode/error-combination-components combination receiver)
  137.   (scode/combination-components combination
  138.     (lambda (operator operands)
  139.       operator
  140.       (receiver
  141.        (car operands)
  142.        (let loop ((irritants (cadr operands)))
  143.      (cond ((null? irritants) '())
  144.            ((and (scode/absolute-combination? irritants)
  145.              (eq? (scode/absolute-combination-name irritants) 'LIST))
  146.         (scode/absolute-combination-operands irritants))
  147.            ((and (scode/combination? irritants)
  148.              (eq? (scode/combination-operator irritants) cons))
  149.         (let ((operands (scode/combination-operands irritants)))
  150.           (cons (car operands)
  151.             (loop (cadr operands)))))
  152.            (else
  153.         (cadr operands))))))))
  154.  
  155. (define (scode/make-error-combination message operand)
  156.   (scode/make-absolute-combination
  157.    'ERROR-PROCEDURE
  158.    (list message
  159.      (scode/make-combination cons (list operand '()))
  160.      (scode/make-the-environment))))