(#%define-macro #%quasiquote
  (#%lambda (form)
    (#%let-values
      (((normal)
        (#%lambda (x old)
          (#%if (#%eq? x old)
            (#%if (#%null? x) x (#%list (#%quote #%quote) x))
            x))))
      (normal
        (#%letrec-values
          (((qq)
            (#%lambda (x level)
              (#%let-values
                (((qq-list)
                  (#%lambda (x level)
                    (#%let-values
                      (((old-first) (#%car x)))
                      (#%let-values
                        (((old-second) (#%cdr x)))
                        (#%let-values
                          (((first) (qq old-first level)))
                          (#%let-values
                            (((second) (qq old-second level)))
                            (#%let-values
                              ()
                              (#%if (#%if (#%eq? first old-first)
                                      (#%eq? second old-second)
                                      #f)
                                x
                                (#%list
                                  (#%quote #%cons)
                                  (normal first old-first)
                                  (normal second old-second)))))))))))
                (#%if (#%pair? x)
                  (#%let-values
                    (((first) (#%car x)))
                    (#%if (#%if (#%eq? first (#%quote unquote))
                            (#%list? x)
                            #f)
                      (#%let-values
                        (((rest) (#%cdr x)))
                        (#%if (#%let-values
                                (((g35) (#%not (#%pair? rest))))
                                (#%if g35 g35 (#%not (#%null? (#%cdr rest)))))
                          (#%raise-syntax-error
                            (#%quote unquote)
                            "takes exactly one expression"
                            (#%list (#%quote quasiquote) form)))
                        (#%if (#%zero? level)
                          (#%car rest)
                          (qq-list x (#%sub1 level))))
                      (#%if (#%if (#%eq? first (#%quote quasiquote))
                              (#%list? x)
                              #f)
                        (qq-list x (#%add1 level))
                        (#%if (#%if (#%eq? first (#%quote unquote-splicing))
                                (#%list? x)
                                #f)
                          (#%raise-syntax-error
                            (#%quote unquote-splicing)
                            "invalid context within quasiquote"
                            (#%list (#%quote quasiquote) form))
                          (#%if (#%if (#%pair? first)
                                  (#%if (#%eq? (#%car first)
                                               (#%quote unquote-splicing))
                                    (#%list? first)
                                    #f)
                                  #f)
                            (#%let-values
                              (((rest) (#%cdr first)))
                              (#%if (#%let-values
                                      (((g34) (#%not (#%pair? rest))))
                                      (#%if g34
                                        g34
                                        (#%not (#%null? (#%cdr rest)))))
                                (#%raise-syntax-error
                                  (#%quote unquote-splicing)
                                  "takes exactly one expression"
                                  (#%list (#%quote quasiquote) form)))
                              (#%let-values
                                (((uqsd) (#%car rest))
                                 ((old-l) (#%cdr x))
                                 ((l) (qq (#%cdr x) level)))
                                (#%if (#%zero? level)
                                  (#%let-values
                                    (((l) (normal l old-l)))
                                    (#%let-values
                                      ()
                                      (#%list (#%quote #%append) uqsd l)))
                                  (#%let-values
                                    (((restx) (qq-list rest (#%sub1 level))))
                                    (#%let-values
                                      ()
                                      (#%if (#%if (#%eq? l old-l)
                                              (#%eq? restx rest)
                                              #f)
                                        x
                                        (#%list
                                          (#%quote #%cons)
                                          (#%list
                                            (#%quote #%cons)
                                            (#%list
                                              (#%quote #%quote)
                                              (#%quote unquote-splicing))
                                            (normal restx rest))
                                          (normal l old-l))))))))
                            (qq-list x level))))))
                  (#%if (#%vector? x)
                    (#%let-values
                      (((l) (#%vector->list x)))
                      (#%let-values
                        (((l2) (qq l level)))
                        (#%let-values
                          ()
                          (#%if (#%eq? l l2)
                            x
                            (#%list (#%quote #%list->vector) l2)))))
                    (#%if (#%box? x)
                      (#%let-values
                        (((v) (#%unbox x)))
                        (#%let-values
                          (((qv) (qq v level)))
                          (#%let-values
                            ()
                            (#%if (#%eq? v qv)
                              x
                              (#%list (#%quote #%box) qv)))))
                      x)))))))
          (qq form 0))
        form))))

> qstop quasiquote <

(#%define-macro #%and 
  (#%case-lambda
   [() #t]
   [(expr) expr]
   [(expr . exprs)
    `(#%if ,expr
	 (#%and ,@exprs)
	 #f)]))

> kstop and <

(#%define-macro #%or
  (#%case-lambda 
   [() #f]
   [(expr) expr]
   [(expr . exprs)
    (#%let ([temp (#%gensym)])
      `(#%let ([,temp ,expr])
	 (#%if ,temp
	       ,temp
	       (#%or ,@exprs))))]))

> kstop or <

(#%define-macro #%cond
    (#%lambda form
     (#%let ([serror
	      (#%lambda (msg at)
		(#%raise-syntax-error 'cond msg (#%cons 'cond form) at))])
      (#%let loop ([tests form])
	(#%if (#%null? tests)
	    (#%if (#%compile-allow-cond-fallthrough)
		'(#%void)
		'(#%cond))
	    (#%if (#%not (#%pair? tests))
		(serror
		 "bad syntax (body must contain a list of pairs)"
		 tests)
		(#%let ([line (#%car tests)]
		        [rest (#%cdr tests)])
		  (#%if (#%not (#%pair? line))
		        (serror
			 "bad syntax (clause is not a test-value pair)"
			 line)
		      (#%let* ([test (#%car line)]
			       [value (#%cdr line)]
			       [else? (#%and (#%eq? test 'else) 
					     (#%not (#%local-expansion-time-bound? 'else)))])
			(#%if (#%and else? (#%pair? rest))
			      (serror "bad syntax (`else' clause must be last)" line))
			(#%if (#%and (#%pair? value)
				     (#%eq? '=> (#%car value))
				     (#%not (#%local-expansion-time-bound? '=>)))
			    (#%if (#%and (#%pair? (#%cdr value))
					 (#%null? (#%cddr value)))
				(#%let ([test (#%if else?
						    #t 
						    test)]
					[gen (#%gensym)])
				  `(#%let ([,gen ,test])
				     (#%if ,gen
					 (,(#%cadr value) ,gen)
					 ,(loop rest))))
				(serror
				 "bad syntax (bad clause form with =>)"
				 line))
			    (#%if else?
				(#%cons '#%begin value)
				(#%if (#%null? value)
				    (#%let ([gen (#%gensym)])
				      `(#%let ([,gen ,test])
					 (#%if ,gen ,gen ,(loop rest))))
				    (#%list
				     '#%if test
				     (#%cons '#%begin value)
				     (loop rest))))))))))))))

> cstop cond <

(#%define-macro #%case 
    (#%lambda (v . tests-in)
     (#%let ([serror
	      (#%lambda (msg at)
		(#%raise-syntax-error
		 'case
		 msg
		 (#%list* 'case v tests-in)
		 at))])
      (#%let ([gen (#%gensym)])
	`(#%let ([,gen ,v])
	   (#%cond
	    ,@(#%let loop ([tests tests-in])
		(#%cond
		 [(#%null? tests) `()]
		 [(#%pair? tests)
		  (#%let ([test-value (#%car tests)]
			  [rest (#%cdr tests)])
		    (#%cons
		     (#%if (#%or (#%not (#%pair? test-value))
				 (#%not (#%pair? (#%cdr test-value))))
			 (serror
			  "bad syntax (clause is not a test-value pair)"
			  test-value)
			 (#%let ([test (#%car test-value)]
				 [value (#%cdr test-value)])
			   (#%if (#%and (#%pair? value) (#%list? value))
				 #t
				 (serror
				  "bad syntax (improper clause body)"
				  value))
			   (#%cons
			    (#%cond
			     [(#%and (#%eq? test 'else)
				     (#%not (#%local-expansion-time-bound? 'else)))
			      (#%if (#%null? rest)
				    'else
				    (serror
				     "bad syntax (`else' clause must be last)"
				     test-value))]
			     [else
			      (#%if (#%not (#%list? test))
				    (serror
				     "bad syntax (improper datum list)"
				     test))
			      (#%cons 
			       '#%or
			       (#%let loop ([test test])
				 (#%cond
				  [(#%null? test) ()]
				  [else
				   (#%let ([t (#%list '#%quote (#%car test))])
				     (#%cons `(#%eqv? ,gen ,t)
					     (loop (#%cdr test))))])))])
			    `((#%begin ,@value)))))
		     (loop rest)))]
		 [else (serror
			"bad syntax (body must contain a list of pairs)"
			tests)]))))))))

> kstop case <

(#%define-macro #%do 
    (#%lambda (bindings test-and-result . body)
      (#%let ([code (#%list* 'do bindings test-and-result body)])
	(#%if (#%list? bindings)
	      (#%void)
	      (#%raise-syntax-error 'do "bad syntax (bad binding sequence)" code))
	(#%map (#%lambda (binding)
		 (#%if (#%and (#%list? binding)
			      (#%let ([l (#%length binding)])
			        (#%or (#%= l 2) (#%= l 3))))
		     (#%void)
		     (#%raise-syntax-error 'do "bad syntax (bad binding)" code)))
	       bindings)
	(#%if (#%list? test-and-result) (#%void)
	      (#%raise-syntax-error 'do "bad syntax (bad test and result)" code))
	(#%if (#%list? body) (#%void)
	      (#%raise-syntax-error 'do "bad syntax (improper body)" code))
	(#%let* ([vars (#%map (#%lambda (binding)
				(#%let ([var (#%car binding)])
				  (#%if (#%symbol? var)
				      var
				      (#%raise-syntax-error
				       'do "bad syntax (variable must be an identifier)"
				       code))))
			      bindings)]
		 [inits (#%map #%cadr bindings)]
		 [steps (#%map (#%lambda (binding)
				 (#%cond
				  [(#%pair? (#%cddr binding))
				   (#%caddr binding)]
				  [else (#%car binding)]))
			       bindings)]
		 [test (#%if (#%pair? test-and-result)
			   (#%car test-and-result)
			   (#%raise-syntax-error
			    'do "bad syntax (test/result part)"
			    code))]
	       [results (#%if (#%null? (#%cdr test-and-result))
			    (#%list '(#%void))
			    (#%cdr test-and-result))]
	       [loop (#%gensym)])
	  `(#%let ,loop ,(#%map (#%lambda (var init)
				(#%list var init))
			        vars inits)
		(#%if ,test
		    (#%begin
		      ,@results)
		    (#%begin
		      ,@body
		      (,loop ,@steps))))))))

> kstop do <

(#%define-macro #%define
     (#%lambda body
       (#%let ([code (#%cons 'define body)])
	 (#%if (#%null? body)
	       (#%raise-syntax-error
		'define
		"bad syntax (no definition body)"
		code))
	 (#%let ([first (#%car body)]) 
	  (#%cond
	   [(#%symbol? first)
	    (#%if (#%and (#%pair? (#%cdr body))
			 (#%null? (#%cddr body)))
		  `(#%define-values (,first) ,@(#%cdr body))
		  (#%raise-syntax-error
		   'define
		   "bad syntax (zero or multiple expressions after identifier)"
		   code))]
	   [(#%pair? first)
	    (#%let ([bad-symbol  (#%lambda (s) (#%raise-syntax-error 'define
								     "bad identifier"
								     code
								     s))])
		   (#%let loop ([l first])
			  (#%cond
			   [(#%null? l) #f]
			   [(#%pair? l) 
			    (#%if (#%symbol? (#%car l))
				  (loop (#%cdr l))
				  (bad-symbol (#%car l)))]
			   [(#%symbol? l) #f]
			   [else (bad-symbol l)])))
	    
	    `(#%define-values (,(#%car first)) (#%lambda ,(#%cdr first) ,@(#%cdr body)))]
	   [else
	    (#%raise-syntax-error
	     'define
	     "not an identifier"
	     code
	     first)])))))

> kstop define <

(#%define-macro #%set!-values
  (#%lambda (args expr)
    (#%and (#%or (#%list? args)
		 (#%raise-syntax-error
			       'set!-values
			       "bad syntax (illegal use of `.')"
			       (#%list 'set!-values args expr)
			       args))
	   (#%andmap (#%lambda (arg)
			(#%or (#%symbol? arg)
			      (#%raise-syntax-error
			       'set!-values
			       "bad syntax (not an identifier)"
			       (#%list 'set!-values args expr)
			       arg)))
		     args))
    (#%if (#%and (#%pair? args) (#%null? (#%cdr args)))
	  `(#%set! ,(#%car args) ,expr)
	  (#%let ([gens (#%map (#%lambda (arg) (#%gensym)) args)])
	     `(#%let-values ([,gens ,expr])
		 ,@(#%if (#%null? args)
			 `((#%void))
			 (#%map (#%lambda (arg gen) `(#%set! ,arg ,gen)) args gens)))))))

> kstop set!-values <

(#%define-macro #%delay
  (#%lambda (body)
    `(#%make-promise (#%lambda () ,body))))

> kstop delay <

(#%define-macro #%let/cc 
  (#%lambda (var expr1 . body)
    `(#%call/cc (#%lambda (,var) ,expr1 ,@body))))

> kstop let/cc <

(#%define-macro #%let/ec 
  (#%lambda (var expr1 . body)
    `(#%call/ec (#%lambda (,var) ,expr1 ,@body))))

> kstop let/ec <

(#%define-macro #%when 
  (#%lambda (test expr1 . body)
    `(#%if ,test
	   (#%begin
	    ,expr1
	    ,@body))))

> kstop when <

(#%define-macro #%unless 
  (#%lambda (test expr1 . body)
    `(#%if ,test
	   (#%void)
	   (#%begin
	    ,expr1
	    ,@body))))

> kstop unless <

(#%define-macro #%define-struct
  (#%lambda body
     (#%let ([syntax-error
	      (#%lambda (s . detail)
		(#%apply
		 #%raise-syntax-error
		 'define-struct
		 s
		 (#%cons 'define-struct body)
		 detail))]
	     [build-struct-names
	      (#%lambda (name fields)
		(#%let ([name (#%symbol->string name)]
			[fields (#%map #%symbol->string fields)]
			[+ #%string-append])
		  (#%map #%string->symbol
			 (#%append
			  (#%list 
			   (+ "struct:" name)
			   (+ "make-" name)
			   (+ name "?"))
			  (#%apply
			   #%append
			   (#%map
			    (#%lambda (f) 
			       (#%list 
				(+ name "-" f)
				(+ "set-" name "-" f "!")))
			   fields))))))])
	    (#%or (#%pair? body)
		  (syntax-error "empty declaration"))
	    (#%or (#%= 2 (#%length body))
		  (syntax-error "wrong number of parts"))
	    (#%or (#%symbol? (#%car body))
		  (#%and (#%pair? (#%car body))
			 (#%symbol? (#%caar body))
			 (#%pair? (#%cdar body))
			 (#%null? (#%cddar body)))
		  (syntax-error "first part must be an identifier or identifier-expression pair"))
	    (#%or (#%list? (#%cadr body))
		  (syntax-error "illegal use of `.' in field list"))
	    (#%for-each (#%lambda (x) 
			  (#%or (#%symbol? x)
				(syntax-error "field name not a identifier" x)))
		      (#%cadr body))
	    (#%let ([name (#%if (#%symbol? (#%car body))
			      (#%car body)
			      (#%caar body))]
		  [fields (#%cadr body)])
	      `(#%define-values ,(build-struct-names name fields) (#%struct ,@body))))))

> kstop define-struct <

(#%define-macro #%let-struct
  (#%lambda (base field . body)
    `(#%let () (#%define-struct ,base ,field) ,@body)))

> kstop let-struct <

> literal "#ifndef NO_OBJECT_SYSTEM"

(#%define-macro #%class 
  (#%lambda (super args . rest)
    `(#%class*/names (this super-init) ,super () ,args ,@rest)))

> kstop class <

(#%define-macro #%class* 
  (#%lambda (super interfaces args . rest)
    `(#%class*/names (this super-init) ,super ,interfaces ,args ,@rest)))

> kstop class* <

(#%define-macro #%send 
  (#%lambda (obj msg . params)
    (#%unless (#%symbol? msg)
      (#%raise-syntax-error
       'send
       "bad syntax (expected an ivar name)"
       (#%list* 'send obj msg params)
       msg))
    `((#%ivar ,obj ,msg) ,@params)))

> kstop send <

(#%define-macro #%make-generic 
  (#%lambda (c% name)
    (#%unless (#%symbol? name)
      (#%raise-syntax-error
       'make-generic
       "bad syntax (expected an ivar name)"
       (#%list 'make-generic c% name)
       name))
    `(#%make-generic/proc ,c% (#%quote ,name))))

> kstop make-generic <

(#%define-macro #%ivar 
    (#%lambda args
      (#%if (#%list? args)
	  (#%let ([l (#%length args)])
	    (#%cond
	     [(#%= l 2)
	      (#%unless (#%symbol? (#%cadr args))
		 (#%raise-syntax-error
		  'ivar
		  "bad syntax (expected an ivar name)"
		  (#%cons 'ivar args)
		  (#%cadr args)))
	      `(#%ivar/proc ,(#%car args) (#%quote ,(#%cadr args)))]
	     [else (#%raise-syntax-error
		    'ivar
		    (#%format "bad syntax (~s parts after the keyword)" l)
		    (#%cons 'ivar args))]))
	  (#%raise-syntax-error
	   'ivar
	   "bad syntax (illegal use of `.')"
	   (#%cons 'ivar args)))))

> kstop ivar <

> literal "#endif"

(#%define-macro #%fluid-let 
    (#%lambda (assignments expr1 . body)
     (#%if (#%null? assignments)
      `(#%let-values () ,expr1 ,@body)
      (#%let ([mk-expr (lambda () (#%list* 'fluid-let 
					      assignments 
					      expr1
					      body))])
	(#%unless (#%list? assignments)
           (#%raise-syntax-error 'fluid-let
				 "bad syntax" (mk-expr)
				 assignments))
	(#%let ([tempnames (#%map (#%lambda (assignment) 
				   (#%cond
				    [(#%and (#%pair? assignment)
					   (#%symbol? (#%car assignment))
					   (#%pair? (#%cdr assignment))
					   (#%null? (#%cddr assignment)))
				    (#%gensym)]
				    [else
				     (#%raise-syntax-error
				      'fluid-let
				      "bad syntax"
				      (mk-expr)
				      assignment)]))
				  assignments)])
	     `(#%let ,(#%map (#%lambda (tempname assignment)
			     (#%list tempname (#%car assignment)))
			   tempnames assignments)
	   (#%dynamic-wind
	    (#%lambda ()
	      ,@(#%map (#%lambda (assignment)
			 `(#%set! ,(#%car assignment) ,(#%cadr assignment)))
		       assignments))
	    (#%lambda () ,expr1 ,@body)
	    (#%lambda ()
	      ,@(#%map (#%lambda (assignment tempname)
		       `(#%set! ,(#%car assignment) ,tempname))
		     assignments tempnames)))))))))

> kstop fluid-let <

(#%define-macro #%parameterize
    (#%lambda (params . body)
     (#%let ([fail
	      (#%lambda (msg)
	       (#%raise-syntax-error
		'parameterize
		msg
		(#%list* 'parameterize params body)))])
      (#%if (#%null? body) (fail "bad syntax (empty body)"))
      (#%if (#%not (#%list? params)) (fail "bad syntax"))
      (#%if (#%ormap (#%lambda (pp)
                       (#%or (#%not (#%pair? pp))
		             (#%not (#%pair? (#%cdr pp)))
		             (#%not (#%null? (#%cddr pp)))))
                     params)
            (fail "bad syntax"))
      (#%if (#%null? params)
        `(#%let-values () ,@body)
        (#%let ([params (#%map #%car params)]
                [vals (#%map #%cadr params)]
                [saves (#%map (#%lambda (x) (#%gensym)) params)]
                [pzs (#%map (#%lambda (x) (#%gensym)) params)]
                [swap (#%gensym 'swap)])
           `(#%let ,(#%append
		     (#%map list pzs params)
		     (#%map list saves vals))
		   (#%let ((,swap 
			    (#%lambda () ,@(#%map 
					    (#%lambda (save pz)
					      `(#%let ([x ,save])
						  (#%set! ,save (,pz))
						  (,pz x)))
					    saves pzs))))
			  (#%dynamic-wind
			   ,swap
			   (#%lambda () ,@body)
			   ,swap))))))))

> kstop parameterize <

(#%define-macro #%with-handlers
    (#%lambda (clauses . body)
      (#%if (#%and (#%list? clauses)
		   (#%andmap (#%lambda (p)
			       (#%and (#%pair? p)
				      (#%pair? (#%cdr p))
				      (#%null? (#%cddr p))))
			     clauses)
		   (#%pair? body))
	  (#%void)
	  (#%raise-syntax-error 'with-handlers "bad syntax"
				(#%list* 'with-handlers clauses body)))
      (#%if (#%null? clauses)
	  `(#%let-values () ,@body)
        (#%let ([k (#%gensym)]
	        [loop (#%gensym)]
	        [list (#%gensym)])
	  `((#%call/ec 
	     (#%lambda (,k)
	       (#%let ([,list (#%list ,@(#%map (#%lambda (p)
		  			       `(#%cons ,(#%car p)
		      				,(#%cadr p)))
					     clauses))])
	         (#%parameterize ([#%current-exception-handler
				   (#%lambda (e)
				    (,k
				     (#%lambda ()
				      (#%let ,loop ([,list ,list])
				        (#%cond
				         [(#%null? ,list)
					  (#%raise e)]
					 [((#%caar ,list) e)
					  ((#%cdar ,list) e)]
					 [else
					  (,loop (#%cdr ,list))])))))])
		   (#%call-with-values
		    (#%lambda () ,@body)
		    (#%lambda args (#%lambda () (#%apply #%values args)))))))))))))

> kstop with-handlers <

> literal "#ifdef USE_STRUCT_CASE"

(#%define-macro #%struct-case-lambda
  (#%lambda (x . pairs)
    (#%unless (#%and (#%symbol? x)
                     (#%list? pairs)
                     (#%andmap (#%lambda (p) (#%and (#%list? p) (#%not (#%null? p)))) pairs))
	      (#%raise-syntax-error 'struct-case-lambda "bad syntax"
				    (#%list* 'struct-case-lambda x pairs)))
    (#%let-values ([(predicates functions else)
		    (#%let loop ([l pairs])
		      (#%if (#%null? l)
			    (#%values () () ())
			    (#%let-values ([(p-rest f-rest else) (loop (#%cdr l))]
					   [(p) (#%caar l)]
					   [(f) (#%let ([r (#%cdar l)])
						  `(#%lambda (,x) ,@(#%if (#%null? r)
									  '(x)
									  r)))])
			     (#%cond
			      [(#%and (#%eq? p 'else)
				      (#%not (#%local-expansion-time-bound? 'else)))
			       (#%unless (#%null? p-rest)
					 (#%raise-syntax-error 'struct-case-lambda "else clause must be last"
							       (#%list* 'struct-case-lambda x pairs)))
			       (#%values () () (#%list f))]
			      [else
			       (#%values (#%cons p p-rest)
					 (#%cons f f-rest)
					 else)]))))])
      (#%list* '#%make-struct-case 
	       (#%cons '#%list predicates)
	       (#%cons '#%list functions)
	       else))))

> kstop struct-case-lambda <

> literal "#endif"

(#%define load/cd
  (#%let ([make-exn make-exn:i/o:filesystem]
	  [debug current-continuation-marks])
    (#%lambda (n)
      (#%unless (#%string? n)
	(#%raise-type-error 'load/cd "string" n))
      (#%let-values ([(base name dir?) (#%split-path n)])
	 (#%if dir?
	     (#%raise
	      (make-exn
	       (#%string->immutable-string
		(#%format "load/cd: cannot open a directory: ~s" n))
	       (debug)
	       n
	       #f))
	     (#%if (#%not (#%string? base))
		 (#%load n)
		 (#%begin
		   (#%if (#%not (#%directory-exists? base))
		       (#%raise
			(make-exn
			 (#%string->immutable-string
			  (#%format 
			   "load/cd: directory of ~s does not exist (current directory is ~s)" 
			   n (#%current-directory)))
			 (debug)
			 base
			 #f)))
		   (#%let ([orig (#%current-directory)])
		     (#%dynamic-wind
		      (#%lambda () (#%current-directory base))
		      (#%lambda () (#%load name))
		      (#%lambda () (#%current-directory orig)))))))))))
  
> fstop load/cd <

(#%define (read-eval-print-loop)
  (#%let* ([eeh #f]
	   [jump #f]
	   [be? #f]
	   [rep-error-escape-handler (#%lambda () (jump))])
    (#%dynamic-wind
      (#%lambda () (#%set! eeh (#%error-escape-handler))
		   (#%set! be? (#%break-enabled))
		   (#%error-escape-handler rep-error-escape-handler)
                   (#%break-enabled #f))
      (#%lambda ()
	(#%let/ec done
          (#%let loop ()
	    (#%let/ec k
              (#%dynamic-wind
                 (#%lambda ()
                   (#%break-enabled be?)
                   (#%set! jump k))
		 (#%lambda ()
		   (#%let ([v ((#%current-prompt-read))])
		     (#%when (#%eof-object? v) (done (#%void)))
		     (#%call-with-values
		      (#%lambda () ((#%current-eval) v))
		      (#%lambda results (#%for-each (#%current-print) results)))))
		 (#%lambda () 
                   (#%set! be? (#%break-enabled))
		   (#%break-enabled #f)
                   (#%set! jump #f))))
	    (loop))))
      (#%lambda () (#%error-escape-handler eeh)
                   (#%break-enabled be?)
		   (#%set! jump #f)
                   (#%set! eeh #f)))))

> fstop read-eval-print-loop <

> literal "#ifndef NO_FILE_SYSTEM_UTILS"

(#%define-values (load-relative load-relative-extension)
  (#%let ([mk
	   (#%lambda (load name)
             (#%lambda (path)
               (#%unless (#%and (#%string? path) (#%or (#%relative-path? path) (#%absolute-path? path)))
                 (#%raise-type-error name "pathname string" path))
               (#%if (#%complete-path? path)
           	  (load path)
           	  (#%let ([dir (#%current-load-relative-directory)])
           	     (load (#%if dir (#%path->complete-path path dir) path))))))])
    (#%values (mk #%load 'load-relative) (mk #%load-extension 'load-relative-extension))))

> fstop load-relative load-relative-extension <

(#%define-values (load/use-compiled 
		  require-library/proc require-relative-library/proc 
		  provide-library collection-path)
  (#%let* ([get-table current-loaded-library-table]
	   [not-found (box 0)]
	   [null-str (#%string #\nul)]
	   [debug current-continuation-marks]
	   [make-exn make-exn:i/o:filesystem]
	   [check (#%lambda (who s)
		    (#%unless (#%string? s)
		      (#%raise-type-error who "string" s))
		    (#%unless (#%relative-path? s)
		      (#%raise (make-exn
				(#%string->immutable-string
				 (#%format "~a: invalid relative path: ~s" who s))
				(debug) s 'ill-formed-path))))]
	   [with-null (#%lambda (l) (#%let loop ([l l])
					   (#%if (#%null? l)
						 #%null
						 (#%list* (#%car l) null-str (loop (#%cdr l))))))]
	   [check-collection
	    (#%lambda (who collection collection-path)
		      (check who collection) (#%for-each (lambda (p) (check who p)) collection-path))]
	   [find-col
	    (#%lambda (who collection collection-path)
	      (#%let ([all-paths (#%current-library-collection-paths)])
		     (#%let loop ([paths all-paths])
			    (#%if (#%null? paths)
				 (#%raise
				  (make-exn
				   (#%string->immutable-string
				    (#%format "~a: collection not found: ~s in any of: ~s" 
					      who collection all-paths))
				   (debug)
				   collection
				   #f))
				 (#%let ([dir (#%build-path (#%car paths) collection)])
				    (#%if (#%directory-exists? dir)
				       (#%let* ([cpath (#%apply #%build-path dir collection-path)])
					  (#%if (#%directory-exists? cpath)
						cpath
						(let loop ([p dir][l collection-path][c collection])
						  (#%let ([np (#%build-path p (#%car l))]
							  [nc (#%build-path c (#%car l))])
							 (#%if (#%directory-exists? np)
							       (loop np (#%cdr l) nc)
							       (#%raise
								(make-exn
								 (#%string->immutable-string
								  (#%format "require-library: collection ~s does not have sub-collection: ~s in: ~s"
									    c (#%car l) p))
								 (debug)
								 nc
								 #f)))))))
				       (loop (#%cdr paths))))))))])
	   
	  (#%letrec ([core-load/use-compiled
		      (#%let ([re:suffix (#%regexp "\\..?.?.?$")]
			      [resolve (#%lambda (s)
						 (#%if (#%complete-path? s)
						       s
						       (#%let ([d (#%current-load-relative-directory)])
							      (#%if d (#%path->complete-path s d) s))))]
			      [date>=?
			       (#%lambda (a bm)
					 (#%let ([am (#%with-handlers ([#%void (#%lambda (x) #f)])
								      (#%file-or-directory-modify-seconds a))])
						(#%or (#%and (#%not bm) am) (#%and am bm (#%>= am bm)))))])
			     (#%case-lambda 
			      [(path) (core-load/use-compiled path #f)]
			      [(path none-there)
			       (#%unless (#%and (#%string? path) (#%or (#%relative-path? path) (#%absolute-path? path)))
				    (#%raise-type-error 'load/use-compiled "pathname string" path))
			       (#%let*-values ([(path) (resolve path)]
					       [(base file dir?) (#%split-path path)]
					       [(base) (#%if (#%eq? base 'relative) 'same base)]
					       [(mode) (#%use-compiled-file-kinds)]
					       [(comp?) (#%not (#%eq? mode 'none))])
				  (#%let* ([get-so (#%lambda (file)
							     (#%if comp?
								   (#%build-path base
										 "compiled"
										 "native"
										 (#%system-library-subpath)
										 (#%regexp-replace 
										  re:suffix file
										  (#%case (#%system-type)
											  [(windows) ".dll"]
											  [else ".so"])))
								   #f))]
					   [ok-kind? (#%lambda (file)
							(#%or (#%eq? mode 'all)
							   (#%with-handlers ([#%void #%void])
							      (#%let-values ([(p) (#%open-input-file file)])
							        (#%dynamic-wind
								 #%void
								 (#%lambda ()
								   (#%not (#%and (#%char=? #\' (#%read-char p))
										 (#%char=? #\e (#%read-char p))
										 (#%char=? #\space (#%read-char p)))))
								 (#%lambda () (#%close-input-port p)))))))]
					   [zo (#%and comp?
						      (#%build-path base
								    "compiled"
								    (#%regexp-replace re:suffix file ".zo")))]
					   [so (get-so file)]
					   [_loader-so (get-so "_loader.ss")]
					   [path-d (#%with-handlers ([#%void (#%lambda (x) #f)])
								    (#%file-or-directory-modify-seconds path))]
					   [with-dir (#%lambda (t) 
						      (#%parameterize ([#%current-load-relative-directory 
									(#%if (#%string? base) base (#%current-directory))])
							(t)))])
				     (#%cond
				      [(#%and (date>=? _loader-so path-d)
					      (#%let ([getter (#%load-extension _loader-so)])
						     (getter (#%string->symbol (#%regexp-replace re:suffix file "")))))
				       => (#%lambda (loader) (with-dir loader))]
				      [(date>=? so path-d)
				       (with-dir (#%lambda () ((#%current-load-extension) so)))]
				      [(#%and (date>=? zo path-d) (ok-kind? zo))
				       (with-dir (#%lambda () ((#%current-load) zo)))]
				      [(and (not path-d) none-there)
				       (none-there)]
				      [else (#%load path)])))]))]
		     [collection-path (#%lambda (collection . collection-path) 
						(check-collection 'collection-path collection collection-path)
						(find-col 'collection-path collection collection-path))]
		     [require-relative-library/proc
		      (#%lambda (file . collection-path)
			 (check 'require-relative-library file) 
			 (check-collection 'require-relative-library file collection-path)
			 (#%let ([cp (#%current-require-relative-collection)])
			    (#%if cp
				  (#%apply require-library/proc file (#%append cp collection-path))
				  (#%raise
				   (make-exn
				    (#%string->immutable-string
				     (#%format "require-relative-library: there is no current collection for library: ~s~a"
					       file
					       (#%if (#%null? collection-path)
						     ""
						     (#%format " in sub-collection: ~s" collection-path))))
				    (debug)
				    (#%apply #%build-path file collection-path)
				    #f)))))]
		     [filecol->symbol
		      (#%lambda (file collection collection-path)
			(#%string->symbol (#%apply #%string-append 
						   (with-null (#%list* file collection collection-path)))))]
		     [require-library/proc
		      (#%case-lambda
		       [(file) (require-library/proc file "mzlib")]
		       [(file collection . collection-path)
			(check 'require-library file) (check-collection 'require-library collection collection-path)
			(#%let ([table (get-table)]
				[sym (filecol->symbol file collection collection-path)])
			       (#%let ([found (#%hash-table-get table sym (#%lambda () not-found))])
				      (#%if (#%eq? found not-found)
					    (#%let* ([c (find-col 'require-library collection collection-path)]
						     [p (#%build-path c file)]
						     [result (#%parameterize ([#%current-require-relative-collection
									       (#%cons collection collection-path)])
							          (#%call-with-values
								   (#%lambda () 
								     (core-load/use-compiled
									 p
									 (#%lambda ()
									    (#%raise
									     (make-exn
									      (#%string->immutable-string
									       (#%format "require-library: collection ~s does not have library: ~s in: ~s"
											 (#%apply #%build-path collection collection-path) file c))
									      (debug)
									      p
									      #f)))))
								   #%list))])
						    (#%hash-table-put! table sym result)
						    (#%apply #%values result))
					    (#%if (#%procedure? found)
						  (#%call-with-values 
						   (#%lambda ()
							     (#%parameterize ([#%current-require-relative-collection
									       (#%cons collection collection-path)])
							        (found)))
						   (#%lambda found
							     (#%hash-table-put! table sym found)
							     (#%apply #%values found)))
						  (#%apply #%values found)))))])]
		     [provide-library
		      (#%case-lambda
		       [(vals file) (provide-library vals file "mzlib")]
		       [(vals file collection . collection-path)
			(#%unless (#%and (#%procedure? vals) (#%procedure-arity-includes? vals 0))
				  (#%raise-type-error 'provide-library "procedure (arity 0)" vals))
			(check 'provide-library file) (check-collection 'provide-library collection collection-path)
			(#%let ([table (get-table)]
				[sym (filecol->symbol file collection collection-path)])
			       (#%let ([found (#%hash-table-get table sym (#%lambda () not-found))])
				      (#%if (#%eq? found not-found)
					    (begin
					      (#%hash-table-put! table sym vals)
					      #t)
					    #f)))])]
		     [load/use-compiled (lambda (f) (core-load/use-compiled f #f))])
		    (#%values load/use-compiled
			      require-library/proc require-relative-library/proc
			      provide-library
			      collection-path))))

> fstop load/use-compiled require-library/proc require-relative-library/proc provide-library collection-path <

(#%begin
 (#%define tmp-rl
      (#%lambda (req-lib/proc rel?)
          (#%letrec ([rl (#%case-lambda 
			  [(name . collection-path)
			   (#%let ([name (#%local-expand-defmacro name)]
				   [collection-path (#%map #%local-expand-defmacro collection-path)]
				   [check (#%lambda (s kind)
					    (#%unless (#%string? s)
					      (#%let ([rlname (#%if rel? 'require-relative-library 'require-library)])
						(#%raise-syntax-error 
						 rlname
						 (#%string->immutable-string
						  (#%format "~a name is not a string" kind))
						 (#%list* rlname name collection-path)))))])
				  (check name "library")
				  (#%if (#%or rel? (#%null? collection-path))
					(#%for-each (#%lambda (c) (check c "sub-collection")) collection-path)
					(#%begin
					 (check (#%car collection-path) "collection")
					 (#%for-each (#%lambda (c) (check c "sub-collection")) (#%cdr collection-path))))
				  `(,req-lib/proc ,name ,@collection-path))])])
	         rl)))
  (#%define-macro #%require-relative-library (tmp-rl '#%require-relative-library/proc #t))
  (#%define-macro #%require-library (tmp-rl '#%require-library/proc #f))
  (#%undefine 'tmp-rl))

> kstop require-library require-relative-library <

(#%define path-list-string->path-list
  (#%let ((r (#%regexp (#%let ((sep (#%case (#%system-type) 
					    ((unix beos oskit) ":")
					    ((windows macos) ";"))))
			      (#%format "([^~a]*)~a(.*)" sep sep))))
	  (cons-path (#%lambda (default s l) 
			       (#%if (#%string=? s "")
				     (#%append default l)
				     (#%if (#%or (#%relative-path? s) (#%absolute-path? s)) (#%cons s l) l)))))
    (#%lambda (s default)
      (#%unless (#%string? s) (#%raise-type-error 'path-list-string->path-list "string" s))
      (#%unless (#%list? default) (#%raise-type-error 'path-list-string->path-list "list" default))
      (#%let loop ([s s])
	(#%let ([m (#%regexp-match r s)])
          (#%if m
		(cons-path default (#%cadr m) (loop (#%caddr m)))
		(cons-path default s #%null)))))))

> fstop path-list-string->path-list <

(#%define find-executable-path
  (#%lambda (program libpath)
    (#%unless (#%string? program)
      (#%raise-type-error 'find-executable-path "string" program))
    (#%unless (#%or (#%not libpath) (#%relative-path? libpath))
      (#%raise-type-error 'find-executable-path "relative-path string or #f" libpath))
    (#%letrec ([found-exec
		(#%lambda (exec-name)
                  (#%if libpath
		        (#%let-values ([(base name isdir?) (#%split-path exec-name)])
		           (#%if (#%string? base)
		             (#%let ([lib (#%build-path base libpath)])
			       (#%if (#%or (#%directory-exists? lib) 
				           (#%file-exists? lib))
			           lib
			           (#%let ([resolved (#%resolve-path exec-name)])
			             (#%cond
				      [(#%string=? resolved exec-name) #f]
				      [(#%relative-path? resolved)
				       (found-exec (#%build-path base resolved))]
			             [else (found-exec resolved)]))))
		             #f))
			exec-name))])
      (#%if (#%relative-path? program)
	  (#%let ([paths-str (#%getenv "PATH")]
		  [win-add (#%lambda (s) (#%if (#%eq? (#%system-type) 'windows) (#%cons "." s) s))])
	    (#%let loop ([paths (#%if paths-str 
				      (win-add (#%path-list-string->path-list paths-str #%null))
				      #%null)])
		  (#%if (#%null? paths)
			#f
			(#%let* ([base (#%path->complete-path (#%car paths))]
				 [name (#%build-path base program)])
				(#%if (#%file-exists? name)
				      (found-exec name)
				      (loop (#%cdr paths)))))))
	  (found-exec program)))))

> fstop find-executable-path <

> literal "#endif"

> literal "#ifdef TIME_SYNTAX"

(#%define-macro #%time
  (#%lambda (expr1 . body)
    `(#%let-values ([(v cpu user gc) (#%time-apply (#%lambda () ,expr1 ,@body) #%null)])
	(#%printf "cpu time: ~s real time: ~s gc time: ~s~n" cpu user gc)
	(#%apply #%values v))))

> kstop time <

> literal "#endif"

> literal "#ifndef NO_UNIT_SYSTEM"

(#%define verify-linkage-signature-match
  (#%let ([make-exn make-exn:unit]
	  [p-suffix (#%lambda (pos) (#%case pos [(1) 'st][(2) 'nd][(3) 'rd][else 'th]))])
    (#%lambda (who tags units esigs isigs)
      (#%for-each
       (#%lambda (u tag)
	  (#%unless (#%unit-with-signature? u)
	     (#%raise
	      (make-exn
	       (#%string->immutable-string
		(#%format
		 "~s: expression for \"~s\" is not a signed unit"
		 who tag))
	       (#%current-continuation-marks)))))
       units tags)
      (#%for-each
       (#%lambda (u tag esig)
	 (#%verify-signature-match
	  who #f
	  (#%format "specified export signature for ~a" tag)
	  esig
	  (#%format "export signature for actual ~a sub-unit" tag)
	  (#%unit-with-signature-exports u)))
       units tags esigs)
      (#%for-each
       (#%lambda (u tag isig)
	 (#%let ([n (#%length (#%unit-with-signature-imports u))]
		 [c (#%length isig)])
	   (#%unless (#%= c n)
	      (#%raise
	       (make-exn
		(#%string->immutable-string
		 (#%format
		  "~s: ~a unit imports ~a units, but ~a units were provided"
		  who tag n c))
		(#%current-continuation-marks))))))
       units tags isigs)
      (#%for-each
       (#%lambda (u tag isig)
	 (#%let loop ([isig isig][expecteds (#%unit-with-signature-imports u)][pos 1])
	   (#%unless (#%null? isig)
	     (#%let ([expected (#%car expecteds)]
		     [provided (#%car isig)])
	       (#%verify-signature-match
		who #t
		(#%format "~a unit's ~s~s import (~a signature)" tag
			  pos (p-suffix pos)
			  (#%car expected))
		(#%cdr expected)
		(#%format "~s~s linkage (~a signature) for ~a"
			  pos (p-suffix pos)
			  (#%car provided)
			  tag)
		(#%cdr provided))
	       (loop (#%cdr isig) (#%cdr expecteds) (#%add1 pos))))))
       units tags isigs))))

> fstop verify-linkage-signature-match <

; Extra names:
(#%define-values (unit/sig? unit-with-signature->unit unit/sig->unit)
       (values #%unit-with-signature?
	       #%unit-with-signature-unit
	       #%unit-with-signature-unit))

> fstop unit/sig? unit-with-signature->unit unit/sig->unit <

> literal "#endif"

(#%define rationalize
  (#%letrec ([check (#%lambda (x) 
                      (#%unless (#%real? x) (#%raise-type-error 'rationalize "real" x)))]
	     [find-between 
	      (#%lambda (lo hi)
		(#%if (#%integer? lo)
		    lo
		    (#%let ([lo-int (#%floor lo)]
			    [hi-int (#%floor hi)])
		      (#%if (#%< lo-int hi-int)
			  (#%add1 lo-int)
			  (#%+ lo-int
			     (#%/ (find-between (#%/ (#%- hi lo-int)) (#%/ (#%- lo lo-int)))))))))])
     (#%lambda (x within)
       (check x) (check within)
       (#%let* ([delta (#%abs within)]
		[lo (#%- x delta)]
	        [hi (#%+ x delta)])
	 (#%cond
	  [(#%not (#%= x x)) +nan.0]
	  [(#%<= lo 0 hi) (#%if (#%exact? x) 0 0.0)]
	  [(#%negative? lo) (#%- (find-between (#%- hi) (#%- lo)))]
	  [else (find-between lo hi)])))))

> fstop rationalize <

(#%define (simple-return-primitive? v)
  (#%unless (#%primitive? v) (#%raise-type-error 'simple-return-primitive? "primitive-procedure" v))
  (#%not (#%memq (#%inferred-name v) '(call-with-values 
				       apply 
				       error
				       call-with-current-continuation
				       hash-table-get
				       write-image-to-file))))

> fstop simple-return-primitive? <

(#%define (port? x) (#%or (#%input-port? x) (#%output-port? x)))

> fstop port? <

(#%define-macro #%begin-elaboration-time 
  (#%lambda body
    (#%if (#%or (#%null? body)
		(#%not (#%list? body)))
	  (#%raise-syntax-error 'begin-elaboration-time 
				"empty or ill-formed body"
				(#%cons 'begin-elaboration-time  body))
	  (#%eval `(#%begin ,@body)))))

> kstop begin-elaboration-time <

(#%define-values (scheme-report-environment null-environment)
  (#%let* ([debug current-continuation-marks]
	  [r4-syntax '(quasiquote unquote unquote-splicing 
				   if let and or
				   cond case define delay do
				   letrec let* begin
				   lambda quote set!)]
	  [r4 '(car cdr caar cadr cdar cddr
		    caaar caadr cadar caddr cdaar cdadr cddar cdddr
		    caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
		    cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
		    map = < > <= >= max min + - * / 
		    abs gcd lcm exp log sin cos tan not eq?
		    call-with-current-continuation
		    symbol->string make-rectangular exact->inexact inexact->exact number->string string->number 
		    rationalize output-port? current-input-port current-output-port current-error-port 
		    open-input-file open-output-file close-input-port close-output-port
		    with-output-to-file transcript-on transcript-off flush-output
		    string-length string-ci<=? string-ci>=? string-append string->list list->string string-fill! 
		    vector-length vector->list list->vector vector-fill! char-alphabetic? char-numeric? char-whitespace? 
		    char-upper-case? char-lower-case? char->integer integer->char char-downcase
		    call-with-output-file call-with-input-file with-input-from-file
		    apply for-each symbol? pair? cons set-car! set-cdr! null? list? list length append reverse list-tail list-ref
		    memq memv member assq assv assoc
		    number? complex? real? rational? integer? exact? inexact? zero? positive?  negative? odd? even? 
		    quotient remainder modulo floor ceiling truncate round numerator denominator asin acos atan sqrt
		    expt make-polar real-part imag-part angle magnitude input-port? read read-char peek-char eof-object?
		    char-ready? write display newline write-char load string? string string-ref string-set! string=? 
		    string-ci=? string<? string>? string<=? string>=? string-ci<? string-ci>? substring string-copy
		    vector? make-vector vector vector-ref vector-set! 
		    char? char=? char<? char>? char<=? char>=? char-ci=? char-ci<? char-ci>? char-ci<=? char-ci>=? 
		    char-upcase boolean? eqv? equal? force)]
	  [#%r4 '(#%make-promise)]
	  [r5 '(call-with-values values eval port?)]
	  [copy-env (#%lambda (l l2)
		      (#%let ([n (#%make-namespace 'empty)]
			      [all (#%make-namespace)]
			      [l (#%append l l2 (#%map (#%lambda (s) 
						          (#%string->symbol 
							   (#%string-append "#%" (#%symbol->string s)))) 
						       l))])
			 (#%parameterize ([#%current-namespace n])
			   (#%for-each
			    (#%lambda (s v) (#%global-defined-value s v))
			    l
			    (#%parameterize ([#%current-namespace all])
			      (#%map
			       (#%lambda (s) (#%global-defined-value s))
			       l))))
			 n))]
	  [make-maker
	   (#%lambda (who r5 r4 #%r4)
            (#%lambda (n)
	     (#%cond
	      [(#%eq? n 5) (copy-env (#%append r5 r4) #%r4)]
	      [(#%eq? n 4) (copy-env r4 #%r4)]
	      [(#%and (#%number? n) (#%integer? n) (#%positive? n))
	       (#%raise (#%make-exn:misc:unsupported
			 (#%string->immutable-string
			  (#%format "~s: version ~a not supported" who n))
			 (debug)))]
	      [else (#%raise-type-error who "positive integer" n)])))])
     (#%values
      (make-maker 'scheme-report-environment r5 (append r4-syntax r4) #%r4)
      (make-maker 'null-environment '() r4-syntax '()))))

> fstop report-environment null-environment <

(#%define interaction-environment #%current-namespace)

> fstop interaction-environment <
