

(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)
(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)))))


(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))

(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*))


(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))
form))


(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))


(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?)


(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*))))


(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*))

     
;;; TidbitMisc.scheme
;;; Copyright Ó 1989, 1991 by Xerox Corporation.  All rights reserved.
;;; Last changed by Pavel on August 11, 1989 6:35:15 pm PDT
;;; Environment management
;; 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.
;;; Error reporting/handling

;;; Fluid-let variables
;;; Syntax Expansion
;;; TidBit functions
;;; Name handling
;;; Literal/Global interning
;;; Bookkeeping
Êë  –(cedarcode) style•NewlineDelimiter
™ ™JšœÐetœ7™FJ™;—J˜ ™J˜ ˜J˜BJ˜@J˜—J˜ ˜˜J˜˜J˜˜J˜˜>J˜————J˜ —˜2˜J˜#˜˜J˜—˜J˜˜3˜J˜—————J˜ —˜˜J˜5J˜——J˜ ˜-J™=J™#J™8J™*˜J˜˜J˜˜!˜J˜J˜————J˜ —˜˜˜˜˜J˜—˜˜*J˜6J˜—J˜——————J˜ ™J˜ ˜1J˜J˜%J˜J˜!J˜
——J™ ™J˜ ˜*J˜ —J˜'J˜ J˜,J˜"J˜ ˜J˜FJ˜ ——J˜ ™J˜ ˜!˜˜˜˜J˜˜˜*J˜"J˜˜ ˜(˜˜J˜*J˜—J˜——J˜———J˜˜˜˜J˜J˜—J˜———J˜——J˜———J˜ ™J˜ ˜5J˜/J˜;J˜*J˜'J˜<J˜2J˜ J˜2J˜"J˜$—J˜ J˜:J˜ J˜4J˜ J˜=J˜GJ˜CJ˜OJ˜CJ˜EJ˜GJ˜IJ˜;—J˜ ™J˜ ˜J˜ —˜&J˜ —˜J˜ ˜˜J˜J˜/——J˜ ˜&˜J˜(J˜———J˜ ˜(J˜ —˜˜(˜'J˜*J˜———J˜ ˜'J˜ —˜˜'˜+J˜)J˜———J˜ ˜&J˜ —˜J˜ ˜ ˜J˜8J˜ ——J˜ ˜H˜#˜'J˜%J˜————J˜ J˜J˜ J˜#J˜ J˜—J˜ ™J˜ J˜)J˜-J˜ J˜&J˜'J˜J˜)J˜'J˜ ˜J˜J˜J˜!J˜J˜—J˜ ˜˜˜J˜—˜&J˜—˜˜J˜8˜(˜J˜1———˜˜˜˜;J˜————J˜BJ˜"——J˜ —˜˜˜ ˜J˜7——J˜&——J˜ J˜%J˜(J˜ ˜˜˜"J˜—˜˜J˜5J˜—J˜@J˜!——J˜ —˜J˜,——J˜ ™J˜ ˜#J˜ —˜J˜:J˜—J˜ ˜$J˜ —˜J˜6J˜——J˜ — …—    .   9  