home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / encorsrc.lha / encore_sources / sys / syntax.t < prev    next >
Encoding:
Text File  |  1988-05-02  |  7.9 KB  |  210 lines
  1. (herald syntax (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. ;;;; Syntax tables & syntax descriptors
  27.  
  28. (define-integrable syntax-table-entry
  29.   (object (lambda (table sym) (table sym))
  30.           ((setter self) set-syntax-table-entry)))
  31.  
  32. (define-operation (set-syntax-table-entry table sym descr))
  33.  
  34. ;++ shouldn't syntax tables be eliminated and let
  35. ;++ the syntax-descriptor into regular environments?
  36.  
  37. (define (make-syntax-table super . maybe-id)
  38.   (let* ((id (car maybe-id))            ; (car '()) => #f
  39.          (table (make-table id))
  40.          (env nil)
  41.          (atomex nil))
  42.     (object (lambda (sym)
  43.               (let ((probe (table-entry table sym)))
  44.                 (cond (probe (if (eq? probe '*filtered*) nil probe))
  45.                       (super (super sym))
  46.                       (else nil))))
  47.       ((set-syntax-table-entry self sym descr)
  48.        (cond ((table-entry table sym)
  49.               (env-warning "Redefining syntax" sym))
  50.              ((and super (super sym))
  51.               (env-warning "Shadowing syntax" sym)))
  52.        (set (table-entry table sym)
  53.             (if descr
  54.                 (enforce syntax-descriptor? descr)
  55.                 '*filtered*)))
  56.       ((env-for-syntax-definition self)
  57.        (cond (env)
  58.              (else
  59.               (set env (if super 
  60.                            (env-for-syntax-definition super)
  61.                            (make-locale standard-env 'env-for-syntax-definition)))
  62.               env)))
  63.       ((set-env-for-syntax-definition self new-env)
  64.        (set env (enforce environment? new-env)))
  65.       ((atom-expander self)
  66.        (cond (atomex)
  67.              (super (atom-expander super))
  68.              (else default-atom-expander)))
  69.       ((set-atom-expander self new-atomex)
  70.        (set atomex (enforce procedure? new-atomex)))
  71.       ((syntax-table? self) '#t)
  72.       ((identification self) id)
  73.       ((set-identification self val)
  74.        (if (not id) (set id val)))
  75.       ((print-type-string self) "Syntax-table"))))
  76.                                 
  77. (define-predicate syntax-table?)
  78. (define-settable-operation (env-for-syntax-definition table))
  79. (define set-env-for-syntax-definition (setter env-for-syntax-definition))
  80.  
  81. (define-settable-operation (atom-expander table))
  82. (define set-atom-expander (setter atom-expander))
  83.  
  84. (define (default-atom-expander atom)
  85.   (cond ((symbol? atom)
  86.          `(,(t-syntax 'variable-value) ,atom))   ;randomness
  87.         ((self-evaluating? atom)
  88.          `(,(t-syntax 'quote) ,atom))           ;more randomness
  89.         ((null? atom)
  90.          (warning "~S in evaluated position~%" atom)
  91.          `(,(t-syntax 'quote) ,atom))
  92.         (else
  93.          (syntax-error "unevaluable datum - ~S" atom))))
  94.  
  95. ;++ what about #!true #!false ...
  96. (define (self-evaluating? exp)
  97.   (or (number? exp)
  98.       (string? exp)
  99.       (char? exp)))
  100.  
  101. (define (make-empty-syntax-table id)
  102.   (make-syntax-table nil id))
  103.  
  104. (define-operation (syntax-descriptor? obj) (macro-expander? obj))
  105. (define-predicate macro-expander?)
  106. (define-operation (expand-macro-form desc exp table))
  107. (define-operation (syntax-check-predicate obj) true)
  108.  
  109. ;;; Called from expansion of MACRO-EXPANDER.
  110. ;;; EXPANDER is a procedure of one argument.
  111. ;;; Someday allow for tracing macro expansions?
  112.  
  113. (define (make-macro-descriptor expander pred id)
  114.   (let ((pred (if (pair? pred) true pred)))
  115.     (object nil
  116.       ((expand-macro-form self exp table)
  117.        (ignore table)
  118.        (expander exp))
  119.       ((macro-expander? self) t)
  120.       ((syntax-check-predicate self) pred)
  121.       ((print self stream)
  122.        (print-syntax-descriptor self stream))
  123.       ((identification self) id)
  124.       ((disclose self)
  125.        (disclose-macro-expander expander))
  126.       ((get-loaded-file self)
  127.        (get-loaded-file expander)))))
  128.  
  129. ;;; Sample nonstandard macro expander:
  130. ;;;   (OBJECT NIL
  131. ;;;           ((EXPAND-MACRO-FORM SELF EXP TABLE)
  132. ;;;            ... use TABLE ...)
  133. ;;;           ((MACRO-EXPANDER? SELF) T))
  134.  
  135. ;;; Basic syntax check for special forms.
  136.  
  137. (define (check-special-form-syntax desc exp)
  138.   (cond (((syntax-check-predicate desc) (cdr exp))
  139.          exp)
  140.         (else
  141.          (check-special-form-syntax desc
  142.                                     (syntax-error
  143.                                      "bad syntax for special form~%  ~S"
  144.                                      exp)))))
  145.  
  146. ;;; This is no longer used in this file, but it is needed elsewhere.
  147.  
  148. (define (compatible-with-argspectrum? l spect)
  149.   (iterate loop ((l l) (n 0))
  150.     (cond ((fx>= n (car spect))
  151.            (cond ((null? (cdr spect))
  152.                   (if (null? l) n nil))         ;Must match exactly
  153.                  ((fixnum? (cdr spect))
  154.                   (iterate loop ((l l) (n n))
  155.                     (cond ((or (fx>= n (cdr spect)) (atom? l))
  156.                            (if (null? l) n nil))
  157.                           (else (loop (cdr l) (fx+ n 1))))))
  158.                  (else n)))     ;Enough args, and no limit
  159.           ((atom? l) nil)       ;Too few args
  160.           (else (loop (cdr l) (fx+ n 1))))))
  161.  
  162. ;;; ---------- end of important stuff.
  163.  
  164. ;;; Random debugging thing called by CRAWL.
  165.  
  166. (define (macro-expand form table)
  167.   (cond ((atom? form) form)
  168.         ((symbol? (car form))
  169.          (let ((probe (syntax-table-entry table (car form))))
  170.            (if (and probe (macro-expander? probe))
  171.                (expand-macro-form probe form table)
  172.                form)))
  173.         ((macro-expander? (car form))
  174.          (expand-macro-form (car form) form table))
  175.         (else form)))
  176.  
  177. ;;; Incredibly kludgey procedure.  Assumes that the form of DISCLOSE
  178. ;;; of the expansion procedure is of the form
  179. ;;;  (NAMED-LAMBDA ,SYMBOL (,Z)
  180. ;;;    (DESTRUCTURE (((() . ,ARGS) ,Z))
  181. ;;;      . ,REST))
  182.  
  183. (define (disclose-macro-expander proc)
  184.   (let ((f (lambda (name body)
  185.              (cond ((and (pair? body) (eq? (car body) (t-syntax 'destructure)))
  186.                     (destructure ((   (#f (((#f . args) #f)) . body)   body))
  187.                       `(macro-expander (,name . ,args) . ,body)))
  188.                    (else nil)))))
  189.     (cond ((disclose proc)
  190.             => (lambda (lexp)
  191.                  (cond ((pair? lexp)
  192.                         (case (car lexp)
  193.                           ((named-lambda) (f (cadr lexp) (cadddr lexp)))
  194.                           ((lambda)       (f nil         (caddr lexp)))
  195.                           (else nil)))
  196.                        (else nil))))
  197.           (else nil))))
  198.  
  199. (define (*define-syntax env symbol descr)
  200.   (set (syntax-table-entry (env-syntax-table env) symbol) descr))
  201.  
  202. (define (t-syntax name)         ;Handy abbreviation
  203.   (syntax-table-entry standard-syntax-table name))
  204.  
  205. (set (syntax-present?) '#t)
  206.  
  207.  
  208.  
  209.  
  210.