home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pseudo-s / pseudo_2.lha / node.scm < prev    next >
Encoding:
Text File  |  1991-12-24  |  4.7 KB  |  178 lines
  1. ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2. ; File node.scm / Copyright (c) 1991 Jonathan Rees / See file COPYING
  3.  
  4. ;;;; Node abstraction
  5.  
  6. ;+++ Make it abstract at some point.
  7.  
  8. ; Standard type order (8):
  9. ;  constant variable LAMBDA LETREC IF BEGIN SET! call
  10.  
  11. (define (node? obj)
  12.   (and (vector? obj)
  13.        (>= (vector-length obj) 1)
  14.        (memq (vector-ref obj 0)
  15.          '(constant local-variable program-variable
  16.             lambda letrec if begin set! call))))
  17.  
  18. (define (node-type node)
  19.   (vector-ref node 0))
  20.  
  21. (define (node-predicate type)
  22.   (lambda (node)
  23.     (eq? (node-type node) type)))
  24.  
  25. (define (node-accessor type index)
  26.   (lambda (node)
  27.     (if (not (eq? (node-type node) type))
  28.     (error "wrong node type" node type))
  29.     (vector-ref node index)))
  30.  
  31. (define (node-modifier type index)
  32.   (lambda (node new-val)
  33.     (if (not (eq? (node-type node) type))
  34.     (error "wrong node type" node type))
  35.     (vector-set! node index new-val)))
  36.  
  37. ; Constant
  38.  
  39. (define (make-constant val quoted?)
  40.   (vector 'constant val quoted?))
  41.  
  42. (define constant? (node-predicate 'constant))
  43.  
  44. (define constant-value (node-accessor 'constant 1))
  45. (define constant-quoted? (node-accessor 'constant 2))
  46.  
  47. ; LAMBDA
  48.  
  49. (define (make-lambda vars body-node)
  50.   (vector 'lambda vars body-node))
  51.  
  52. (define lambda? (node-predicate 'lambda))
  53.  
  54. (define lambda-vars (node-accessor 'lambda 1))
  55. (define lambda-body (node-accessor 'lambda 2))
  56.  
  57. (define (n-ary? proc)
  58.   (not (proper-list? (lambda-vars proc))))
  59.  
  60. (define (proper-list? thing)
  61.   (or (null? thing)
  62.       (and (pair? thing)
  63.        (null? (cdr (last-pair thing))))))
  64.  
  65. (define (proper-listify thing)
  66.   (cond ((null? thing) '())
  67.     ((pair? thing) (cons (car thing) (proper-listify (cdr thing))))
  68.     (else (list thing))))
  69.  
  70. (define (map-bvl proc bvl)
  71.   (cond ((null? bvl) '())
  72.     ((pair? bvl)
  73.      (cons (proc (car bvl)) (map-bvl proc (cdr bvl))))
  74.     (else (proc bvl))))
  75.  
  76. ; LETREC
  77.  
  78. (define (make-letrec vars val-nodes body-node)
  79.   (vector 'letrec vars val-nodes body-node #f))
  80.  
  81. (define letrec? (node-predicate 'letrec))
  82.  
  83. (define letrec-vars (node-accessor 'letrec 1))
  84. (define letrec-vals (node-accessor 'letrec 2))
  85. (define letrec-body (node-accessor 'letrec 3))
  86. (define letrec-strategy (node-accessor 'letrec 4))
  87.  
  88. (define set-letrec-strategy! (node-modifier 'letrec 4))
  89.  
  90. ; IF
  91.  
  92. (define (make-if test con alt)
  93.   (vector 'if test con alt))
  94.  
  95. (define if? (node-predicate 'if))
  96.  
  97. (define if-test (node-accessor 'if 1))
  98. (define if-con  (node-accessor 'if 2))
  99. (define if-alt  (node-accessor 'if 3))
  100.  
  101. ; BEGIN
  102.  
  103. (define (make-begin first second)
  104.   (vector 'begin first second))
  105. (define begin? (node-predicate 'begin))
  106. (define begin-first  (node-accessor 'begin 1))
  107. (define begin-second (node-accessor 'begin 2))
  108.  
  109. ; SET!
  110.  
  111. (define (make-set! lhs rhs)
  112.   (vector 'set! lhs rhs))
  113. (define set!? (node-predicate 'set!))
  114. (define set!-lhs (node-accessor 'set! 1))
  115. (define set!-rhs (node-accessor 'set! 2))
  116.  
  117. ; Call
  118.  
  119. (define (make-call proc-node arg-nodes)
  120.   (vector 'call proc-node arg-nodes))
  121.  
  122. (define call? (node-predicate 'call))
  123. (define call-proc (node-accessor 'call 1))
  124. (define call-args (node-accessor 'call 2))
  125.  
  126. ; Definition
  127.  
  128. (define (make-define lhs rhs)
  129.   (vector 'define lhs rhs))
  130. (define define? (node-predicate 'define))
  131. (define define-lhs (node-accessor 'define 1))
  132. (define define-rhs (node-accessor 'define 2))
  133.  
  134. ; Variables
  135.  
  136. (define (make-local-variable uname)
  137.   (vector 'local-variable
  138.       uname                ;1 user's name
  139.       #f                 ;2 status - obsolete
  140.       #f                ;3 substitution
  141.       #f                ;4 path - obsolete
  142.       #f                ;5 value-refs?
  143.       #f                ;6 proc-refs?
  144.       #f                ;7 assigned?
  145.       #f                ;8 closed-over?
  146.       ))
  147.  
  148. (define local-variable? (node-predicate 'local-variable))
  149.  
  150. (define local-variable-name   (node-accessor 'local-variable 1))
  151. (define variable-substitution (node-accessor 'local-variable 3))
  152.  
  153. (define set-substitution! (node-modifier 'local-variable 3))
  154.  
  155. (define variable-value-refs?  (node-accessor 'local-variable 5))
  156. (define variable-proc-refs?   (node-accessor 'local-variable 6))
  157. (define variable-assigned?    (node-accessor 'local-variable 7))
  158. (define variable-closed-over? (node-accessor 'local-variable 8))
  159.  
  160. (define (set-value-refs!  var) ((node-modifier 'local-variable 5) var #t))
  161. (define (set-proc-refs!   var) ((node-modifier 'local-variable 6) var #t))
  162. (define (set-assigned!    var) ((node-modifier 'local-variable 7) var #t))
  163. (define (set-closed-over! var) ((node-modifier 'local-variable 8) var #t))
  164.  
  165. ; Program (or "global" or "top-level") variables
  166.  
  167. (define (make-program-variable name cl-symbol)
  168.   (vector 'program-variable name cl-symbol))
  169.  
  170. (define program-variable? (node-predicate 'program-variable))
  171.  
  172. (define program-variable-name      (node-accessor 'program-variable 1))
  173. (define program-variable-cl-symbol (node-accessor 'program-variable 2))
  174.  
  175. (define (variable? node)
  176.   (or (local-variable? node)
  177.       (program-variable? node)))
  178.