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 / back / syntax.scm < prev   
Encoding:
Text File  |  1999-01-02  |  6.7 KB  |  223 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: syntax.scm,v 1.27 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. ;;;; LAP Syntaxer
  23. ;;; package: (compiler lap-syntaxer)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define-integrable cons-syntax cons)
  28. (define-integrable append-syntax! append!)
  29.  
  30. #|
  31. (define (cons-syntax directive directives)
  32.   (if (and (bit-string? directive)
  33.        (not (null? directives))
  34.        (bit-string? (car directives)))
  35.       (begin (set-car! directives
  36.                (instruction-append directive (car directives)))
  37.          directives)
  38.       (cons directive directives)))
  39.  
  40. (define (append-syntax! directives1 directives2)
  41.   (cond ((null? directives1) directives2)
  42.     ((null? directives2) directives1)
  43.     (else
  44.      (let ((tail (last-pair directives1)))
  45.        (if (and (bit-string? (car tail))
  46.             (bit-string? (car directives2)))
  47.            (begin
  48.          (set-car! tail
  49.                (instruction-append (car tail) (car directives2)))
  50.          (set-cdr! tail (cdr directives2)))
  51.            (set-cdr! tail directives2))
  52.        directives1))))
  53. |#
  54.  
  55. (define (lap:syntax-instruction instruction)
  56.   (if (memq (car instruction)
  57.         '(EQUATE SCHEME-OBJECT SCHEME-EVALUATION
  58.              ENTRY-POINT LABEL BLOCK-OFFSET
  59.              PADDING))
  60.       (list instruction)
  61.       (let ((match-result (instruction-lookup instruction)))
  62.     (if (not match-result)
  63.         (error "illegal instruction syntax" instruction))
  64.     (match-result))))
  65.  
  66. (define (instruction-lookup instruction)
  67.   (pattern-lookup
  68.    (cdr (or (assq (car instruction) instructions)
  69.         (error "INSTRUCTION-LOOKUP: Unknown keyword" (car instruction))))
  70.    (cdr instruction)))
  71.  
  72. (define (add-instruction! keyword lookup)
  73.   (let ((entry (assq keyword instructions)))
  74.     (if entry
  75.     (set-cdr! entry lookup)
  76.     (set! instructions (cons (cons keyword lookup) instructions))))
  77.   keyword)
  78.  
  79. (define instructions
  80.   '())
  81.  
  82. (define (integer-syntaxer expression coercion-type size)
  83.   (let ((name (make-coercion-name coercion-type size)))
  84.     (if (exact-integer? expression)
  85.     `',((lookup-coercion name) expression)
  86.     `(SYNTAX-EVALUATION ,expression ,name))))
  87.  
  88. (define (syntax-evaluation expression coercion)
  89.   (if (exact-integer? expression)
  90.       (coercion expression)
  91.       `(EVALUATION ,expression ,(coercion-size coercion) ,coercion)))
  92.  
  93. (define (optimize-group . components)
  94.   (optimize-group-internal components
  95.     (lambda (result make-group?)
  96.       (if make-group?
  97.       `(GROUP ,@result)
  98.       result))))
  99.  
  100. (define-integrable optimize-group-early
  101.   optimize-group)
  102.  
  103. (define optimize-group-internal
  104.   (let ()
  105.     (define (loop1 components)
  106.       (cond ((null? components) '())
  107.         ((bit-string? (car components))
  108.          (loop2 (car components) (cdr components)))
  109.         (else
  110.          (cons (car components)
  111.            (loop1 (cdr components))))))
  112.  
  113.     (define (loop2 bit-string components)
  114.       (cond ((null? components)
  115.          (list bit-string))
  116.         ((bit-string? (car components))
  117.          (loop2 (instruction-append bit-string (car components))
  118.             (cdr components)))
  119.         (else
  120.          (cons bit-string
  121.            (cons (car components)
  122.              (loop1 (cdr components)))))))
  123.  
  124.     (lambda (components receiver)
  125.       (let ((components (loop1 components)))
  126.     (if (null? components)
  127.         (error "OPTIMIZE-GROUP: No components"))
  128.     (if (null? (cdr components))
  129.         (receiver (car components) false)
  130.         (receiver components true))))))
  131.  
  132. ;;;; Variable width expression processing
  133.  
  134. (define (choose-clause value clauses)
  135.   (if (null? clauses)
  136.       (error "CHOOSE-CLAUSE: value out of range" value))
  137.   (if (let ((low (caddr (car clauses)))
  138.         (high (cadddr (car clauses))))
  139.     (and (or (null? low)
  140.          (<= low value))
  141.          (or (null? high)
  142.          (<= value high))))
  143.       (car clauses)
  144.       (choose-clause value (cdr clauses))))
  145.  
  146. (define (variable-width-expression-syntaxer name expression clauses)
  147.   (if (exact-integer? expression)
  148.       (let ((chosen (choose-clause expression clauses)))
  149.     `(LET ((,name ,expression))
  150.        (DECLARE (INTEGRATE ,name))
  151.        ,name            ;ignore if not referenced
  152.        (CAR ,(car chosen))))
  153.       `(SYNTAX-VARIABLE-WIDTH-EXPRESSION
  154.     ,expression
  155.     (LIST
  156.      ,@(map (LAMBDA (clause)
  157.           `(CONS (LAMBDA (,name)
  158.                ,name    ;ignore if not referenced
  159.                ,(car clause))
  160.              ',(cdr clause)))
  161.         clauses)))))
  162.  
  163. (define (syntax-variable-width-expression expression clauses)
  164.   (if (exact-integer? expression)
  165.       (let ((chosen (choose-clause expression clauses)))
  166.     (car ((car chosen) expression)))
  167.       `(VARIABLE-WIDTH-EXPRESSION
  168.     ,expression
  169.     ,@clauses)))
  170.  
  171. ;;;; Coercion Machinery
  172.  
  173. (define (make-coercion-name coercion-type size)
  174.   (intern
  175.    (string-append "coerce-"
  176.           (number->string size)
  177.           "-bit-"
  178.           (symbol->string coercion-type))))
  179.  
  180. (define coercion-property-tag
  181.   "Coercion")
  182.  
  183. (define ((coercion-maker coercion-types) coercion-type size)
  184.   (let ((coercion
  185.      ((cdr (or (assq coercion-type coercion-types)
  186.            (error "Unknown coercion type" coercion-type)))
  187.       size)))
  188.     (2D-put! coercion coercion-property-tag (list coercion-type size))
  189.     coercion))
  190.  
  191. (define (coercion-size coercion)
  192.   (cadr (coercion-properties coercion)))
  193.  
  194. (define (unmake-coercion coercion receiver)
  195.   (apply receiver (coercion-properties coercion)))
  196.  
  197. (define (coercion-properties coercion)
  198.   (or (2D-get coercion coercion-property-tag)
  199.       (error "COERCION-PROPERTIES: Not a known coercion" coercion)))
  200.  
  201. (define coercion-environment
  202.   (the-environment))
  203.  
  204. (define-integrable (lookup-coercion name)
  205.   (lexical-reference coercion-environment name))
  206.  
  207. (define ((coerce-unsigned-integer nbits) n)
  208.   (unsigned-integer->bit-string nbits n))
  209.  
  210. (define (coerce-signed-integer nbits)
  211.   (let* ((limit (expt 2 (-1+ nbits)))
  212.      (offset (+ limit limit)))
  213.     (lambda (n)
  214.       (unsigned-integer->bit-string
  215.        nbits
  216.        (cond ((negative? n) (+ n offset))
  217.          ((< n limit) n)
  218.          (else (error "Integer too large to be encoded" n)))))))
  219.  
  220. (define (standard-coercion kernel)
  221.   (lambda (nbits)
  222.     (lambda (n)
  223.       (unsigned-integer->bit-string nbits (kernel n)))))