home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pseudo-s / pseudo_2.lha / classify.scm < prev    next >
Encoding:
Text File  |  1991-12-23  |  11.4 KB  |  347 lines
  1. ; Expression classification
  2.  
  3. ; Entry points (not a complete list?):
  4. ;  classify
  5. ;  process-define-syntax
  6. ;  classify-let-syntax, classify-letrec-syntax
  7. ;  bind            ; for let, lambda
  8. ;  lookup       ; for variable references
  9. ;  define!       ; for define (internal and otherwise)
  10. ;  scan-body
  11. ;  make-special-operator  ; for initialization
  12.  
  13. ;  classify : form * env -> class * form * env
  14. ;  env = name -> denotation
  15. ;  denotation = special + macro + variable
  16. ;  special = {begin, define, if, let-syntax, ...}
  17. ;  variable = [defined elsewhere]
  18. ;  macro = transformer * env
  19. ;  transformer = form * (name -> name) * (name * name -> bool) -> form
  20.  
  21. ; A "form" is an expression, definition, or (syntax ...) form.
  22.  
  23. ; Classify FORM in ENV, returning three values.
  24. ; This dispatches on FORM: it is either a literal, a name, a compound
  25. ; expression, or an already classified form.
  26.  
  27. (define (classify form env)
  28.   (cond ((name? form)
  29.      (values class/name form env))
  30.     ((pair? form)
  31.      (if (name? (car form))
  32.          (let ((den (lookup env (car form))))
  33.            (cond ((special-operator? den)
  34.               (let ((class (special-operator-class den)))
  35.             (if (check-special-form-syntax class form)
  36.                 (values class form env)
  37.                 (classify
  38.                  (syntax-error "invalid special form syntax"
  39.                        form)
  40.                  env))))
  41.              ((macro? den)
  42.               (classify-macro-application den form env))
  43.              (else
  44.               (values class/application form env))))
  45.          (values class/application form env)))
  46.     ((literal? form)
  47.      (values class/literal form env))
  48.     (else (classify (syntax-error "unknown expression type" form) env))))
  49.  
  50. ;==============================================================================
  51. ; Macro application
  52. ; A macro has both the environment in which the macro was defined
  53. ; and an expansion procedure.  The expansion procedure is called on
  54. ; the form, a renaming procedure, and a procedure for comparing
  55. ; denotations in the current environment with the definition
  56. ; environment (which is to allow the for the overriding of keywords:
  57. ; (LET ((ELSE #F)) (COND (ELSE 1) (#T 2))) => 2).
  58.  
  59. (define (classify-macro-application den form use-env)
  60.   (let ((def-env (macro-environment den)))
  61.     (with-values (lambda () (make-renamer+env def-env use-env))
  62.       (lambda (rename output-env)
  63.     (let* ((compare
  64.         (lambda (client-name macro-name)
  65.           (if (and (name? client-name)
  66.                (name? macro-name))
  67.               (same-denotation? (lookup output-env client-name)
  68.                     (lookup output-env macro-name))
  69.               (eq? client-name macro-name))))
  70.            (new-form
  71.         ((macro-transformer den) form rename compare)))
  72.       (classify new-form output-env))))))
  73.  
  74. ; Macro abstraction.
  75.  
  76. (define (process-syntax-spec sspec env)
  77.   (make-macro (eval-for-syntax sspec
  78.                    (get-environment-for-syntax env))
  79.           env))
  80.  
  81. ; Process a define-syntax encountered at program top level.
  82.  
  83. (define (process-define-syntax form env)
  84.   (define! env (cadr form) (process-syntax-spec (caddr form) env)))
  85.  
  86. ;==============================================================================
  87. ; let-syntax and letrec-syntax
  88. ; Classifiers for the two forms that introduce local syntax bindings.
  89. ; These classify the bodies of the forms in the appropriately extended
  90. ; environment.
  91.  
  92. (define (classify-let-syntax form env)
  93.   (let ((dspecs (let-syntax-form-dspecs form)))
  94.     (classify (let-syntax-form-body form)
  95.           (bind (map syntax-spec-name dspecs)
  96.             (map (lambda (dspec)
  97.                (process-syntax-spec (syntax-spec-form dspec) env))
  98.              dspecs)
  99.             env))))
  100.  
  101. (define (classify-letrec-syntax form outer-env)
  102.   (let ((new (new-environment outer-env)))
  103.     (for-each (lambda (dspec)
  104.         (define! new
  105.           (syntax-spec-name dspec)
  106.           (process-syntax-spec (syntax-spec-form dspec) new)))
  107.           (letrec-syntax-form-dspecs form))
  108.     (classify (letrec-syntax-form-body form) new)))
  109.  
  110. ;==============================================================================
  111. ; Environments
  112.  
  113. ; Environments come in three varieties:
  114. ;  - local (lambda, letrec, let-syntax) bindings
  115. ;      represented as #(LOCAL outer ((name1 . den1) ...))
  116. ;  - diversion environments, for expansions of macros
  117. ;      represented as #(DIVERT outer generation env)
  118. ;  - other - classify's client determines representation and semantics.
  119.  
  120. (define (lookup env name)
  121.   (cond ((local-environment? env)
  122.      (let ((probe (assq name (local-environment-bindings env))))
  123.        (if probe
  124.            (cdr probe)
  125.            (lookup (local-environment-parent env) name))))
  126.     ((diverted-environment? env)
  127.      (if (and (generated? name)
  128.           (same-generation? (generated-generation name)
  129.                     (diverted-environment-generation env)))
  130.          (lookup (diverted-environment-macro-env env)
  131.              (generated-name name))
  132.          (lookup (diverted-environment-parent env) name)))
  133.     (else
  134.      (client-lookup env name))))
  135.  
  136. (define (define! env name denotation)
  137.   (cond ((local-environment? env)
  138.      (let* ((bs (local-environment-bindings env))
  139.         (probe (assq name bs)))
  140.        (if probe
  141.            (set-cdr! probe denotation)
  142.            (set-local-environment-bindings!
  143.           env (cons (cons name denotation) bs)))))
  144.     ((diverted-environment? env)
  145.      ;; Not quite right.  Consider a macro that expands into
  146.      ;;  (define <generated> ... <generated> ...)
  147.      (define! (diverted-environment-parent env) name denotation))
  148.     (else
  149.      (client-define! env name denotation))))
  150.  
  151. (define local-environment-rtd
  152.   (make-record-type 'local-environment '(parent bindings)))
  153. (define make-local-environment
  154.   (record-constructor local-environment-rtd '(parent bindings)))
  155. (define local-environment?
  156.   (record-predicate local-environment-rtd))
  157. (define local-environment-parent
  158.   (record-accessor local-environment-rtd 'parent))
  159. (define local-environment-bindings
  160.   (record-accessor local-environment-rtd 'bindings))
  161. (define set-local-environment-bindings!
  162.   (record-modifier local-environment-rtd 'bindings))
  163.  
  164. (define diverted-environment-rtd
  165.   (make-record-type 'diverted-environment '(parent generation macro-env)))
  166. (define make-diverted-environment
  167.   (record-constructor diverted-environment-rtd
  168.               '(generation macro-env parent)))
  169. (define diverted-environment? (record-predicate diverted-environment-rtd))
  170. (define diverted-environment-parent
  171.   (record-accessor diverted-environment-rtd 'parent))
  172. (define diverted-environment-generation
  173.   (record-accessor diverted-environment-rtd 'generation))
  174. (define diverted-environment-macro-env
  175.   (record-accessor diverted-environment-rtd 'macro-env))
  176.  
  177. ; bind
  178.  
  179. (define (bind names denotations outer-env)
  180.   (make-local-environment outer-env (map cons names denotations)))
  181.  
  182. ; Bindings to be stored using define!
  183.  
  184. (define (new-environment outer-env)
  185.   (make-local-environment outer-env '()))
  186.  
  187.  
  188. ; Apply proc to each local variable in a given environment
  189.  
  190. (define (for-each-local proc env)
  191.   (let ((doit (lambda (name+den)
  192.         (let ((den (cdr name+den)))
  193.           (if (and (not (macro? den))
  194.                (not (special-operator? den)))
  195.               (proc den))))))
  196.     (let loop ((env env))
  197.       (cond ((local-environment? env)
  198.          (for-each doit (local-environment-bindings env))
  199.          (loop (local-environment-parent env)))
  200.         ((diverted-environment? env)
  201.          (loop (diverted-environment-parent env)))))))
  202.  
  203. ;==============================================================================
  204. ; Denotations
  205.  
  206. ; Denotation = special operator + macro + variable
  207. ; All of these can be compared using EQ?.
  208.  
  209. (define same-denotation? eq?)
  210.  
  211. ; Special operators
  212.  
  213. (define type/special-operator (make-record-type "Special operator" '(class)))
  214. (define make-special-operator
  215.   (record-constructor type/special-operator '(class)))
  216. (define special-operator?      (record-predicate type/special-operator))
  217. (define special-operator-class (record-accessor type/special-operator 'class))
  218.  
  219. ; Macros
  220.  
  221. (define type/macro (make-record-type "Macro" '(proc env)))
  222. (define make-macro (record-constructor type/macro '(proc env)))
  223. (define macro?            (record-predicate type/macro))
  224. (define macro-transformer (record-accessor type/macro 'proc))
  225. (define macro-environment (record-accessor type/macro 'env))
  226.  
  227. ; Implementation of variables is specific to a particular client of
  228. ; the classifier.
  229.  
  230. ;==============================================================================
  231. ; Names
  232.  
  233. (define (name? thing)
  234.   (or (symbol? thing)
  235.       (generated? thing)))
  236.  
  237. (define same-name? eq?)
  238. (define name-member memq)
  239. (define name-assoc assq)
  240.  
  241. (define (name->symbol name)
  242.   (if (symbol? name)
  243.       name
  244.       (string->symbol (name->string name))))
  245.        
  246. (define (name->string name)
  247.   (if (symbol? name)
  248.       (symbol->string name)
  249.       (string-append "."
  250.              (name->string (generated-name name))
  251.              "."
  252.              (number->string (generated-generation name)))))
  253.       
  254.  
  255. ; Generated names <name, generation>
  256.  
  257. (define type/generated (make-record-type "Generated" '(name generation)))
  258. (define make-generated (record-constructor type/generated '(name generation)))
  259. (define generated?      (record-predicate type/generated))
  260. (define generated-name  (record-accessor type/generated 'name))
  261. (define generated-generation (record-accessor type/generated 'generation))
  262.  
  263. ; Create a new version of THING with all generated parts replaced with their
  264. ; names.  Pairs and vectors are recursively ungenerated.  This is for use in
  265. ; processing the QUOTE special form.
  266.  
  267. (define (strip thing)
  268.   (cond ((generated? thing) (strip (generated-name thing)))
  269.     ((pair? thing)
  270.      (let ((x (strip (car thing)))
  271.            (y (strip (cdr thing))))
  272.        (if (and (eq? x (car thing))
  273.             (eq? y (cdr thing)))
  274.            thing
  275.            (cons x y))))
  276.     ((vector? thing)
  277.      (let ((new (make-vector (vector-length thing))))
  278.        (let loop ((i 0) (same? #t))
  279.          (if (>= i (vector-length thing))
  280.          (if same? thing new)
  281.          (let ((x (strip (vector-ref thing i))))
  282.            (vector-set! new i x)
  283.            (loop (+ i 1)
  284.              (and same? (eq? x (vector-ref thing i)))))))))
  285.     (else thing)))
  286.  
  287. ; Generated names are differentiated by their name and their generation.
  288. ; Generations are integers.
  289.  
  290. (define *generation* 1)
  291.  
  292. (define (new-generation)
  293.   (set! *generation* (+ *generation* 1))
  294.   *generation*)
  295.  
  296. (define same-generation? =)
  297.  
  298. (define (make-renamer+env macro-env client-env)
  299.   (let ((alist '())            ;list of name * generated
  300.     (generation (new-generation)))
  301.     (values (lambda (name)
  302.           (let ((probe (assq name alist)))
  303.         (if probe
  304.             (cdr probe)
  305.             (let ((new-name (make-generated name generation)))
  306.               (set! alist (cons (cons name new-name)
  307.                     alist))
  308.               new-name))))
  309.         (make-diverted-environment generation macro-env client-env))))
  310.  
  311.  
  312. ;==============================================================================
  313. ; Processing internal definitions
  314.  
  315. ; Three values:
  316. ;   definitions - a list of
  317. ;       (<defined name> <value-form> <environment>)
  318. ;     where <environment> is the environment in which <value-form>
  319. ;     should be classified
  320. ;   body-forms - a list of expressions
  321. ;   env - environment in which names should be define!d
  322.  
  323. (define (scan-body forms env)
  324.   (let ((env (new-environment env)))
  325.     (let loop ((forms forms) (specs '()))
  326.       (with-values (lambda () (classify (car forms) env))
  327.     (lambda (class form env)
  328.       (cond ((= class class/define)
  329.          (define! env
  330.            (define-form-lhs form)
  331.            dummy-for-define)        ;should never be seen
  332.          (loop (cdr forms)
  333.                (cons (list (define-form-lhs form)
  334.                    (define-form-rhs form)
  335.                    env)
  336.                  specs)))
  337.         ((= class class/begin)
  338.          (loop (append (begin-form-statements form) (cdr forms))
  339.                specs))
  340.         (else
  341.          (values (reverse specs) forms env))))))))
  342.  
  343. (define dummy-for-define
  344.   (make-generated 'undefined 0))
  345.  
  346. ; (put 'with-values 'scheme-indent-hook 1)
  347.