home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-386-Vol-2of3.iso / c / cr-macro.zip / UTILS.SCM < prev   
Text File  |  1990-02-18  |  2KB  |  79 lines
  1. ; Utilities (need to be loaded before interpreter)
  2.  
  3. ; THE FOLLOWING THREE DEFINITIONS ARE IMPLEMENTATION-DEPENDENT
  4.  
  5. (define scheme-eval
  6.   ;; #'schi:scheme-eval                 ; Pseudoscheme
  7.   (*value t-standard-env 'eval)      ; T
  8.   ;; (access-scheme-48 'eval)        ; Scheme-48
  9.   )
  10.  
  11. (define (make-transformer-environment)
  12.   ;; schi:usual-context            ; Pseudoscheme
  13.   ((*value t-standard-env 'make-locale) scheme-env 'transformer-env) ; T
  14.   ;; (access-scheme-48 'user-initial-environment) ;Scheme-48
  15.   )
  16.  
  17. ; Most Schemes already have some kind of ERROR form defined.
  18. ; (define error (access-scheme-48 'error))
  19.  
  20. ; Evaluate an expression written in the transformer language
  21.  
  22. (define (eval-transformer exp env)
  23.   (let ((exp (if (and (pair? exp)
  24.               (eq? (car exp) 'syntax-rules))
  25.          (rewrite-syntax-rules exp (lambda (x) x) eq?)
  26.          exp)))
  27.     (scheme-eval exp env)))
  28.  
  29. (define (syntax-error message form)
  30.   (error message form))
  31.  
  32. ; In lieu of define-record-type
  33.  
  34. (define (vector-predicate type-name)
  35.   (lambda (obj)
  36.     (and (vector? obj)
  37.      (> (vector-length obj) 0)
  38.      (eq? (vector-ref obj 0) type-name))))
  39.  
  40. (define (vector-accessor type-name index)
  41.   (let ((pred (vector-predicate type-name)))
  42.     (lambda (obj)
  43.       (if (pred obj)
  44.       (vector-ref obj index)
  45.       (error "bad argument" type-name obj)))))
  46.  
  47. (define (vector-updater type-name index)
  48.   (let ((pred (vector-predicate type-name)))
  49.     (lambda (obj val)
  50.       (if (pred obj)
  51.       (vector-set! obj index val)
  52.       (error "bad argument" type-name obj)))))
  53.  
  54. ; Misc.
  55.  
  56. (define (any pred l)
  57.   (and (not (null? l))
  58.        (or (pred (car l))
  59.        (any pred (cdr l)))))
  60.  
  61. (define (right-assq x l)
  62.   (if (null? l)
  63.       #f
  64.       (if (eq? x (cdar l))
  65.       (car l)
  66.       (right-assq x (cdr l)))))
  67.  
  68. (define (make-table)
  69.   (list 'table))
  70.  
  71. (define (table-ref table key)
  72.   (let ((probe (assq key (cdr table))))
  73.     (if probe
  74.     (cdr probe)
  75.     #f)))
  76.  
  77. (define (table-set! table key value)
  78.   (set-cdr! table (cons (cons key value) (cdr table))))
  79.