[_CDCSL_93-16_]<1>Cedar>release>Scheme>TidbitMisc.scheme

;;; TidbitMisc.scheme

;;; Last changed by Pavel on August 11, 1989 6:35:15 pm PDT

;;; Environment management

(define (next-env-slot! name)

(dynamic-set! *last-env-slot* (+ (dynamic-ref *last-env-slot*) 1))

(dynamic-set! *env-names* (cons name (dynamic-ref *env-names*)))

(dynamic-ref *last-env-slot*))

(define (extend-env env ids)

(if (null? env)

(nest-env env ids)

(let loop ((frame (car env))

(ids ids))

(if (null? ids)

(cons frame (cdr env))

(loop (cons `(,(car ids) . ,(next-env-slot! (car ids))) frame)

(cdr ids))))))

(define (extend-env-with-syntax env ids expanders)

(if (null? env)

(cons (map cons ids expanders) '())

(let loop ((frame (car env))

(ids ids)

(expanders expanders))

(if (null? ids)

(cons frame (cdr env))

(loop (cons `(,(car ids) . ,(car expanders)) frame)

(cdr ids)

(cdr expanders))))))

(define (nest-env env ids)

(cons

(map (lambda (id) `(,id . ,(next-env-slot! id))) ids)

env))

(define (lookup-id id env global-fn local-fn)

;; GLOBAL-FN is applied to the name if it's not bound in ENV.

;; LOCAL-FN is applied to two args:

;; -- How many binding frames away the ID was found, and

;; -- The "value" of the ID in that frame.

(let loop ((env env)

(up 0))

(if (null? env)

(global-fn id)

(let ((pair (assq id (car env))))

(if pair

(local-fn up (cdr pair))

(loop (cdr env) (+ up 1)))))))

(define (id->name id env)

(lookup-id id env new-global

(lambda (up over)

(cond

((integer? over)

(local-name up over))

(else

(cerror "Use a temporary variable instead"

"The syntax identifier ~S is used as a value variable"

id)

temp-name)))))

;;; Error reporting/handling

(define (cerror fix-format problem-format . args)

(display "Error: ")

(apply format #t problem-format args)

(format #t "~%Recovery: ")

(apply format #t fix-format args)

(newline))

;;; Fluid-let variables

(define *last-env-slot* (make-dynamic -1))

(define *env-names* (make-dynamic '()))

(define *last-name-index* (make-dynamic -1))

(define *name* (make-dynamic '()))

(define (next-name-index!)

(dynamic-set! *last-name-index* (+ (dynamic-ref *last-name-index*) 1))

(dynamic-ref *last-name-index*))

;;; Syntax Expansion

(define (expand-syntax* form env)

(if (pair? form)

(let ((first (car form)))

(if (symbol? first)

(lookup-id first env

;; Global case

(lambda (id)

(if (memq id '(letrec primitive-let-syntax

%%lambda-with-name%%))

form

(if (environment-bound? user id)

(let ((value (environment-ref user id)))

(if (syntax? value)

(expand-syntax*

(apply (syntax-expander value) (cdr form))

env)

form))

form)))

;; Local case

(lambda (up value)

(if (procedure? value)

(expand-syntax*

(apply value (cdr form))

env)

form)))

form))

;;; TidBit functions

(define tf-descriptor (make-record-type 'tidbit-fn '(

name ; arbitrary value, for debugging purposes

env-names ; list of symbols, last is rest arg if dotted?=#t

dotted? ; true if last arg is a rest arg.

required-args ; # of required arguments

globals ; list of symbols, the global variables referred to

literals ; list of indices in global literal table

; or other, nested tidbit-fn's

code-proc ; string, name of Cedar PROC for this fn

initial-pc ; PC for function entry

doc))) ; documentation string or ()

(define make-tidbit-fn (record-constructor tf-descriptor))

(define tidbit-fn? (record-predicate tf-descriptor))

(define tidbit-fn-name (record-accessor tf-descriptor 'name))

(define tidbit-fn-env-names (record-accessor tf-descriptor 'env-names))

(define tidbit-fn-dotted? (record-accessor tf-descriptor 'dotted?))

(define tidbit-fn-required-args
(record-accessor tf-descriptor 'required-args))

(define tidbit-fn-globals (record-accessor tf-descriptor 'globals))

(define tidbit-fn-literals (record-accessor tf-descriptor 'literals))

(define tidbit-fn-code-proc (record-accessor tf-descriptor 'code-proc))

(define tidbit-fn-initial-pc (record-accessor tf-descriptor 'initial-pc))

(define tidbit-fn-doc (record-accessor tf-descriptor 'doc))

;;; Name handling

(define stack-limit 20)

(define stack-name-table (make-table))

(define (stack-name index)

(define (make-name index)

(if (< index stack-limit)

(format #f "s[~S]" index)

(format #f "a.sEx[~S]" (- index stack-limit))))

(or (table-ref stack-name-table index)

(let ((name (make-name index)))

(table-set! stack-name-table index name)

name)))

(define literal-name-table (make-table))

(define (literal-name index)

(or (table-ref literal-name-table index)

(let ((name (format #f "c[~S]" index)))

(table-set! literal-name-table index name)

name)))

(define global-name-table (make-table))

(define (global-name index)

(or (table-ref global-name-table index)

(let ((name (format #f "g[~S].cdr" index)))

(table-set! global-name-table index name)

name)))

(define local-name-table (make-table))

(define (local-name up over)

(define (make-name up over name)

(if (> up 0)

(make-name (- up 1) over (string-append name ".parent"))

(format #f "~A[~S]" name over)))

(let ((id (make-rectangular up over))) ; Hack until EQUAL? tables exist.

(or (table-ref local-name-table id)

(let ((name (make-name up over "env")))

(table-set! local-name-table id name)

name))))

(define temp-name "temp")

(define result-name (stack-name 0))

(define name=? equal?)

;;; Literal/Global interning

(define *all-literals* (make-dynamic #f))

; EQV? table mapping values to indices in

; the global literal vector.

(define *literals* (make-dynamic '()))

; A-list for lambda-local literals:

; (value . name)

(define *literal-count* (make-dynamic 0))

; (length (dynamic-ref *literals*))

(define named-literals

'((#t . "true")

(#f . "false")

(#!unspecified . "unspecified")

(() . "NIL")

("" . "emptyString")))

(define (new-literal value)

(cond

((assv value named-literals)

=> cdr)

((assv value (dynamic-ref *literals*))

=> cdr)

(else

(unless (or (tidbit-fn? value)

(table-ref (dynamic-ref *all-literals*) value))

(table-set! (dynamic-ref *all-literals*)

value

(table-size (dynamic-ref *all-literals*))))

(dynamic-set! *literals*

(cons

(cons value

(literal-name (dynamic-ref *literal-count*)))

(dynamic-ref *literals*)))

(dynamic-set! *literal-count* (+ 1 (dynamic-ref *literal-count*)))

(cdar (dynamic-ref *literals*)))))

(define (finalize-literals)

(map (lambda (pair)

(if (tidbit-fn? (car pair))

(car pair)

(table-ref (dynamic-ref *all-literals*) (car pair))))

(reverse (dynamic-ref *literals*))))

(define *globals* (make-dynamic '()))

(define *global-count* (make-dynamic 0))

(define (new-global id)

(cond

((assq id (dynamic-ref *globals*))

=> cdr)

(else

(dynamic-set! *globals*

`((,id . ,(global-name (dynamic-ref *global-count*)))

,@(dynamic-ref *globals*)))

(dynamic-set! *global-count* (+ 1 (dynamic-ref *global-count*)))

(cdar (dynamic-ref *globals*)))))

(define (finalize-globals)

(reverse (map car (dynamic-ref *globals*))))

;;; Bookkeeping

(define *max-top* (make-dynamic 0))

(define (try-top top)

(dynamic-set! *max-top* (max top (dynamic-ref *max-top*)))

top)

(define *last-pc* (make-dynamic -1))

(define (next-pc!)

(dynamic-set! *last-pc* (+ (dynamic-ref *last-pc*) 1))

(dynamic-ref *last-pc*))