#! /usr/local/bin/scm \ %0 %*
- !#
;;; schlep.scm: Program for translating SCM code to C
;;; Copyright (C) 1991-2006 Aubrey Jaffer and Radey Shouman
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, and to use it for any purpose is
;granted, subject to the following restrictions and understandings.
;
;1.  Any copy made of this software must include this copyright notice
;in full.
;
;2.  I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3.  In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.

;;;	  http://swissnet.ai.mit.edu/~jaffer/Docupage/schlep

;; To generate documentation:
;; schmooz schlep; makeinfo schlep.txi; cp schlep.info /usr/local/info/; install-info schlep.info /usr/local/info/dir

;;@ \input texinfo @c -*-texinfo-*-
;;@setfilename schlep.info
;;@settitle Schlep
;;@setchapternewpage on
;;@paragraphindent 0
;;@defcodeindex ft
;;@syncodeindex ft tp
;;
;;@dircategory The Algorithmic Language Scheme
;;@direntry
;;* Schlep: (schlep).     Translate SCM to C
;;@end direntry
;;
;;@node Top, Overview, (dir), (dir)
;;
;;@menu
;;* Overview::                    
;;* Scheme Syntax Translation::   
;;* Scheme Procedure Translation::  
;;* C Types and Flags::                     
;;@end menu
;;
;;@example
;;Usage: schlep [-p stdc | nil | scm] FILE1.scm FILE2.scm ...
;;Usage: schlep [-p stdc | nil | scm] FILE1.c FILE2.c ...
;;  Translates Scheme files FILE1.scm, FILE2.scm, ... to FILEn.c,
;;  FILEn.h, and FILEn.txi.
;;Usage: schlep [-p stdc | nil | scm] FILE1.h FILE2.h ...
;;  Translates Scheme files FILE1.scm, FILE2.scm, ... to FILEn.h and
;;  FILEn.txi.
;;
;;Options:
;; -p stdc        FILE*.h will have ANSI prototypes
;; -p nil         FILE*.h will have () prototypes
;; -p scm         FILE*.h will have SCM conditional prototypes
;;@end example
;;
;;@node Overview, Scheme Syntax Translation, Top, Top
;;@chapter Overview
;;
;;@dfn{Schlep} is a Scheme to C translator for a subset of Scheme.
;;Using Scheme files as source, schlep produces texinfo documentation
;;and formatted C code preserving comments; and type, function, and
;;variable names as much as possible.  The output from schlep is
;;human-readable and often forms the base for further development in C;
;;abandoning the original Scheme source.
;;
;;@quotation
;;Note that schlep is a translator -- the C code it produces will be
;;nearly as readable as the original Scheme source.  An unrelated
;;project, @uref{http://swiss.csail.mit.edu/~jaffer/hobbit_toc.html, Hobbit}
;;@dfn{compiles} full R4RS Scheme to C functions for use with the SCM
;;Scheme Implementation.
;;@end quotation
;;
;;@subheading Scope of the Scheme Subset
;;
;;Scheme integers and real numbers, booleans, chars, and strings are
;;translated to the equivalent C types.  SLIB byte vectors map to the
;;type @code{byte*} in C code.  Vectors of user defined (C) types are
;;supported.
;;
;;The user incorporates custom C data types by coding their definitions
;;and accessors in a C include file; and in a Scheme file which is not
;;translated by schlep.
;;
;;Characters in variable names are translated as follows:
;;
;;@multitable @columnfractions .2 .1 .3
;;@item @samp{%}  @tab @result{} @tab @samp{_Percent}
;;@item @samp{@@} @tab @result{} @tab @samp{_At}
;;@item @samp{:}  @tab @result{} @tab @samp{_}
;;@item @samp{-}  @tab @result{} @tab @samp{_}
;;@item @samp{?}  @tab @result{} @tab @samp{_P}
;;@end multitable
;;
;;Schlep does not include support for a Scheme runtime.  Generated C
;;programs should not assume garbage collection or general Scheme
;;values unless linked with a library providing these features.
;;
;;
;;@node Scheme Syntax Translation, Scheme Procedure Translation, Overview, Top
;;@chapter Scheme Syntax Translation
;;
;;@deffn {Syntax} quote <datum>
;;@var{<datum>}
;;@end deffn
;;
;;@deffn {Syntax} and <test1> @dots{}
;;@r{&&}, @r{if}
;;@end deffn
;;
;;@deffn {Syntax} or <test1> @dots{}
;;@r{||}, @r{if}
;;@end deffn
;;
;;@deffn {Syntax} if <test> <consequent> <alternate>
;;@r{? :}, @r{if}
;;@end deffn
;;
;;@deffn {Syntax} cond <clause1> <clause2> @dots{}
;;@r{||}, @r{if}
;;@end deffn
;;
;;@deffn {Syntax} lambda <formals> <body>
;;
;;@end deffn
;;
;;@deffn {Syntax} begin <expression1> <expression2> @dots{}
;;@r{( , )}, @r{@{ ; @}}
;;@end deffn
;;
;;@deffn {Syntax} let <bindings> <body>
;;@deffnx {Syntax} let* <bindings> <body>
;;@deffnx {Syntax} letrec <bindings> <body>
;;@r{@{ ; @}}
;;@end deffn
;;
;;@deffn {Syntax} set! <variable> <expression>
;;@r{=}
;;@end deffn
;;
;;@deffn {Syntax} do <bindings> <clause> <body>
;;@r{while}
;;@end deffn
;;
;;@deffn {Syntax} case <key> <clause1> <clause2> @dots{}
;;@deffnx {Syntax} casev <key> <clause1> <clause2> @dots{}
;;@deffnx {Syntax} qase <key> <clause1> <clause2> @dots{}
;;@r{switch}, @r{? :}
;;@end deffn
;;
;;@deffn {Syntax} define <variable> <expression>
;;Emits a variable declaration.
;;@deffnx {Syntax} define <variable> (lambda <formals> <expression>)
;;@deffnx {Syntax} define (<variable> <formals>) <body>
;;@deffnx {Syntax} define (<variable> . <formal>) <body>
;;Emits a function declaration.
;;
;;Tail recursion is converted to goto for functions tail calling
;;themselves and for functions defined using internal DEFINE.  Mutual
;;tail recursion is not optimized.  Internal functions called in
;;non-tail position are not supported.
;;@end deffn
;;
;;@deffn {Syntax} defvar <variable> <expression>
;;Emits global declaration.
;;@end deffn
;;
;;@defun defined? symbol
;;@defunx provided? feature
;;@r{#ifdef, #ifndef}
;;@end defun
;;
;;@defun provide feature
;;@r{#define}
;;@end defun
;;
;;@deffn {Syntax} defconst <constant> <expression>
;;@r{#define} in file.h
;;@end deffn
;;
;;@deffn {Syntax} defmacro
;;Invocations of DEFMACROs are expanded before translation to C.
;;@end deffn
;;
;;
;;@node Scheme Procedure Translation, C Types and Flags, Scheme Syntax Translation, Top
;;@chapter Scheme Procedure Translation
;;
;;@deffn {Procedure} defmacro:load filename
;;Inserts macroexpanded code.
;;@end deffn
;;
;;@deffn {Procedure} load filename
;;@deffnx {Procedure} require symbol
;;@r{#include}
;;@end deffn
;;
;;@defun in-vicinity vicinity filename
;;@defunx library-vicinity
;;Library includes are @r{<xxx.h>}; otherwise @r{"xxx.h"}.
;;@end defun
;;
;;@defun call-with-current-continuation proc
;;@r{goto}
;;@end defun
;;
;;@defun * z1 @dots{}
;;@r{*}
;;@end defun
;;
;;@defun + z1 @dots{}
;;@r{+}
;;@end defun
;;
;;@defun - z1 @dots{}
;;@r{-}
;;@end defun
;;
;;@defun / z1 @dots{}
;;@defunx quotient n1 n2
;;@r{/}
;;@end defun
;;
;;@defun modulo n1 n2
;;@defunx remainder n1 n2
;;@r{%}
;;@end defun
;;
;;@defun lognot n1
;;@r{~}
;;@end defun
;;
;;@defun logand n1 n2
;;@defunx logtest n1 n2
;;@r{&}
;;@end defun
;;
;;@defun logior n1 n2
;;@r{|}
;;@end defun
;;
;;@defun logxor n1 n2
;;@r{^}
;;@end defun
;;
;;@defun ash n1 n2
;;@defunx arithmetic-shift n1 n2
;;@r{<<}, @r{>>}
;;@end defun
;;
;;@defun logbit? n k
;;@r{(1<< )&}
;;@end defun
;;
;;@defun bit-field n1 n2
;;@r{(1<< )&}
;;@end defun
;;
;;@defun char-downcase char
;;@r{tolower}
;;@end defun
;;
;;@defun char-upcase char
;;@r{toupper}
;;@end defun
;;
;;@defun char->integer char
;;@r{(unsigned)}
;;@end defun
;;
;;@defun integer->char k
;;
;;@end defun
;;
;;@defun not obj
;;@r{!}
;;@end defun
;;
;;@defun < x1 x2
;;@defunx char<? char1 char2
;;@r{<}
;;@end defun
;;
;;@defun <= x1 x2
;;@defunx char<=? char1 char2
;;@r{<=}
;;@end defun
;;
;;@defun > x1 x2
;;@defunx char>? char1 char2
;;@r{>}
;;@end defun
;;
;;@defun >= x1 x2
;;@defunx char>=? char1 char2
;;@r{>=}
;;@end defun
;;
;;@defun positive? x
;;@r{0 <}
;;@end defun
;;
;;@defun negative? x
;;@r{0 >}
;;@end defun
;;
;;@defun odd? n
;;@r{&}
;;@end defun
;;
;;@defun even? n
;;@r{! &}
;;@end defun
;;
;;@defun zero? z
;;@r{!}
;;@end defun
;;
;;@defun = z1 z2
;;@defunx eq? obj1 obj2
;;@defunx eqv? obj1 obj2
;;@defunx char=? char1 char2
;;@r{==}
;;@end defun
;;
;;@defun number? obj
;;@defunx char? obj
;;always true.
;;@end defun
;;
;;@defun error obj1 obj2
;;@r{#error}
;;@end defun
;;
;;@defun current-time
;;@r{time(0L)}
;;@end defun
;;
;;@defun make-string k char
;;@defunx make-string k
;;@defunx make-bytes k integer
;;@defunx make-bytes k
;;In a define, @r{char []}; otherwise @r{(char *)malloc}.
;;@end defun
;;
;;@defun string char @dots{}
;;In a define, @r{char []}.
;;@end defun
;;
;;@defun string-length string
;;@r{strlen}
;;@end defun
;;
;;@defun string->number string
;;@r{atoi}
;;@end defun
;;
;;@defun substring string start end
;;Returns &@var{string}[@var{start}].
;;@end defun
;;
;;@deffn {Procedure} substring! string start end
;;Sets @var{string}[@var{end}] = 0 and returns &@var{string}[@var{start}].
;;@end deffn
;;
;;@defun make-bytes k1 k2
;;@defunx make-bytes k1
;;In a define, @r{byte []}; otherwise @r{(byte *)malloc}.
;;@end defun
;;
;;@defun bytes k @dots{}
;;In a define, @r{byte []}.
;;@end defun
;;
;;@defun bytes-length string
;;@r{sizeof}
;;@end defun
;;
;;@defun make-vector k fill
;;@defunx make-vector k
;;@defunx vector obj @dots{}
;;@defunx create-array prototype bound1 bound2 @dots{}
;;@defunx make-array prototype bound1 bound2 @dots{}
;;In a define, generates an array of the type as determined by the
;;variable name and inline declarations or @file{schlep.typ}; otherwise
;;a @r{malloc} cast to the type*.
;;@end defun
;;
;;@defun vector-length vector
;;@r{sizeof}
;;@end defun
;;
;;@defun vector-set-length! vector k
;;@r{realloc}.
;;@end defun
;;
;;@defun array-ref vector k
;;@defunx string-ref string k
;;@defunx byte-ref string k
;;@defunx vector-ref vector k
;;@var{vector}[@var{k}]
;;@end defun
;;
;;@deffn {Procedure} array-set! array k obj
;;@deffnx {Procedure} string-set! string k char
;;@deffnx {Procedure} byte-set! string k1 k2
;;@deffnx {Procedure} vector-set! vector k obj
;;@var{array}[@var{k}] = @var{obj}
;;@end deffn
;;
;;
;;@node C Types and Flags,  , Scheme Procedure Translation, Top
;;@chapter C Types and Flags
;;
;;Variable names are used to determine C types of variables.

;;; SLIB modules.
(require 'common-list-functions)	;some
(require 'string-search)
(require 'line-i/o)			;READ-LINE
(require 'byte)
(require 'printf)
(require 'filename)
(require 'fluid-let)
(require 'string-case)
(require 'defmacroexpand)
;;(require 'debug) (set! *qp-width* 100) (define qreport qpn)

(define (schlep.usage)
  (display "\
\
Usage: schlep [-p stdc | nil | scm] FILE1.scm FILE2.scm ...
Usage: schlep [-p stdc | nil | scm] FILE1.c FILE2.c ...
\
  Translates Scheme files FILE1.scm, FILE2.scm, ... to FILEn.c,
  FILEn.h, and FILEn.txi.
Usage: schlep [-p stdc | nil | scm] FILE1.h FILE2.h ...
\
  Translates Scheme files FILE1.scm, FILE2.scm, ... to FILEn.h and
  FILEn.txi.

Options:
 -p stdc        FILE*.h will have ANSI prototypes
 -p nil         FILE*.h will have () prototypes
 -p scm         FILE*.h will have SCM conditional prototypes

http://swiss.csail.mit.edu/~jaffer/Docupage/schlep
"
	   (current-error-port))
  #f)

(define (schlep.script args)
  (cond ((not (<= 1 (length args)))
	 (schlep.usage))
	((string=? "-p" (car args))
	 (cond ((null? (cdr args)) (schlep.usage))
	       ((string-ci=? "stdc" (cadr args))
		(prototype-style 'stdc)
		(schlep.script (cddr args)))
	       ((string-ci=? "nil" (cadr args))
		(prototype-style 'nil)
		(schlep.script (cddr args)))
	       ((string-ci=? "scm" (cadr args))
		(prototype-style 'scm)
		(schlep.script (cddr args)))
	       (else (schlep.usage))))
	((and (<= 1 (string-length (car args)))
	      (eqv? #\- (string-ref (car args) 0)))
	 (schlep.usage))
	(else
	 (apply schlep args))))

;;; REPORT an error or warning
(define report
  (lambda args
    (display *schlep-input-name*)
    (display ": In function `")
    (display *procedure*)
    (display "': ")
    (newline)

    (display *schlep-output-name*)
    (display ": ")
    (display *output-line*)
    (display ": warning: ")
    (apply qreport args)))

(define qreport
  (lambda args
    (for-each (lambda (x) (write x) (display #\space)) args)
    (newline)))

;;; This allows us to test without generating files
(define *schlep-input* (current-input-port))
(define *schlep-output* (current-output-port))
(define *prototype-output* (current-output-port))
(define *schlep-input-name* "stdin")
(define *schlep-output-name* "?")
(define *documentation-output* (current-output-port))

;; slib:features is fluid-let so Scheme session is not screwed up.
(define schlep:features (cons 'schlep slib:features))
(define *included-files* '())
(define *label-list* '())		;Lexically active labels
(define *procedure* #f)
(define *output-line* 0)
(define tokcntr 0)

;; Don't indent on freshline -- continue on current line.
(define CONTLINE -80)
;; What is this for?
(define EXTERN 'EXTERN)

;; These are the possible values of @var{use} arguments to
;; @code{schlep-exp}.
(define VOID 'VOID)
(define VAL 'VAL)
(define LONG 'LONG)
(define BOOL 'BOOL)

;; These are types and type-modifiers which Schlep treats specially.
(define INT 'INT)
(define LONG 'LONG)
(define PTR 'PTR)
(define ARRAY 'ARRAY)

;; These are the possible values of @var{termin} arguments to
;; @code{schlep-exp}.
(define RETURN "return")
(define NONE "")
(define COMMA ",")
(define SEMI ";")
(define SUBSCRIPT "]")

;;@body The C types to which variables are translated are controlled
;;by @0.  A declaration is a list @code{(glob type)}.  @var{glob} is a
;;string; @var{type} an expression.  @var{Glob}es are matched to
;;variable names with trailing digits removed.  Declarations made
;;later override those made earlier.
;;
;;Declarations can be made by a call to @code{declare-names}.  If
;;no declarations have been made before @code{schlep} is called,
;;@code{schlep} will read a list of declarations from a file named
;;@file{schlep.typ} if it exists in the same directory as the Scheme
;;file being translated.
;;
;;If the @var{type} is a symbol or string, variables which match
;;the glob string will be declared as types of that name.  If the
;;@var{type} is a list, then it will be interpreted as follows.
;;
;;@table @code
;;@item (ptr @var{type})
;;produces @code{* @var{type}}.
;;@item (array @var{type})
;;produces @code{@var{type}[]}.
;;
;;@end table
;;
;;Types can be nested.  Procedure names ending with @samp{!} are typed
;;to return @code{void}.  Procedure names ending with @samp{?} are
;;translated to names with a trailing @samp{_P}.
;;
(define declarations '())

;;@noindent
;;These procedures can be mixed with code to be translated.

;;@body @1 must be a list of lists (declarations).  Glob
;;declarations may have local scope.  Glob declarations at
;;top level persist from one file to the next.
(define (declare-names! globs)
  (for-each (lambda (glob)
	      (or (and (pair? glob)
		       (= 2 (length glob)))
		  (report "bad syntax" glob))
	      (declare-name! (car glob) (cadr glob)))
	    globs))

;;@noindent
;;The Scheme files in the table at
;;@url{http://swiss.csail.mit.edu/~jaffer/CNS/benchmarks.html#PRNG}
;;have examples of the use of @code{declare-names!}.

(define (declare-name! glob ctype)
  (if (symbol? glob) (set! glob (symbol->string glob)))
  (let (	      ; CADDR is count per file, CADDDR is cumulative.
	(entry (list (filename:match?? glob) glob ctype 0 0)))
    (let loop ((typs declarations))
      (cond ((null? typs)
	     (set! declarations
		   (append declarations (list (list entry)))))
	    (else
	     (set-cdr! typs (cons (car typs) (cdr typs)))
	     (set-car! typs (list entry)))))))

(define (read-local-declarations vic)
  (let ((typfile (in-vicinity vic "schlep.typ")))
    (cond ((file-exists? typfile)
	   (set! declarations '())
	   (display "Reading type declarations from ")
	   (display typfile)
	   (newline)
	   (declare-names! (call-with-input-file typfile read))
	   #t)
	  (else #f))))

(define (read-version revfile)
  (and (file-exists? revfile)
       (call-with-input-file
	   revfile (lambda (port)
		     (and (find-string-from-port? "VERSION" port)
			  (read port))))))

;;@body In Scheme source, @0 has no effect, but the @1 are written to
;;@var{filename}.h during translation.
(define (pragma.h . strings) #f)

;;@body In Scheme source, @0 has no effect, but the @1 are written to
;;@var{filename}.c during translation.
(define (pragma.c . strings) #f)

(define (strip-quote expr)
  (if (and (pair? expr) (eq? 'quote (car expr)))
      (cadr expr)
      expr))

(defvar __STDC__ #t)

;;@body Sets the type of prototypes written to the .h files.  Make @1
;;the symbol STDC for ANSI function prototypes; SCM for SCM
;;conditional prototypes; NIL for K&R C.  The default value is STDC.
;;
;;To work with the conditional prototypes, an include file loaded
;;before the .h files should contain:
;;
;;@example
;;#ifndef SCM_EXPORT
;;# define SCM_EXPORT extern
;;#endif
;;
;;#ifndef P
;;# ifdef __STDC__
;;#  ifndef __HIGHC__
;;#   define USE_ANSI_PROTOTYPES
;;#  endif
;;# endif
;;# ifdef __sgi__
;;#  define USE_ANSI_PROTOTYPES
;;# endif
;;
;;# ifdef USE_ANSI_PROTOTYPES
;;#  define P(s) s
;;# else
;;#  define P(s) ()
;;# endif
;;#endif
;;@end example
(define (prototype-style style)
  (set! __STDC__
	(case style
	  ((NIL () #f) #f)
	  ((__STDC__ STDC) #t)
	  ((SCM) 'SCM))))

;; @body Returns a string describing the current input-file and
;; line-number, if that information is known.  @0 would only be useful
;; as a read-macro in the file being translated:
;;
;; @example
;; #.(where)
;; @end example
(define (where)
  (string-append (or (port-filename *schlep-input*)
		     *schlep-input-name*)
		 ":"
		 (cond ((port-line *schlep-input*) => number->string)
		       (else "??"))
		 ": "))

;;These variables control file translation.  They have no effect from
;;the file being translated, unless they are defined using
;;read-macros: @code{#.(define number-lines? #t)}.

;;@body
;;Define @0 to #t for C code to be prefixed with commmented line
;;numbers.  The default value is #f.
(defvar number-lines? #f)

;;@noindent
;;The following procedures are called to translate a file.
;;They should @emph{not} be called from the file being translated.

;;@body Translates scheme files to C.  Each argument must be a
;;string.  If the @var{suffix} is:
;;
;;@table @samp
;;@item scm
;;@itemx c
;;Produces files @var{filename}.c, @var{filename},h, and @var{filename}.txi.
;;@item h
;;Produces files @var{filename}.h and @var{filename}.txi.
;;
;;@end table
;;
;;Otherwise, the file named by the argument @var{filename} is translated to
;;@var{filename}.c, @var{filename},h, and @var{filename}.txi.
;;
;;If @var{filename}.txi is empty after translation, then it is deleted.
(define (schlep . filenames)
  (for-each (lambda (filename)
	      (let* ((sufind (string-reverse-index filename #\.))
		     (suffix (and sufind
				  (substring filename sufind
					     (string-length filename)))))
		(cond ((not sufind)
		       (schlep1 filename ".c"))
		      ((string-ci=? ".h" suffix)
		       (schlep1 (substring filename 0 sufind) suffix))
		      ((string-ci=? ".c" suffix)
		       (schlep1 (substring filename 0 sufind) suffix))
		      ((substring-ci? ".scm" suffix)
		       (schlep1 (substring filename 0 sufind) ".c"))
		      (else
		       (schlep1 filename ".c")))))
	    filenames)
  (do-includes)
  #t)

;;@body Prints an association-list (suitable passing to
;;@code{declare-name!}) along with the counts of references to each
;;name pattern type declared.
(define (declarations-report! cumulative? port)
  (define cum-uses cadddr)
  (define set-cum-uses! (lambda (arg n) (set-car! (cdddr arg) n)))
  (define file-uses caddr)
  (define set-file-uses! (lambda (arg n) (set-car! (cddr arg) n)))
  (cond ((string? port)
	 (call-with-output-file port
	   (lambda (port)
	     (declarations-report! cumulative? port))))
	(cumulative?
	 (display ";; schlep.typ\n" port)
	 (display "(" port)
	 (for-each (lambda (arg)
		     (set! arg (cdr arg))
		     (let ((uses (+ (cum-uses arg)
				    (file-uses arg))))
		       (cond ((positive? uses)
			      (fprintf port "\n (%#-6a %#-20a)"
				       (car arg) (cadr arg))
			      (set-cum-uses! arg 0)
			      (set-file-uses! arg 0)
			      (fprintf port " ;; %d uses" uses)))))
		   (reverse (apply append declarations)))
	 (display "\n )\n" port))
	(else
	 (display "#+schlep\n" port)
	 (display "(declare-names" port)
	 (for-each (lambda (arg)
		     (set! arg (cdr arg))
		     (let ((uses (file-uses arg)))
		       (cond ((positive? uses)
			      (fprintf port "\n (%#-6a %#-20a)"
				       (car arg) (cadr arg))
			      (set-file-uses! arg 0)
			      (set-cum-uses! arg (+ (cum-uses arg) uses))
			      (fprintf port " ;; %d uses" uses)))))
		   (reverse (apply append declarations)))
	 (display "\n )\n" port))))

;;;;			 Internal procedures

(define (careful-for-each proc lst)
  (do ((lst lst (cdr lst)))
      ((not (pair? lst))
       (if (not (null? lst)) (proc lst)))
    (proc (car lst))))

;; Indents and displays its arguments.
(define (out indent . args)
  (cond ((>= indent 0)
	 (newline *schlep-output*)
	 (set! *output-line* (+ 1 *output-line*))
	 (cond ((and number-lines? (> indent 0))
		(display "/*" *schlep-output*)
		(display *output-line* *schlep-output*)
		(display "*/" *schlep-output*)))
	 (do ((j indent (- j 8)))
	     ((> 8 j)
	      (do ((i j (- i 1)))
		  ((>= 0 i))
		(display #\space *schlep-output*)))
	   (display slib:tab *schlep-output*))))
  (careful-for-each
   (lambda (a)
     (cond ((symbol? a)
	    (c-ify-symbol a *schlep-output*))
	   ((string? a)
	    (display a *schlep-output*)
	    (cond (#f (string-index a #\nl)
		      (set! *output-line* (+ 1 *output-line*))
		      (report "newline in string" a))))
	   (else
	    (if (and (number? a) (negative? a))
		(display #\space *schlep-output*))
	    (display a *schlep-output*))))
   args))

;; Removes or translates characters from @1 and displays to @2
(define (c-ify-string name port)
  (define visible? #f)
  (for-each
   (lambda (c)
     (let ((tc (cond ((char-alphabetic? c) c)
		     ((char-numeric? c) c)
		     ((char=? c #\%) "_Percent")
		     ((char=? c #\@) "_At")
		     ((char=? c #\=) "Eql")
		     ((char=? c #\:) #\_)
		     ((char=? c #\-) #\_)
		     ((char=? c #\_) #\_)
		     ((char=? c #\>) "to_")
		     ((char=? c #\?) "_P")
		     ((char=? c #\.) ".")
		     (else #f))))
       (cond (tc (set! visible? #t) (display tc port)))))
   (string->list name))
  (if (not visible?) (report "C-invisible symbol?" name)))
(define (c-ify-symbol name port)
  (c-ify-string (symbol->string name) port))

;; Makes a temporary variable name.
(define (tmpify sym)
  (string->symbol (string-append "T_" (symbol->string sym))))

;; Makes a label name.
(define (lblify sym)
  (string->symbol (string-append "L_" (symbol->string sym))))

(define (assoc-if str alst)
  (cond ((null? alst) #f)
	(((caar alst) str) (car alst))
	(else (assoc-if str (cdr alst)))))

;;; VARTYPE gives a guess for the type of var
(define (vartype var)
  (define (suffix->ctype str len)
    (let loop ((typs declarations))
      (and (pair? typs)
	   (let* ((match (assoc-if (substring str 0 len) (car typs))))
	     (cond (match
		    (set! match (cdr match))
		    (set-car! (cddr match) (+ 1 (caddr match)))
		    match)
		   (else
		    (loop (cdr typs))))))))
  (let* ((str (symbol->string var))
	 (len (string-length str)))
    (do ((i len (+ -1 i)))
	((not (char-numeric? (string-ref str (+ -1 i)))) (set! len i)))
    (cond ((eqv? 0 (substring? "T_" str))
	   (set! str (substring str 2 len))
	   (set! len (+ -2 len))))
    (let ((v (suffix->ctype str len)))
      (cond ((and (not v) (char=? #\? (string-ref str (+ -1 len)))) BOOL)
	    ((not v) 'INT)
	    ((and (memq (cadr v) '(ARRAY PTR)) (>= len 4))
	     (let ((c (string-ref str (- len 4))))
	       (list (cadr v)
		     (vartype (string->symbol
			       (substring str 0
					  (if (memv c '(#\- #\: #\_))
					      (- len 4)
					      (- len 3))))))))
	    ((and (eq? (cadr v) 'WORD)
		  (>= len 5)
		  (string-ci=? "dword" (substring str (+ -5 len) len)))
	     'DWORD)
	    ((cadr v) (cadr v))
	    (else INT)))))

;;; PROCTYPE - gives a guess for the type of proc
(define (proctype proc)
  (let ((str (symbol->string proc)))
    (case (string-ref str (- (string-length str) 1))
      ((#\?) BOOL)
      ((#\!) VOID)
      (else (or (vartype proc)
		(begin (report "unknown type" proc)
		       VAL))))))

(define (type->exptype type)
  (case type
    ((VOID BOOL LONG) type)
    (else VAL)))

(define (outtype-aux doc? indent type name val)
  (cond ((symbol? type)
	 (let ((typestr
		(case type
		  ((BOOL) "int")
		  ((VAL) "SCM")
		  (else type))))
	   (if doc?
	       (out indent "{" typestr "} " name)
	       (out indent typestr #\space name))
	   #t))
	((string? type)
	 (if doc?
	     (out indent "{" type "} " name)
	     (out indent type #\space name)))
	((pair? type)
	 (case (car type)
	   ((PTR)
	    (cond (doc?
		   (out indent "{")
		   (outtype-aux #f CONTLINE (cadr type) NONE VOID)
		   (out CONTLINE "*} " name)
		   #t)
		  (else
		   (outtype-aux #f indent (cadr type) NONE VOID)
		   (out CONTLINE "*" name)
		   #t)))
	   ((ARRAY)
	    (cond ((and (pair? val)
			(memq (car val)
			      '(MAKE-VECTOR MAKE-STRING MAKE-BYTES))
			(pair? (cdr val))
			(null? (cddr val)))
		   (outtype-aux doc? indent (cadr type) NONE VOID)
		   (out CONTLINE name "[")
		   (schlep-exp SUBSCRIPT INT indent (cadr val))
		   #f)
		  ((and (pair? val)
			(memq (car val) '(MAKE-VECTOR MAKE-BYTES))
			(pair? (cdr val))
			(or (null? (cddr val))
			    (zero? (caddr val))))
		   (outtype-aux doc? indent (cadr type) NONE VOID)
		   (out CONTLINE name "[")
		   (schlep-exp SUBSCRIPT INT indent (cadr val))
		   (if (not (null? (cddr val)))
		       (out CONTLINE "= {0}"))
		   #f)
		  ((or (and (pair? val)
			    (memq (car val) '(VECTOR STRING BYTES)))
		       (string? val)
		       (vector? val)
		       (eq? val EXTERN))
		   (outtype-aux doc? indent (cadr type) NONE VOID)
		   (out CONTLINE name "[]")
		   #t)
		  (else
		   (outtype-aux doc? indent (cons 'PTR (cdr type)) name VOID)
		   #t)))
	   ((FUNCTION)
	    (out indent (string-append
			 ((if (symbol? (cadr type)) symbol->string identity)
			  (cadr type))
			 "_function ")
		 name)
	    #f)
;;;	   ((FUNCTION)
;;;	    (outtype indent (cadr type) NONE VOID)
;;;	    (out CONTLINE "(*" name ")()") #f)
	   (else (report "unknown type" type name) #f)))
	(else (report "unknown type" type name) #f)))

(define (outtype indent type name val)
  (outtype-aux #f indent type name val))

(define (outtype-doc indent type name val)
  (outtype-aux #t indent type name val))

;;; OUTBINDING - indents and prints out local binding
(define (outbinding indent b)
  (let ((type (vartype (car b))))
    (cond ((var-involved? (car b) (cadr b))
	   (report "rebinding variable" b)
	   (outtmpbnd indent (car b) (cadr b))
	   (outuntmpbnd indent (car b)))
	  ((outtype indent type (car b) (cadr b))
	   (out CONTLINE " = ")
	   (schlep-exp SEMI (type->exptype type) indent (cadr b)))
	  (else
;;;	   (report "var can't be assigned" b)
	   (out CONTLINE SEMI)))))

;;; OUTBINDINGS - indents and prints out local bindings
(define (outbindings indent b)
  (for-each (lambda (b) (outbinding indent b)) b))

(define (outtmpbnd indent var val)
  (let ((type (vartype var)))
    (cond ((outtype indent type (tmpify var) val)
	   (out CONTLINE " = ")
	   (schlep-exp SEMI (type->exptype type) indent val))
	  (else
	   (report "temp can't be assigned" var val)
	   (out CONTLINE SEMI)))))

(define (outuntmpbnd indent var)
  (outtype indent (vartype var) var VOID)
  (out CONTLINE " = " (tmpify var) SEMI))

;;; OUTLETBINDINGS - indents and prints out local simultaneous bindings
(define (outletbindings indent bindings types?)
  (if (not (null? bindings))
      (let* ((vars (map car bindings))
	     (exps (map cadr bindings))
	     (invol (map
		     (lambda (b)
		       (if types?
			   (var-involved? (car b) (map cadr bindings))
			   (var-involved-except?
			    (car b) (map cadr bindings) (cadr b))))
		     bindings)))
	(for-each
	 (lambda (v b i) (if i (outtmpbnd indent (car b) (cadr b))))
	 vars bindings invol)
;;;	(if types? (outbinding indent (car bindings))
;;;	    (let ((vtype (vartype (caar bindings))))
;;;	      (out indent (caar bindings) " = ")
;;;	      (schlep-exp SEMI (type->exptype vtype) indent (cadar bindings))))

	(for-each
	 (lambda (v b i)
	   (let ((type (vartype (car b))))
	     (cond (i)
		   ((not types?)
		    (out indent (car b))
		    (out CONTLINE " = ")
		    (schlep-exp SEMI (type->exptype type) indent (cadr b)))
		   ((outtype indent type (car b) (cadr b))
		    (out CONTLINE " = ")
		    (schlep-exp SEMI (type->exptype type) indent (cadr b)))
		   (else		;(report "can't initialize" b)
		    (out CONTLINE SEMI)))))
	 vars bindings invol)
	(for-each
	 (lambda (v b i)
	   (let ((type (vartype (car b))))
	     (cond (i (if types? (outuntmpbnd indent v)
			  (out indent v " = " (tmpify v) SEMI))))))
	 vars bindings invol))))

(define (var-involved-except? var sexps own)
  (if (null? sexps) #f
      (if (eq? (car sexps) own)
	  (var-involved-except? var (cdr sexps) own)
	  (or (var-involved? var (car sexps))
	      (var-involved-except? var (cdr sexps) own)))))

(define (var-involved? var sexp )
  (if (pair? sexp)
      (or (var-involved? var (car sexp))
	  (var-involved? var (cdr sexp)))
      (eq? sexp var)))

(define (outcomment indent str)
  (cond ((string-index str #\nl)
	 (set! *output-line* (+ 1 *output-line*))
	 (report "newline in comment" str)))
  (out indent "/*" str "*/"))

(define (descmfilify file)
  (let ((sl (string-length file)))
    (cond ((< sl 4) file)
	  ((string-ci=? (substring file (- sl 4) sl) ".scm")
	   (substring file 0 (- sl 4)))
	  (else file))))

(define (out-include spec)
  (cond ((and (pair? spec) (eq? (car spec) 'quote) (symbol? (cadr spec))))
	(else
	 (out 0 "#include ")
	 (cond ((not (pair? spec))
		(out CONTLINE "\"" (descmfilify spec) ".h\""))
	       ((and (eq? 'IN-VICINITY (car spec))
		     (eq? 'LIBRARY-VICINITY (caadr spec)))
		(out CONTLINE "<" (descmfilify (caddr spec)) ".h>"))
	       (else
		(out CONTLINE "\"" (descmfilify (caddr spec)) ".h\"")
		(if (not (member (caddr spec) *included-files*))
		    (set! *included-files*
			  (cons (caddr spec) *included-files*)))))
	 (out 0))))

(define (do-includes)
  (cond ((not (null? *included-files*))
	 (display "include files are:") (newline)
	 (for-each (lambda (f) (write f) (newline)) *included-files*)
	 (set! *included-files* ())))
  (newline) (display "done.") (newline))

(define (out-c-cmt line)
  (display "/* " *schlep-output*)
  (display line *schlep-output*)
  (set! *output-line* (+ 1 *output-line*))
  (display " */" *schlep-output*)
  (newline *schlep-output*))

(define (out-sharpdef expr)
  (cond ((and (pair? expr)
	      (eq? 'QUOTE (car expr))
	      (symbol? (cadr expr))
	      (null? (cddr expr)))
	 (set! schlep:features
	       (cons (cadr expr) schlep:features))
	 (out 0 "#define ")
	 (c-ify-string
	  (string-upcase (symbol->string (cadr expr)))
	  *schlep-output*))))

;; Substitute @ macros in string LINE.
;; Returns a list of strings, the first is the substituted version
;; of LINE, the rest are "@cindex " directives for Texinfo.
;; MACS is an alist of (macro-name . macro-value) pairs.
(define (document-substitute line macs)
  (define (get-word i)
    (let loop ((j (+ i 1)))
      (cond ((>= j (string-length line))
	     (substring line i j))
	    ((or (char-alphabetic? (string-ref line j))
		 (char-numeric? (string-ref line j)))
	     (loop (+ j 1)))
	    (else (substring line i j)))))
  ;;Return (next-char-number . list-of-arguments)
  (define (get-args i)
    (let skip ((i i))
      (cond ((>= i (string-length line)) #f)
	    ((char-whitespace? (string-ref line i))
	     (skip (+ i 1)))
	    ((eqv? (string-ref line i) #\{)
	     (let loop-args ((i (+ i 1))
			     (args '()))
	       (let loop ((j i))
		 (if (>= j (string-length line))
		     #f	;;error
		     (case (string-ref line j)
		       ((#\,)
			(loop-args (+ j 1)
				   (cons (substring line i j) args)))
		       ((#\})
			(cons (+ j 1)
			      (reverse (cons (substring line i j) args))))
		       (else (loop (+ j 1))))))))
	    (else #f))))
  (define (c-ify string)
    (call-with-output-string
	(lambda (p)
	  (c-ify-string
	   (if (char=? #\' (string-ref string 0))
	       (string-upcase
		(substring string 1 (string-length string)))
	       (string-downcase string))
	   p))))
  (let loop ((istrt 0)
	     (i 0)
	     (res '())
	     (idxs '()))
    (cond ((>= i (string-length line))
	   (cons (apply string-append
			(reverse
			 (cons (substring line istrt (string-length line))
			       res)))
		 idxs))
	  ((char=? #\@ (string-ref line i))
	   (let* ((w (get-word i))
		  (symw (string->symbol w)))
	     (cond ((eq? '@cname symw)
		    (let ((args (get-args (+ i (string-length w)))))
		      (cond ((and args (= 2 (length args)))
			     (loop (car args) (car args)
				   (cons
				    (string-append
				     "@code{" (c-ify (cadr args)) "}")
				    (cons (substring line istrt i) res))
				   idxs))
			    (else
			     (report "@cname wrong number of args" line)
			     (loop istrt (+ i (string-length w)) res idxs)))))
		   ((eq? '@dfn symw)
		    (let* ((args (get-args (+ i (string-length w))))
			   (inxt (car args))
			   (args (cdr args)))
		      (loop inxt inxt
			    (cons (substring line istrt inxt) res)
			    (cons (string-append "@cindex " (car args))
				  idxs))))
		   ((assq symw macs) =>
		    (lambda (s)
		      (if (not (cdr s))
			  (report "Ambiguous argument macro" symw))
		      (loop (+ i (string-length w))
			    (+ i (string-length w))
			    (cons (or (cdr s) "??")
				  (cons (substring line istrt i) res))
			    idxs)))
		   (else
		    (if (string->number (substring w 1 (string-length w)))
			(report "Unmatched argument macro" symw))
		    (loop istrt (+ i (string-length w)) res idxs)))))
	  (else (loop istrt (+ i 1) res idxs)))))


;; Alist for argument macro definitions.
(define (document-args->macros args xargs)
  (define (c-ify sym)
    (call-with-output-string
	(lambda (p) (c-ify-symbol sym p))))
  (define (merge-args args1 args2 . argsn)
    (if (pair? argsn)
	(apply merge-args (merge-args args1 args2) argsn)
	(let loop ((a1 (cdr args1))
		   (a2 (cdr args2))
		   (res (list (car args1))))
	  (cond ((null? a1)
		 (append (reverse res) a2))
		((null? a2)
		 (append (reverse res) a1))
		((eq? (car a1) (car a2))
		 (loop (cdr a1) (cdr a2) (cons (car a1) res)))
		(else
		 (loop (cdr a1) (cdr a2) (cons #f res)))))))
  (let ((args (if (pair? xargs)
		  (apply merge-args args xargs)
		  args)))
    (let ((m0 (and (car args)
		   (string-append "@code{" (c-ify (car args)) "}"))))
      `((@arg0 . ,m0)
	(@0 . ,m0)
	,@(let recur ((i 1)
		      (args (cdr args)))
	    (if (null? args) '()
		(let ((s (number->string i))
		      (m (and (car args)
			      (string-append "@var{"
					     (c-ify (car args)) "}"))))
		  `((,(string->symbol (string-append "@" s)) . ,m)
		    (,(string->symbol (string-append "@arg" s)) . ,m)
		    ,@(recur (+ i 1) (cdr args))))))))))

(define (document-fun sexp body xdefs)
  (define (out-header sexp op)
    (let ((fun (caadr sexp))
	  (args (cdadr sexp)))
      (out 0 op)
      (outtype-doc CONTLINE (proctype fun) fun VOID)
      (out CONTLINE " (")
      (if (pair? args)
	  (let loop ((args args))
	    (outtype-doc CONTLINE (vartype (car args)) NONE VOID)
	    (out CONTLINE "@var{" (car args) "}")
	    (cond ((pair? (cdr args))
		   (out CONTLINE COMMA)
		   (out CONTLINE #\space)
		   (loop (cdr args))))))
      (out CONTLINE ")")))
  (let* ((mac-list (document-args->macros (cadr sexp) (map cadr xdefs)))
	 (lines (map (lambda (bl) (document-substitute bl mac-list))
		     body)))
    (fluid-let ((*schlep-output* *documentation-output*)
		(*output-line* *output-line*))
      (out-header sexp "@deftypefun ")
      (for-each (lambda (def)
		  (out-header def "@deftypefunx "))
		xdefs)
      (for-each (lambda (line) (out 0 line)) (apply append lines))
      (out 0 "@end deftypefun")
      (out 0))
    (for-each (lambda (line) (out-c-cmt (car line))) lines)))

(define (document-var sexp body xdefs)
  (let* ((name (cadr sexp))
	 (mac-list (document-args->macros (list name) '()))
	 (lines
	  (map (lambda (bl) (document-substitute bl mac-list)) body)))
    (fluid-let ((*schlep-output* *documentation-output*)
		(*output-line* *output-line*))
      (out 0 "@deftypevar ")
      (outtype-doc CONTLINE (vartype name) name
		   (and (caddr sexp) 'EXTERN))
      (let loop ((xdefs xdefs))
	(if (pair? xdefs)
	    (let ((sexp (car xdefs)))
	      (and (pair? sexp)
		   (eq? (car sexp) 'DEFINE)
		   (pair? (cdr sexp))
		   (symbol? (cadr sexp)))
	      (out 0 "@deftypevarx ")
	      (outtype-doc CONTLINE (vartype (cadr sexp)) (cadr sexp)
			   (and (caddr sexp) 'EXTERN))
	      (loop (cdr xdefs)))))
      (for-each (lambda (line) (out 0 line)) (apply append lines))
      (out 0 "@end deftypevar")
      (out 0))
    (for-each (lambda (line) (out-c-cmt (car line))) lines)))

(define (document-h-def sexp body xdefs)
  (define (out-const sexp op)
    (out 0 op "{C Preprocessor Constant} ")
    (outtype CONTLINE (cadr sexp) NONE VOID))
  (define (out-macro sexp op)
    (out 0 op "{C Preprocessor Macro} ")
    (out CONTLINE (caadr sexp))
    (out CONTLINE " (")
    (if (pair? (cdadr sexp))
	(let loop ((args (cdadr sexp)))
	  (out CONTLINE "@var{" (car args) "}")
	  (cond ((pair? (cdr args))
		 (out CONTLINE COMMA)
		 (out CONTLINE #\space)
		 (loop (cdr args))))))
    (out CONTLINE ")"))
  (if (pair? (cadr sexp))
      (let* ((mac-list
	      (document-args->macros (cadr sexp) (map cadr xdefs)))
	     (lines
	      (map (lambda (bl) (document-substitute bl mac-list)) body)))
	(fluid-let ((*schlep-output* *documentation-output*)
		    (*output-line* *output-line*))
	  (out-macro sexp "@deffn ")
	  (for-each (lambda (s) (out-macro s "@deffnx ")) xdefs)
	  (for-each (lambda (line) (out 0 line)) (apply append lines))
	  (out 0 "@end deffn")
	  (out 0))
	(for-each (lambda (line) (out-c-cmt (car line))) lines))
      (let* ((mac-list
	      (document-args->macros (list (cadr sexp)) '()))
	     (lines
	      (map (lambda (bl) (document-substitute bl mac-list)) body)))
	(fluid-let ((*schlep-output* *documentation-output*)
		    (*output-line* *output-line*))
	  (out-const sexp "@defvr ")
	  (for-each (lambda (s) (out-const s "@defvrx ")) xdefs)
	  (for-each (lambda (line) (out 0 line)) (apply append lines))
	  (out 0 "@end defvr")
	  (out 0))
	(for-each (lambda (line) (out-c-cmt (car line))) lines))))

;;; SCHLEP1 - schlep file.scm to file.suffix
(define (schlep1 file suffix)
  (define ifile (string-append file ".scm"))
  (define ofile (string-append file suffix))
  (define texname (string-append file ".txi"))
  (cond ((not (file-exists? ifile))
	 (schlep.usage)
	 (slib:error 'schlep1 ifile 'not 'found)))
  (if (null? declarations)
      (or (read-local-declarations (pathname->vicinity file))
	  (report "No schlep.typ file found, all variables will be int")))
  (fluid-let ((*schlep-input* (open-file ifile "r?"))
	      (*schlep-output* (open-file ofile "w?"))
	      (*schlep-input-name* ifile)
	      (*schlep-output-name* ofile)
	      (*documentation-output*
	       (let ()
		 (display "Texinfo documentation -> ") (write texname) (newline)
		 (open-file texname "w")))
	      (*schlep-defmacros* *schlep-defmacros*)
	      (schlep:features (cons 'schlep slib:features))
	      (declarations declarations))
    (cond ((string-ci=? ".c" suffix)
	   (if __STDC__ (display "ANSI "))
	   (display "prototypes -> ")
	   (write (string-append file ".h"))
	   (newline)
	   (set! *prototype-output*
		 (open-file (string-append file ".h") "w"))))
    (set! *output-line* 1)
    (set! tokcntr 0)
    (cond ((string-ci=? ".c" suffix)
	   (schlep-tops schlep-top)
	   (cond			; debugging stuff for Jonathan
	    (#f (eq? 'MS-DOS (software-type)) ; For MS-DOS only.
		(out 0 "void last_routine_in_" file "(FILE *fp)")
		(out 0 "{")
		(out 1 "fprintf(fp,\"last_routine_in_"
		     file " %x:%x\\n\",")
		(out 10 "FP_SEG(last_routine_in_" file "),")
		(out 10 "FP_OFF(last_routine_in_" file "));")
		(out 0 "}")
		(out 0))))
	  (else (schlep-tops schlep-h-top)))
    (close-input-port *schlep-input*)
    (close-output-port *schlep-output*)
    (cond ((string-ci=? ".c" suffix)
	   (close-output-port *prototype-output*)
	   (set! *prototype-output* (current-output-port))
	   (declarations-report! #f (current-output-port))))
    (close-output-port *documentation-output*)
    (if (eof-object? (call-with-input-file texname read-char))
	(delete-file texname))))

(define (schlep-read port)
  (fluid-let ((slib:features schlep:features))
    (let ((expr (read port)))
      (cond ((not (pair? expr)) expr)
	    (else
	     (case (car expr)
	       ((DECLARE-NAMES! PROTOTYPE-STYLE)
		(apply (slib:eval (car expr)) (map strip-quote (cdr expr)))
		"")
	       (else expr)))))))

;;; SCHLEP-TOPS - schlep top level forms.
(define (schlep-tops schlep-top)
  (let ((doc-lines '()))
    (define (tok1 line)
      (let loop ((i 0))
	(cond ((>= i (string-length line)) line)
	      ((or (char-whitespace? (string-ref line i))
		   (char=? #\; (string-ref line i)))
	       (substring line 0 i))
	      (else (loop (+ i 1))))))
    (define (skip-ws line)
      (do ((i 0 (+ i 1)))
	  ((or (>= i (string-length line))
	       (not (memv (string-ref line i)
			  '(#\space #\tab #\;))))
	   (substring line i (string-length line)))))
    (define (read-cmt-line)
      (cond ((eqv? #\; (peek-char *schlep-input*))
	     (read-char *schlep-input*)
	     (read-cmt-line))
	    (else (read-line *schlep-input*))))
    (define (read-newline)
      (if (char=? #\cr (read-char *schlep-input*))
	  (if (char=? #\nl (peek-char *schlep-input*))
	      (read-char *schlep-input*)
	      (report "stranded #\\cr"))))
    (define (lp c)
      (cond ((eof-object? c)
	     (cond ((pair? doc-lines)
		    (report "No definition found for @body doc lines"
			    (reverse doc-lines)))))
	    ((memv c '(#\cr #\nl))
	     (read-newline)
	     (set! *output-line* (+ 1 *output-line*))
	     (newline *schlep-output*)
	     (lp (peek-char *schlep-input*)))
	    ((char-whitespace? c)
	     (write-char (read-char *schlep-input*) *schlep-output*)
	     (lp (peek-char *schlep-input*)))
	    ((char=? c #\;)
	     (c-cmt c))
	    (else
	     (sx))))
    (define (sx)
      (let* ((s1 (schlep-read *schlep-input*))
	     ;;Read all forms separated only by single newlines.
	     (ss (let recur ()
		   (case (peek-char *schlep-input*)
		     ((#\cr #\space #\tab) (read-char *schlep-input*) (recur))
		     ;; Ignore trailing comments
		     ((#\;) (read-char *schlep-input*)
		      (let skip ((c (peek-char *schlep-input*)))
			(cond ((eqv? #\nl c) (recur))
			      ((not (char? c)) '())
			      (else (read-char *schlep-input*)
				    (skip (peek-char *schlep-input*))))))
		     ((#\nl) (read-char *schlep-input*)
		      (if (eqv? #\( (peek-char *schlep-input*))
			  (cons (schlep-read *schlep-input*) (recur))
			  '()))
		     (else '())))))
	(cond ((eof-object? s1))
	      (else
	       (schlep-top (if (null? ss) s1 `(DOC-BEGIN ,s1 ,@ss))
			   (reverse doc-lines))
	       (set! doc-lines '())
	       (lp (peek-char *schlep-input*))))))
    ;;Comments transcribed to generated C source files.
    (define (c-cmt c)
      (cond ((eof-object? c) (lp c))
	    ((eqv? #\; c)
	     (read-char *schlep-input*)
	     (c-cmt (peek-char *schlep-input*)))
	    ;; Escape to start Texinfo comments
	    ((eqv? #\@ c)
	     (let* ((line (read-line *schlep-input*))
		    (tok (tok1 line)))
	       (cond ((or (string=? tok "@body")
			  (string=? tok "@text"))
		      (set! doc-lines
			    (cons (skip-ws
				   (substring line
					      (string-length tok)
					      (string-length line)))
				  doc-lines))
		      (body-cmt (peek-char *schlep-input*)))
		     (else
		      (for-each (lambda (l)
				  (newline *documentation-output*)
				  (display l *documentation-output*))
				(document-substitute
				 (if (string=? tok "@")
				     (skip-ws
				      (substring line 1 (string-length line)))
				     line)
				 '()))
		      (doc-cmt (peek-char *schlep-input*))))))
	    ;; Transcribe the comment line to C source file.
	    (else
	     (out-c-cmt (read-line *schlep-input*))
	     (lp (peek-char *schlep-input*)))))
    ;;Comments incorporated in generated Texinfo files.
    ;;Continue adding lines to DOC-LINES until a non-comment
    ;;line is reached (may be a blank line).
    (define (body-cmt c)
      (cond ((eof-object? c) (lp c))
	    ((eqv? #\; c)
	     (set! doc-lines (cons (read-cmt-line) doc-lines))
	     (body-cmt (peek-char *schlep-input*)))
	    ((memv c '(#\nl #\cr))
	     (read-newline)
	     (lp (peek-char *schlep-input*)))
	    ;; Allow whitespace before ; in doc comments.
	    ((char-whitespace? c)
	     (read-char *schlep-input*)
	     (body-cmt (peek-char *schlep-input*)))
	    (else
	     (lp (peek-char *schlep-input*)))))
    ;;Comments incorporated in generated Texinfo files.
    ;;Transcribe comments to current position in Texinfo file
    ;;until a non-comment line is reached (may be a blank line).
    (define (doc-cmt c)
      (cond ((eof-object? c) (lp c))
	    ((eqv? #\; c)
	     (let* ((ls (document-substitute (read-cmt-line) '())))
	       (for-each (lambda (l)
			   (newline *documentation-output*)
			   (display l *documentation-output*))
			 ls)
	       (out-c-cmt (car ls)))
	     (doc-cmt (peek-char *schlep-input*)))
	    ((memv c '(#\nl #\cr))
	     (read-newline)
	     (newline *documentation-output*)
	     (lp (peek-char *schlep-input*)))
	    ;; Allow whitespace before ; in doc comments.
	    ((char-whitespace? c)
	     (read-char *schlep-input*)
	     (doc-cmt (peek-char *schlep-input*)))
	    (else
	     (newline *documentation-output*)
	     (lp (peek-char *schlep-input*)))))
    (lp (peek-char *schlep-input*))))

(define (schlep-h-def sexp)
  (cond ((pair? (cadr sexp))
	 (let* ((ptype (or *procedure* (proctype (caadr sexp))))
		(use (type->exptype ptype)))
	   (set! *procedure* (caadr sexp))
	   (out 0 "#define " (caadr sexp)) ;name
	   (infix-schlep-exp VAL #\, CONTLINE (cdadr sexp)) ;arglist
	   (out CONTLINE " ")
	   (schlep-bracketed-begin (if (eq? VOID use) SEMI NONE)
				   use CONTLINE (cddr sexp))))
	(else (out 0 "#define " (cadr sexp) (if (pair? (caddr sexp)) " (" " "))
	      (schlep-exp NONE VAL CONTLINE
			  (cond ((and (pair? (caddr sexp))
				      (eq? 'QUOTE (caaddr sexp))
				      (eq? (cadr sexp) (cadr (caddr sexp))))
				 (set! tokcntr (+ 1 tokcntr)) tokcntr)
				(else (caddr sexp))))
	      (if (pair? (caddr sexp)) (out CONTLINE ")"))))
  (out 0))

(define (do-pragma strs) (for-each (lambda (str) (out 0 str)) strs))

;;; SCHLEP-H-TOP - schlep top level form sexp.
(define (schlep-h-top sexp . doc)
  (if (pair? doc) (set! doc (car doc)))
  (cond ((symbol? sexp) (set! *procedure* sexp))
	((and (pair? sexp) (eq? (car sexp) 'QUOTE))
	 (set! *procedure* (cadr sexp)))
	((string? sexp) (outcomment 0 sexp))
	((not (pair? sexp))
	 (outcomment 0 sexp)
	 (report "top level atom?" sexp))
	(else
	 (case (car sexp)
	   ((LOAD REQUIRE)	       ;If you redefine load, you lose
	    (out-include (cadr sexp)))
	   ((DEFMACRO:LOAD)
	    (include-defmacros (cadr sexp)))
	   ((PROVIDE)
	    (out-sharpdef (cadr sexp)))
	   ((BEGIN)
	    (cond ((pair? doc)
		   (schlep-h-top (cadr sexp) doc)
		   (set! doc '())
		   (for-each schlep-h-top (cddr sexp)))
		  (else
		   (for-each schlep-h-top (cdr sexp)))))
	   ((DOC-BEGIN)
	    (if (pair? doc)
		(begin
		  (schlep-top-doc-begin (cdr sexp) doc #t)
		  (set! doc '())))
	    (for-each schlep-h-top (cdr sexp)))
	   ((DEFVAR DEFINE DEFCONST)
	    (fluid-let ((*schlep-output* *schlep-output*)
			(*output-line* *output-line*))
	      (cond ((pair? doc)
		     (document-h-def sexp doc '())
		     (set! doc '())))
	      (schlep-h-def sexp)))
	   ((PRAGMA.H)
	    (do-pragma (cdr sexp)))
	   ((PRAGMA.C)
	    (report "PRAGMA.C: no .c file being generated" sexp))
	   (else
	    (report "SCHLEP-H-TOP: statement not in procedure" sexp)))
	 (or (null? doc)
	     (report
	      "SCHLEP-H-TOP: no definition found for Texinfo documentation"
	      doc sexp))
	 (set! *procedure* #f))))

(define (schlep-to-sharp-if test consequent alternate schlep sense)
  (define (crestif)
    (schlep consequent)
    (cond (alternate
	   (out 0 "#else                    /*")
	   (ctest (not sense) test)
	   (out CONTLINE "*/")
	   ;; (out 0)
	   (schlep alternate)))
    (out 0 "#endif	")
    (out CONTLINE "/* ")
    (ctest (if alternate (not sense) sense) test)
    (out CONTLINE " */")
    (out 0))
  (define (ctest sense test)
    (out CONTLINE (if sense "" "n") "def ")
    (cond ((and (eq? 'PROVIDED? (car test))
		(pair? (cadr test))
		(eq? 'QUOTE (caadr test)))
	   (c-ify-string
	    (string-upcase (symbol->string (cadadr test)))
	    *schlep-output*))
	  ((string? (cadr test))
	   (c-ify-string (cadr test) *schlep-output*))
	  ((symbol? (cadr test))
	   (c-ify-symbol (cadr test) *schlep-output*))
	  (else
	   (report "argument not identifier" test))))
  (case (and (pair? test) (car test))
    ((NOT)
     (schlep-to-sharp-if
      (cadr test) consequent alternate schlep (not sense)))
    ((DEFINED? PROVIDED?)
     (out 0 (string-append "#if"))
     (ctest sense test)
     (crestif))
    (ELSE
     (out 0 (string-append "#if " (if sense "" "!") "("))
     (schlep-exp NONE BOOL CONTLINE test)
     (out CONTLINE ")")
     (out 0)
     (crestif))))

(define (schlep-top-if exps sense)
  (define test (car exps))
  (define consequent (cadr exps))
  (define alternate (if (null? (cddr exps)) #f (caddr exps)))
  (schlep-to-sharp-if test consequent alternate schlep-top sense))

(define (schlep-top-cond clauses)
  (if (not (null? clauses))
      (let* ((clause (car clauses)))
	(cond ((eq? 'ELSE (car clause))
	       (for-each schlep-top (cdr clause)))
	      ((not (null? (cdr clauses)))
	       (schlep-top-if (list (car clause)
				    (clause->sequence (cdr clause))
				    (cons 'COND (cdr clauses)))
			      #t))
	      (else
	       (schlep-top-if (list (car clause)
				    (clause->sequence (cdr clause)))
			      #t))))))

(define (funcalled-in-code? ident tree)
  (let walk ((tree tree))
    (cond ((not (pair? tree)) #f)
	  ((not (list? tree)) #f)
	  ((eq? 'quote (car tree)) #f)
	  ((eq? ident (car tree)))
	  (else (some walk tree)))))

;; BODY must be one, ie a list of one or more forms.
(define (tailcalled-in-body? ident body)
  (define (tcalled? form)
    (cond ((not (pair? form)) #f)
	  ((eq? ident (car form)) #t)
	  (else
	   (case (car form)
	     ((BEGIN)
	      (tailcalled-in-body? ident (cdr form)))
	     ((LET)
	      (tailcalled-in-body? ident
				   (if (symbol? (cadr form))
				       (cdddr form)
				       (cddr form))))
	     ((LETREC LET*)
	      (tailcalled-in-body? ident (cddr form)))
	     ((IF)
	      (or (tcalled? (caddr form))
		  (and (pair? (cdddr form))
		       (tcalled? (cadddr form)))))
	     ((AND OR)
	      (tailcalled-in-body? ident (cdr form)))
	     ((DO)
	      (tailcalled-in-body? ident (caddr form)))
	     ((COND CASE CASEV QASE)
	      (let loop ((clauses (if (eq? (car form) 'COND)
				      (cdr form)
				      (cddr form))))
		(cond ((null? clauses) #f)
		      ((tailcalled-in-body? ident (car clauses)))
		      (else (loop (cdr clauses))))))
	     (else #f)))))
  (let defloop ((body body))
    (cond ((null? body) #f)		;This shouldn't happen
	  ((not (pair? (car body)))
	   (tcalled? (car (last-pair body))))
	  ((eq? 'DEFINE (caar body))
	   (or (and (let ((form (car body)))
		      (and (pair? (cdr form))
			   (pair? (cadr form))
			   (tailcalled-in-body? ident (cddr form)))))
	       (defloop (cdr body))))
	  (else
	   (tcalled? (car (last-pair body)))))))

;;@noindent
;;Defmacros transforming Scheme code to Scheme code may be defined in
;;schlep source files.

;;@body
;;Is an alist associating defmacro names with their transformers.  It
;;is @code{fluid-let} during each file translatation, so that schlep
;;macro definitions do not take effect in the Scheme top level.
(define *schlep-defmacros* '())

(define (procedure->schlep-defmacro name proc)
  (set! *schlep-defmacros*
	(cons (cons name proc) *schlep-defmacros*)))
(define (do-defmacro name . body)
  (define (expn name pattern body)
    (let ((args (gentemp)))
      (procedure->schlep-defmacro
       name
       (eval `(lambda ,args (destructuring-bind ,pattern ,args ,@body))))))
  (if (pair? name)
      (expn (car name) (cdr name) body)
      (expn name (car body) (cdr body))))

(procedure->schlep-defmacro
 'edprintf
 (lambda (fmt . args)
   `(dprintf ,(string-append ">>>>ERROR<<<< " fmt) ,@args)))

(procedure->schlep-defmacro
 'wdprintf
 (lambda (fmt . args)
   `(dprintf ,(string-append "WARNING: " fmt) ,@args)))

(define (include-defmacros filename-spec)
  (and (pair? filename-spec)
       (eq? (car filename-spec) 'IN-VICINITY)
       (pair? (cdr filename-spec))
       (pair? (cadr filename-spec))
       (eq? (caadr filename-spec) 'PROGRAM-VICINITY)
       (let* ((filename (caddr filename-spec))
	      (port (try-open-file filename OPEN_READ)))
	 (if port
	     (do ((sexp (schlep-read port) (schlep-read port)))
		 ((eof-object? sexp))
	       (if (pair? sexp)
		   (case (car sexp)
		     ((DEFMACRO)
		      (apply do-defmacro (cdr sexp)))
		     ((DEFMACRO:LOAD)
		      (include-defmacros (cadr sexp))))))))))

(define (schlep-top-doc-begin defs doc h-defs?)
  (let ((s1 (car defs)))
    (cond
     ((or (not (pair? s1))
	  (not (memq (car s1) '(DEFINE DEFVAR DEFCONST))))
      (report "SCHLEP-TOP: no definition found for Texinfo documentation"
	      doc (car defs)))
     (else
      (let ((op1 (car s1))
	    (proc? (pair? (cadr s1))))
	(let loop ((ss (cdr defs))
		   (smatch (list s1)))
	  (if (and (pair? ss)
		   (pair? (car ss))
		   (eq? op1 (caar ss))
		   (if proc?
		       (pair? (cadar ss))
		       (not (pair? (cadar ss)))))
	      (loop (cdr ss) (cons (car ss) smatch))
	      (let ((smatch (reverse smatch)))
		(cond (h-defs?
		       (document-h-def (car smatch) doc (cdr smatch)))
		      (proc?
		       (document-fun (car smatch) doc (cdr smatch)))
		      ((eq? op1 'DEFCONST)
		       (document-h-def (car smatch) doc (cdr smatch)))
		      (else
		       (document-var (car smatch) doc (cdr smatch))))))))))))


;;; SCHLEP-TOP - schlep top level form sexp.
(define (schlep-top sexp . doc)
  (if (pair? doc) (set! doc (car doc)))
  (if (pair? sexp)
      (set! sexp
	    (fluid-let ((*defmacros* *schlep-defmacros*))
	      (defmacro:expand* sexp))))
  (cond ((symbol? sexp) (set! *procedure* sexp))
	((and (pair? sexp) (eq? (car sexp) 'QUOTE))
	 (set! *procedure* (cadr sexp)))
	((string? sexp) (outcomment 0 sexp))
	((not (pair? sexp))
	 (outcomment 0 sexp)
	 (report "top level atom?" sexp))
	(else
	 (case (car sexp)
	   ((LOAD REQUIRE)	       ;If you redefine load, you lose
	    (out-include (cadr sexp)))
	   ((REQUIRE-IF) #f)
	   ((DEFMACRO:LOAD)
	    (include-defmacros (cadr sexp)))
	   ((PROVIDE)
	    (out-sharpdef (cadr sexp)))
	   ((BEGIN)
	    (cond ((pair? doc)
		   (schlep-top (cadr sexp) doc)
		   (set! doc '())
		   (for-each schlep-top (cddr sexp)))
		  (else
		   (for-each schlep-top (cdr sexp)))))
	   ((DOC-BEGIN)
	    (if (pair? doc)
		(begin
		  (schlep-top-doc-begin (cdr sexp) doc #f)
		  (set! doc '())))
	    (for-each schlep-top (cdr sexp)))
	   ((IF) (schlep-top-if (cdr sexp) #t))
	   ((COND) (schlep-top-cond (cdr sexp)))
	   ((DEFCONST)
	    ;;(schlep-h-def sexp)
	    (cond ((pair? doc)
		   (document-h-def sexp doc '())
		   (set! doc '())))
	    (fluid-let ((*schlep-output* *prototype-output*)
			(*output-line* *output-line*))
	      (schlep-h-def sexp)))
	   ((DEFVAR DEFINE)
	    (if (pair? (cadr sexp))
		(let ((ptype (or *procedure* (proctype (caadr sexp)))))
		  (set! *procedure* (caadr sexp))
		  (cond ((pair? doc)
			 (document-fun sexp doc '())
			 (set! doc '())))
		  (fluid-let ((*schlep-output* *prototype-output*)
			      (*output-line* *output-line*))
		    (case __STDC__
		      ((SCM)
		       (out 0 "SCM_EXPORT ")
		       (outtype CONTLINE ptype (caadr sexp) VOID)
		       (out CONTLINE " P("))
		      (else
		       (outtype 0 ptype (caadr sexp) VOID))) ;name
		    (out CONTLINE "(")
		    (if __STDC__
			(if (null? (cdadr sexp))
			    (out CONTLINE "void")
			    (let ((bs (cdadr sexp)))
			      (outtype CONTLINE (vartype (car bs))
				       (car bs) VOID)
			      (careful-for-each (lambda (b)
						  (out CONTLINE COMMA)
						  (outtype CONTLINE (vartype b)
							   b VOID))
						(cdr bs)))))
		    (case __STDC__
		      ((SCM)
		       (out CONTLINE ")")))
		    (out CONTLINE ");")
		    (out 0))
		  (add-label (caadr sexp) (cdadr sexp))
		  (outtype 0 ptype (caadr sexp) VOID) ;name
		  (infix-schlep-exp VAL #\, CONTLINE (cdadr sexp)) ;arglist
		  (careful-for-each (lambda (b)
				      (outtype 5 (vartype b) b VOID)
				      (out CONTLINE SEMI))
				    (cdadr sexp))
		  (out 0 #\{)
		  (cond ((tailcalled-in-body? (caadr sexp) (cddr sexp))
			 ;;(funcalled-in-code? (caadr sexp) (cddr sexp))
			 (out 0 (lblify (caadr sexp)) #\:)
			 (schlep-maybe-bracketed-begin
			  RETURN (type->exptype ptype) 2 (cddr sexp)))
			(else
			 (schlep-body RETURN (type->exptype ptype)
				      2 (cddr sexp))))
		  (out 0 #\})
		  (rem-label (caadr sexp)))
		(begin
		  (cond ((pair? doc)
			 (document-var sexp doc '())
			 (set! doc '())))
		  (fluid-let ((*schlep-output* *prototype-output*)
			      (*output-line* *output-line*))
		    (out 0 "extern ")
		    (outtype CONTLINE (vartype (cadr sexp)) (cadr sexp)
			     (and (caddr sexp) 'EXTERN)) ;name
		    (out CONTLINE SEMI)
		    (out 0))
		  (outbinding 0 (cdr sexp))))
	    (out 0))
	   ((ERROR)			;already at column 0
	    (out CONTLINE "#error")
	    (for-each (lambda (term) (out CONTLINE " " term))
		      (cdr sexp)))
	   ((PRAGMA.H)
	    (fluid-let ((*schlep-output* *prototype-output*)
			(*output-line* *output-line*))
	      (do-pragma (cdr sexp))))
	   ((PRAGMA.C)
	    (do-pragma (cdr sexp)))
	   ((DEFMACRO)
	    (apply do-defmacro (cdr sexp)))
	   ((DECLARE-NAMES)
	    (declare-names! (cdr sexp)))
	   (else (report "SCHLEP-TOP: statement not in procedure" sexp)))
	 (or (null? doc)
	     (report
	      "SCHLEP-TOP: no definition found for Texinfo documentation"
	      doc sexp))
	 (set! *procedure* #f))))

(define (has-defines? body)
  (cond ((null? body) #f)
	((null? (cdr body)) #f)
	((not (pair? (car body))) (has-defines? (cdr body)))
	((eq? 'BEGIN (caar body)) (has-defines? (cdar body)))
	(else (memq (caar body) '(DEFVAR DEFINE)))))

;;; SCHLEP-BODY - schlep body
(define (schlep-body termin use indent body)
  (if (and (not (eq? RETURN termin)) (not (eq? use VOID)))
      (report "body value not at top level" termin use body))
  (cond ((not (pair? body))
	 (if (not (eq? use VOID))
	     (report "short body?" body)))
	((null? (cdr body))
	 (out indent)
	 (schlep-exp termin use indent (car body)))
	((string? (car body))
	 (outcomment indent (car body))
	 (schlep-body termin use indent (cdr body)))
	(else
	 (case (caar body)
	   ((DEFVAR DEFINE)
	    (cond ((symbol? (cadar body))
		   (outbinding indent (cdar body))
		   (schlep-body termin use indent (cdr body)))
		  (else (add-label (caadar body) (cdadar body))
			(for-each (lambda (b)
				    (outtype indent (vartype b) b VOID)
				    (out CONTLINE SEMI))
				  (cdadar body))
			(schlep-body termin use indent (cdr body))
			(if (and (eq? use VOID) (eq? termin RETURN))
			    (out indent "return;"))
			(out 0 (lblify (caadar body)) #\:)
			(schlep-body termin use indent (cddar body))
			(rem-label (caadar body)))))
	   ((DECLARE-NAMES)
	    (fluid-let ((declarations declarations))
	      (declare-names! (cdar body))
	      (schlep-body termin use indent (cdr body))))
	   (else
	    (out indent)
	    (schlep-exp SEMI VOID indent (car body))
	    (schlep-body termin use indent (cdr body)))))))

(define (schlep-goto indent sexp)
  (define lbls (label-vars (car sexp)))
  (cond ((eq? RETURN lbls)
	 (cond ((not (null? (cddr sexp)))
		(report "too many values to continuation" sexp)))
	 (out CONTLINE "return ")
	 (schlep-exp SEMI VAL (+ 7 indent) (cadr sexp)))
	(else
	 (let ((lv (filter (lambda (l) (not (eq? (car l) (cadr l))))
			   (map list lbls (cdr sexp)))))
	   (cond ((pair? lv)
		  (out CONTLINE "{")
		  (outletbindings (+ 2 indent) lv #f)
		  (out (+ 2 indent) "goto " (lblify (car sexp)) #\;)
		  (out indent "}"))
		 (else
		  (out CONTLINE "goto " (lblify (car sexp)) #\;)))))))

(define (filter pred? lst)
  (cond ((null? lst) lst)
	((pred? (car lst))
	 (cons (car lst) (filter pred? (cdr lst))))
	(else (filter pred? (cdr lst)))))

;;; LOOKUP - translate from table or return arg as string
(define (lookup arg tab)
  (let* ((p (assq arg tab))
	 (l (if p (cdr p) arg)))
    (if (symbol? l) (symbol->string l) l)))

(define (c-ify-char chr)
  (cond ((char-alphabetic? chr) (string chr))
	((char-numeric? chr) (string chr))
	(else
	 (case chr
	   ((#\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/
	     #\: #\; #\< #\= #\> #\? #\@
	     #\[     #\] #\^ #\_ #\`
	     #\{ #\| #\} #\~)
	    (string chr))
	   ((#\\) "\\\\")
	   ((#\newline) "\\n")
	   ((#\tab) "\\t")
	   ((#\backspace) "\\b")
	   ((#\return) "\\r")
	   ((#\page) "\\f")
	   ((#\space) " ")
	   ;;((#\null) "\\0")
	   (else
	    (let ((numstr (number->string (char->integer chr) 8)))
	      (string-append
	       "\\" (make-string (- 3 (string-length numstr)) #\0) numstr)))))))


;;; SCHLEP-EXP - schlep expression
(define (schlep-exp termin use indent sexp)
  (cond ((not (pair? sexp))		;atoms
	 (cond ((eq? RETURN termin)	;return from here
		(case use
		  ((VOID)		;shouldn't happen
		   (cond (sexp (report "void function returning?" sexp)
			       (schlep-exp SEMI use indent sexp)))
		   (out indent "return;"))
		  (else
		   (out CONTLINE "return ")
		   (schlep-exp SEMI use (+ 7 indent) sexp))))
	       ((string? sexp)
		(let ((icnt (if (> (string-length sexp) 80) 0 #f)))
		  (out CONTLINE #\")
		  (cond ((<= 60 (string-length sexp) 80)
			 (out CONTLINE #\\)
			 (out 0)))
		  (for-each (lambda (c)
			      (cond ((not icnt))
				    ((zero? (modulo icnt 16))
				     (set! icnt (+ 1 icnt))
				     (out CONTLINE #\\)
				     (out 0))
				    (else
				     (set! icnt (+ 1 icnt))))
			      (out CONTLINE
				   (case c
				     ((#\") "\\\"")
				     (else (c-ify-char c)))))
			    (string->list sexp))
		  (out CONTLINE #\" termin)))
	       ((and (number? sexp) (inexact? sexp))
		(out CONTLINE sexp termin))
	       ((integer? sexp)
;;;		(cond ((and (>= sexp 65536) (not (eq? use LONG)))
;;;		       (report "Large Constant used in non-LONG context"
;;;			       sexp)))
		(out CONTLINE
		     (if (or (and (eq? use LONG) (not (negative? sexp)))
			     (> sexp 9))
			 (string-append "0x" (number->string sexp 16)
					(if (eq? use LONG) "L" ""))
			 sexp)
		     termin))
	       ((char? sexp)
		(out CONTLINE "'" (c-ify-char sexp) "'" termin))
	       ((vector? sexp)
		(out CONTLINE "{\n\t")
		(set! *output-line* (+ 1 *output-line*))
		(infix-schlep-exp VAL ",\n\t" indent (vector->list sexp))
		(out CONTLINE "\n\t}" termin)
		(set! *output-line* (+ 1 *output-line*)))
	       ((eq? VOID use)
		(if sexp (report "returning value?" sexp))
		(out CONTLINE termin))
	       (else (out CONTLINE (case sexp ((#f) 0) ((#t) "!0") (else sexp))
			  termin))))
	((and (pair? (car sexp))
	      (eq? 'LAMBDA (caar sexp)))
	 (schlep-exp termin use indent
		     (append (list 'LET (map list (cadar sexp) (cdr sexp)))
			     (cddar sexp))))
	((case (car sexp)
	   ((IF)
	    (schlep-if termin use indent (cdr sexp) #t) #t)
	   ((OR)
	    (schlep-or termin use indent (cdr sexp)) #t)
	   ((AND)
	    (schlep-and termin use indent (cdr sexp)) #t)
	   ((COND)
	    (schlep-cond termin use indent (cdr sexp)) #t)
	   ((BEGIN)
	    (schlep-begin termin use indent (cdr sexp)) #t)
	   ((DO)
	    (schlep-do termin use indent (cdr sexp)) #t)
	   ((LET)
	    (schlep-let termin use indent (cdr sexp)) #t)
	   ((LET*)
	    (schlep-let* termin use indent (cdr sexp)) #t)
	   ((CASE CASEV QASE)
	    (schlep-case termin use indent (cdr sexp)) #t)
	   ((QUOTE)
	    (schlep-exp
	     termin use indent
	     (cond ((or (number? (cadr sexp))
			(string? (cadr sexp))
			(vector? (cadr sexp)))
		    (cadr sexp))
		   ((symbol? (cadr sexp))
		    (call-with-output-string
			(lambda (stp)
			  (c-ify-symbol (cadr sexp) stp))))
		   (else (report "quoted type not handled" sexp)
			 #f)))
	    #t)
	   ((CALL-WITH-CURRENT-CONTINUATION)
	    (schlep-call-with-current-continuation
	     termin use indent (cdr sexp)) #t)
	   ((PRAGMA.H)
	    (fluid-let ((*schlep-output* *prototype-output*)
			(*output-line* *output-line*))
	      (do-pragma (cdr sexp))) #t)
	   ((PRAGMA.C)
	    (do-pragma (cdr sexp)) #t)
	   (else
	    (and (label? (car sexp))
		 (cond
		  ((or (eq? termin RETURN)
		       ;;(eq? termin SEMI)
		       (eq? use VOID))
		   (schlep-goto indent sexp)
		   #t)
		  (else
		   (if (eq? (car sexp) *procedure*) #f
		       (report "internal recursion not tail recursion" sexp
			       "termin=" termin))
		   #f))))))
	(else
	 (cond ((and (eq? RETURN termin) (not (eq? use VOID)))
		(out CONTLINE "return ")
		(set! indent (+ 7 indent))))
	 (case (car sexp)
	   ((CURRENT-ERROR-PORT) (out CONTLINE "stderr"))
	   ((CURRENT-OUTPUT-PORT) (out CONTLINE "stdout"))
	   ((CURRENT-INPUT-PORT) (out CONTLINE "stdin"))
	   ((CURRENT-TIME)
	    (out CONTLINE "time(0L)"))
	   ((ODD?)
	    (out CONTLINE "(1&(")
	    (schlep-exp NONE VAL indent (cadr sexp))
	    (out CONTLINE "))"))
	   ((EVEN?)
	    (out CONTLINE "(!(1&(")
	    (schlep-exp NONE VAL indent (cadr sexp))
	    (out CONTLINE ")))"))
	   ((LOGBIT?)
	    (out CONTLINE "(1<<(")
	    (schlep-exp NONE VAL indent (cadr sexp))
	    (out CONTLINE ")) & (")
	    (schlep-exp NONE VAL indent (caddr sexp))
	    (out CONTLINE ")"))
	   ((BIT-EXTRACT BIT-FIELD)	; this was commented out; why?
	    (let ((n (cadr sexp))
		  (start (caddr sexp))
		  (end (cadddr sexp)))
	      (schlep-exp NONE VAL indent
			  `(logand (- (ash 2 ,(- end start)) 1)
				   (ash ,n ,(- start))))))
	   ((DPRINTF TDPRINTF)
	    (out CONTLINE (car sexp) "(")
	    (infix-schlep-exp
	     VAL #\, (+ 2 (string-length (symbol->string (car sexp))) indent)
	     (cons 'diagout (cdr sexp)))
	    (out CONTLINE ")"))
	   ((SET!)
	    (if (not (eq? use void)) (report "returning void?" sexp))
	    (out CONTLINE (cadr sexp) " = ")
	    (schlep-exp NONE (type->exptype (vartype (cadr sexp))) indent (caddr sexp)))
	   ((VECTOR-SET! STRING-SET! BYTE-SET!)
	    (if (not (eq? use void)) (report "returning void?" sexp))
	    (schlep-exp NONE VAL indent (cadr sexp))
	    (out CONTLINE #\[)
	    (schlep-exp NONE VAL indent (caddr sexp))
	    (out CONTLINE #\] " = ") ;TBD could be smarter about type of expression in vector-set!
	    (schlep-exp NONE VAL indent (cadddr sexp)))
	   ((ARRAY-SET!)
	    (if (not (eq? use void)) (report "returning void?" sexp))
	    (schlep-exp NONE VAL indent (cadr sexp))
	    (out CONTLINE #\[)
	    (schlep-exp NONE VAL indent (cadddr sexp))
	    (out CONTLINE #\] " = ") ;TBD could be smarter about type of expression in vector-set!
	    (schlep-exp NONE VAL indent (caddr sexp)))
	   ((SUBSTRING!)
	    (schlep-exp NONE VAL CONTLINE
			`(begin (string-set! ,(cadr sexp) ,(cadddr sexp) 0)
				(SUBSTRING ,@(cdr sexp)))))
	   ((SUBSTRING)
	    (cond ((eqv? 0 (caddr sexp)) (out CONTLINE (cadr sexp)))
		  (else (out CONTLINE #\&)
			(schlep-exp NONE VAL CONTLINE (cadr sexp))
			(out CONTLINE #\[)
			(schlep-exp NONE VAL CONTLINE (caddr sexp))
			(out CONTLINE #\]))))
	   ((BYTE-REF)
	    (out CONTLINE "(((unsigned char*)(")
	    (schlep-exp NONE VAL CONTLINE (cadr sexp))
	    (out CONTLINE "))[")
	    (schlep-exp NONE VAL CONTLINE (caddr sexp))
	    (out CONTLINE "])"))
	   ((VECTOR-REF STRING-REF ARRAY-REF)
	    (schlep-exp NONE VAL CONTLINE (cadr sexp))
	    (out CONTLINE #\[)
	    (schlep-exp NONE VAL CONTLINE (caddr sexp))
	    (out CONTLINE #\]))
	   ((VECTOR STRING BYTES)
	    (out CONTLINE #\{)
	    (infix-schlep-exp use "," (+ 2 indent) (cdr sexp))
	    (out CONTLINE #\}))
	   ((VECTOR-SET-LENGTH!)
	    (out CONTLINE "realloc(")
	    (schlep-exp NONE use (+ 2 indent) (cadr sexp))
	    (out CONTLINE ", (")
	    (schlep-exp NONE use (+ 2 indent) (caddr sexp))
	    (out CONTLINE ") * (sizeof (void *)))"))
	   ((OFFSET-ARRAY)		; unadvertised
	    (out CONTLINE "&(")
	    (schlep-exp NONE use (+ 2 indent) (cadr sexp))
	    (out CONTLINE "[")
	    (schlep-exp NONE use (+ 4 indent) `(ash ,(caddr sexp) -2))
	    (out CONTLINE "])"))
	   ((MAKE-VECTOR)
	    (schlep-alloc indent "void *"
			  (cadr sexp)
			  (cddr sexp)))
	   ((CREATE-ARRAY MAKE-ARRAY)
	    (let ((prot (cadr sexp)))
	      (cond ((string? prot)
		     (schlep-alloc indent 'char
				   (caddr sexp)
				   (and (not (equal? "" prot))
					(list (string-ref (cadr prot) 0)))))
		    ((vector? prot)
		     (schlep-exp NONE use (+ 2 indent)
				 (if (zero? (vector-length prot))
				     (cons 'make-vector (cddr sexp))
				     `(make-vector ,(caddr sexp)
						   ,(vector-ref port 0)))))
		    ((pair? prot)
		     (schlep-alloc
		      indent
		      (case (car prot)
			((A:floR64b) 'double)
			((A:floR32b) 'float)
			((A:fixZ32b) 'long)
			((A:fixN32b) "unsigned long")
			((A:fixZ16b) 'short)
			((A:fixN16b) "unsigned short")
			((A:fixZ8b) 'char)
			((A:fixN8b) "unsigned char")
			(else
			 (report 'MAKE-ARRAY 'unknown 'type prot)))
		      (caddr sexp)
		      (cdr prot)))
		    (else (report "weird init " prot)))))
	   ((VECTOR-LENGTH BYTES-LENGTH)
	    (out CONTLINE "sizeof(")
	    (schlep-exp NONE use (+ 2 indent) (cadr sexp))
	    (out CONTLINE (if (eq? 'BYTES-LENGTH (car sexp)) ")-1" ")")))
	   ((STRING-LENGTH CHAR-UPCASE CHAR-DOWNCASE)
	    (out CONTLINE (cadr (assq (car sexp)
				      '((STRING-LENGTH "strlen")
					(CHAR-UPCASE "toupper")
					(CHAR-DOWNCASE "tolower"))))
		 "(")
	    (schlep-exp NONE use (+ 2 indent) (cadr sexp))
	    (out CONTLINE ")"))
	   ((NUMBER? CHAR?)
	    (out CONTLINE "(1)"))
	   ((STRING->NUMBER)
	    (out CONTLINE "atoi(")
	    (schlep-exps use (+ 2 indent) (cdr sexp))
	    (out CONTLINE ")"))
	   ((ZERO? NEGATIVE? POSITIVE?
		   INTEGER->CHAR CHAR->INTEGER
		   MAKE-STRING MAKE-BYTES
		   LOGNOT DEFINED?)
	    (out CONTLINE
		 (lookup (car sexp)
			 '((ZERO? . "!")
			   (NEGATIVE? . "0 > ")
			   (POSITIVE? . "0 < ") (INTEGER->CHAR . "")
			   (CHAR->INTEGER . "(unsigned)")
			   (MAKE-STRING . "(unsigned char *)malloc")
			   (MAKE-BYTES . "(unsigned char *)malloc")
			   (LOGNOT . "~") (DEFINED? . defined)
			   ))
		 "(")
	    (schlep-exp NONE use (+ 2 indent)(cadr sexp))
	    (out CONTLINE ")"))
	   ((NOT)
	    (cond ((and (pair? (cadr sexp))
			(memq (caadr sexp) '(ZERO? NOT)))
		   (schlep-exp NONE use indent (cadadr sexp)))
		  ((and (pair? (cadr sexp))
			(memq (caadr sexp) '(= EQ? EQV? EQUAL? CHAR=?)))
		   (schlep-exp NONE use indent
			       (cons '!=-internal (cdadr sexp))))
		  (else (out CONTLINE "!(")
			(schlep-exp NONE use (+ 2 indent) (cadr sexp))
			(out CONTLINE ")"))))
	   ((-)
	    (cond ((= 2 (length sexp))
		   (out CONTLINE
			"-(")
		   (schlep-exp NONE use (+ 2 indent)(cadr sexp))
		   (out CONTLINE ")"))
		  ((> (length sexp) 2)
		   (infix-schlep-exp use "-" indent (cdr sexp)))
		  (else (report "strange `-' expression " sexp))))
	   ((ASH ARITHMETIC-SHIFT)
	    (let ((arg2 (caddr sexp)))
	      (cond ((and (pair? arg2)
			  (null? (cddr arg2))
			  (eq? '- (car arg2)))
		     (infix-schlep-exp use ">>" indent
				       (list (cadr sexp) (cadr arg2))))
		    ((not (number? arg2))
		     ;;(report "shift by variable?" sexp)
		     (infix-schlep-exp use "<<" indent (cdr sexp)))
		    ((zero? arg2)
		     (schlep-exp NONE use indent (cadr sexp)))
		    ((positive? arg2)
		     (infix-schlep-exp use "<<" indent (cdr sexp)))
		    (else
		     (infix-schlep-exp use ">>" indent
				       (list (cadr sexp) (- arg2)))))))
	   ((+ * / REMAINDER MODULO QUOTIENT LOGIOR LOGAND LOGXOR LOGTEST)
	    (infix-schlep-exp use
			      (lookup (car sexp)
				      '((REMAINDER . %)
					(MODULO . %) (/ . /)
					(QUOTIENT . /) (LOGIOR . |)
					(LOGAND . &) (LOGTEST . &)
					(LOGXOR . ^)))
			      indent
			      (cdr sexp)))
	   ((< > = <= >= EQ? EQV? CHAR<? CHAR>? CHAR<=? CHAR>=? CHAR=?
	       !=-internal)
	    (case (length (cdr sexp))
	      ((0 1) (report "to few arguments to comparison operator:" sexp)
	       (schlep-exp NONE use indent #t))
	      ((2)
	       (infix-schlep-exp
		VAL (lookup (car sexp)
			    '((= . ==)
			      (!=-internal . !=)
			      (EQ? . ==) (EQV? . ==) (CHAR<? . <) (CHAR>? . >)
			      (CHAR<=? . <=) (CHAR>=? . >=) (CHAR=? . ==)))
		indent
		(cdr sexp)))
	      (else (schlep-exp "" use indent
				`(and (,(car sexp) ,(cadr sexp) ,(caddr sexp))
				      (,(car sexp) ,@(cddr sexp)))))))
	   ((PRAGMA.H)
	    (fluid-let ((*schlep-output* *prototype-output*)
			(*output-line* *output-line*))
	      (do-pragma (cdr sexp))) #t)
	   ((PRAGMA.C)
	    (do-pragma (cdr sexp)) #t)
	   (else
	    (cond ((pair? (car sexp))	;computed function
		   (out indent "(*(")
		   (schlep-exp NONE VAL (+ 3 indent) (car sexp))
		   (out CONTLINE "))")
		   (out (+ 2 indent)))
		  (else (out CONTLINE (car sexp))))
	    (infix-schlep-exp VAL #\, (+ 2 indent) (cdr sexp))))
	 (cond ((eq? VOID use)
;;;		(if (not (eq? VOID (proctype (car sexp))))
;;;		    (report "void function returning?" sexp))
		(out CONTLINE (if (eq? COMMA termin) COMMA SEMI))
;;;		(if (eq? RETURN termin) (out indent "return;"))
		)
	       ((eq? RETURN termin)
		(out CONTLINE #\;))
	       (else (out CONTLINE termin))))))

(define (schlep-alloc indent type numelts initv)
  (cond ((null? initv)
	 (out CONTLINE "malloc((")
	 (schlep-exp NONE 'LONG (+ 2 indent) numelts)
	 (out CONTLINE ") * (sizeof (" type ")))"))
	(else
	 (if (not (member (car initv) '(#f () 0)))
	     (report "cannot initialize to other than 0 " initv))
	 (out CONTLINE "calloc(")
	 (schlep-exp NONE 'LONG (+ 2 indent) numelts)
	 (out CONTLINE ", (sizeof (" type ")))"))))

(define (schlep-call-with-current-continuation termin use indent sexp)
  (cond ((not (null? (cdr sexp)))
	 (report
	  "ignoring extra args to call-with-current-continuation:"
	  sexp)))
  (cond ((not (and (pair? (car sexp))
		   (list? (car sexp))
		   (eq? 'LAMBDA (caar sexp))))
	 (report "Schlep can't pass continuations: " sexp)))
  (cond ((not (or (eq? use VOID)
		  (eq? termin RETURN)))
	 (report "Sticky continuation value: " use termin)))
  (add-label (caadar sexp) (if (eq? use VOID) '() RETURN))
  (schlep-body termin use indent (cddar sexp))
  (cond ((eq? use VOID)
	 (out 0 (lblify (caadar sexp)) #\:)))
  (rem-label (caadar sexp)))

(define (schlep-begin termin use indent exps)
  (cond ((null? exps) (outcomment CONTLINE "null begin?"))
	((null? (cdr exps))
	 (schlep-exp termin use indent (car exps)))
	(else (schlep-bracketed-begin termin use indent exps))))

(define (schlep-bracketed-begin termin use indent exps)
  (cond ((and (not (eq? RETURN termin)) (not (eq? VOID use)))
	 (out CONTLINE "(")
	 (schlep-exps use (+ 2 indent) exps)
	 (out CONTLINE ")" termin))
	((and (pair? exps)
	      (null? (cdr exps))
	      (pair? (car exps))
	      (or (not (eq? use VOID))
		  (memq (caar exps) '(BEGIN DO LET LET*))))
	 (schlep-exp termin use indent (car exps)))
	(else
	 (out CONTLINE #\{)
	 (schlep-body termin use (+ 2 indent) exps)
	 (out indent "}"))))

;;; SCHLEP-EXPS - schlep expressions separated by commas
(define (schlep-exps use indent exps)
  (cond ((null? (cdr exps))
	 (schlep-exp NONE use indent (car exps)))
	(else
	 (schlep-exp COMMA VOID indent (car exps))
					;VOID causes if statements inside parenthesis.
	 (schlep-exps use indent (cdr exps)))))

(define (clause->sequence clause)
  (cond ((not (pair? clause)) (report "bad clause" clause) clause)
	((null? (cdr clause)) (car clause))
	(else (cons 'BEGIN clause))))

(define (schlep-cond termin use indent clauses)
  (cond ((null? clauses)
	 (report "cond as return value has no else clause")
	 ;; What should this value be?
	 (out CONTLINE 0))
	(else
	 (let* ((clause (car clauses)))
	   (cond ((null? (cdr clause))
		  (schlep-or termin use indent
			     (list (car clause)
				   (cons 'COND (cdr clauses)))))
		 ((eq? 'ELSE (car clause))
		  (schlep-begin termin use indent (cdr clause)))
		 ((not (null? (cdr clauses)))
		  (schlep-if termin use indent
			     (list (car clause)
				   (clause->sequence (cdr clause))
				   (cons 'COND (cdr clauses)))
			     #t))
		 (else
		  (schlep-if termin use indent
			     (list (car clause)
				   (clause->sequence (cdr clause)))
			     #t)))))))

(define (schlep-if termin use indent exps sense)
  (define test (car exps))
  (define consequent (cadr exps))
  (define alternate (if (null? (cddr exps)) #f (caddr exps)))
  (case (and (pair? test) (car test))
    ((NOT) (schlep-if termin use indent
		      `(,(cadr test) ,@(cdr exps)) (not sense)))
    ((DEFINED? PROVIDED?)
     (schlep-to-sharp-if test consequent alternate
			 (lambda (exp)
			   (out indent)
			   (schlep-exp termin use (+ 2 indent) exp))
			 sense))
    (else
     (cond
      ((and (not (eq? RETURN termin)) (not (eq? use VOID)))
       (schlep-exp NONE BOOL (+ 4 indent) (if sense test (list 'not test)))
       (out (+ 2 indent) #\?)
       (schlep-exp NONE use (+ 2 indent) consequent)
       (out (+ 2 indent) #\:)
       (if (null? (cddr exps))
	   (report "value from if missing" exps)
	   (schlep-exp termin use (+ 2 indent) alternate)))
      (else
       (out CONTLINE "if (")
       (schlep-exp NONE BOOL (+ 4 indent) (if sense test (list 'not test)))
       (out CONTLINE ")")
       (out (+ 2 indent))
       (cond ((null? (cddr exps))
	      (schlep-begin termin use (+ 2 indent) (cdr exps))) ;no else
	     (else			;have an else clause
	      (if (and (eq? use VOID) consequent)
		  (schlep-bracketed-begin
		   termin use (+ 2 indent) (list consequent))
		  (schlep-begin termin use (+ 2 indent) (list consequent)))
	      (out indent "else ")
	      (schlep-begin termin use indent (cddr exps)))))))))

(define (schlep-or termin use indent exps)
  (if (eq? termin RETURN)
      (case (length exps)
	((0) (if (eq? VOID use)
		 (out CONTLINE "return;")
		 (out CONTLINE "return 0;")))
	((1) (schlep-exp termin use indent (car exps)))
	(else
	 (case use
	   ((BOOL) (out CONTLINE "return ")
	    (schlep-or SEMI use (+ 7 indent) exps))
	   ((VOID) (schlep-or SEMI use indent exps)
	    (out indent "return;"))
	   (else
	    (cond ((symbol? (car exps))
		   (schlep-if
		    termin use indent
		    (list (car exps) (car exps) (cons 'OR (cdr exps)))
		    #t))
		  (else
		   (let ((procedure-tmp-symbol (tmpify *procedure*)))
		     (schlep-let* termin use indent
				  `(((,procedure-tmp-symbol ,(car exps)))
				    (or ,procedure-tmp-symbol ,@(cdr exps)))))))))))
      (case (length exps)
	((0) (out CONTLINE 0))
	((1) (schlep-exp termin use indent (car exps)))
	(else
	 (case use
	   ((VAL LONG) (report "OR of values treated as booleans" exps)
	    (infix-schlep-exp BOOL " || " indent exps)
	    (out CONTLINE termin))
	   ((BOOL) (infix-schlep-exp BOOL " || " indent exps)
	    (out CONTLINE termin))
	   ((VOID) (schlep-if termin use indent
			      (list (car exps) #f (cons 'OR (cdr exps)))
			      #t)))))))

(define (schlep-and termin use indent exps)
  (case (length exps)
    ((0) (out CONTLINE (if termin "" "return ") "!0"))
    ((1) (schlep-exp termin use indent (car exps)))
    (else
     (case use
       ((BOOL)
	(cond ((eq? termin RETURN) (out CONTLINE "return ")))
	(infix-schlep-exp use " && " indent exps)
	(cond ((eq? termin RETURN) (out CONTLINE SEMI))
	      (else (out CONTLINE termin))))
       ((VAL)
	(schlep-if termin use indent (list (car exps)
					   (cons 'AND (cdr exps))
					   #f)
		   #t))
       ((VOID)
	(cond (termin
	       (schlep-if termin use indent
			  (list (cons 'AND (but-last-pair exps))
				(car (last-pair exps)))
			  #t))
	      (else (schlep-and SEMI use indent exps)
		    (out indent "return;"))))))))

(define (but-last-pair lst)
  (cond ((null? (cdr lst)) '())
	(else
	 (cons (car lst) (but-last-pair (cdr lst))))))

(define (schlep-let termin use indent exps)
  (cond ((symbol? (car exps))
	 (add-label (car exps) (map car (cadr exps)))
	 (out CONTLINE #\{)
	 (outletbindings (+ 2 indent) (cadr exps) #t)
	 (out 0 (lblify (car exps)) #\:)
	 (schlep-maybe-bracketed-begin termin use (+ 2 indent) (cddr exps))
	 (out indent "}")
	 (rem-label (car exps)))
	(else
	 (out CONTLINE #\{)
	 (outletbindings (+ 2 indent) (car exps) #t)
	 (schlep-body termin use (+ 2 indent) (cdr exps))
	 (out indent "}"))))

(define (schlep-maybe-bracketed-begin termin use indent exps)
;;;  (print 'has-defines? exps)
;;;  (print '==> (has-defines? exps))
  (cond ((has-defines? exps)
	 (out indent)
	 (schlep-bracketed-begin termin use indent exps))
	(else
	 (schlep-body termin use indent exps))))

(define (schlep-let* termin use indent exps)
  (out CONTLINE #\{)
  (outbindings (+ 2 indent) (car exps))
  (schlep-body termin use (+ 2 indent) (cdr exps))
  (out indent "}"))

(define (schlep-do termin use indent exps)
  (if (and (not (eq? RETURN termin)) (not (eq? use VOID)))
      (report "DO value not at top level" exps))
  (out CONTLINE #\{)
  (outletbindings (+ 2 indent)
		  (map (lambda (b) (list (car b) (cadr b))) (car exps))
		  #t)
  (out (+ 2 indent) "while (")
  (schlep-exp NONE BOOL (+ 7 indent) (list 'NOT (caadr exps)))
  (out CONTLINE ") {")
  (schlep-body SEMI VOID (+ 4 indent) (cddr exps))
  (cond ((not (null? (car exps)))
	 (out (+ 4 indent) #\{)
	 (outletbindings
	  (+ 6 indent)
	  (filter (lambda (l) l)
		  (map (lambda (b)
			 (and (= 3 (length b)) (list (car b) (caddr b))))
		       (car exps)))
	  #f)
	 (out (+ 4 indent) "}")))
  (out (+ 2 indent) "}")
  (schlep-body termin use (+ 2 indent) (cdadr exps))
  (out indent "}"))

(define (schlep-case termin use indent exps)
  (if (and (not (eq? RETURN termin)) (not (eq? use VOID)))
      (report "CASE value not at top level" exps))
  (out CONTLINE "switch (")
  (schlep-exp NONE VAL (+ 8 indent) (car exps))
  (out CONTLINE ") {")
  (for-each
   (lambda (x)
     (case (car x)
       ((ELSE) (out indent "default:"))
       (else (for-each (lambda (d)
			 (cond ((not (pair? d))
				(if (char? d)
				    (out indent "case '" (c-ify-char d) "':")
				    (out indent "case " d ":")))
			       ((eq? 'UNQUOTE (car d))
				(out indent "case ")
				(schlep-exp NONE VAL CONTLINE (cadr d))
				(out CONTLINE ":"))))
		       (car x))))
     (schlep-body termin use (+ 2 indent) (cdr x))
     (if (eq? RETURN termin)
	 (if (eq? use VOID) (out (+ 2 indent) "return;"))
	 (out (+ 2 indent) "break;")))
   (cdr exps))
  (out indent "}"))

(define (add-label name arglist)
  (set! *label-list* (cons (cons name arglist) *label-list*)))

(define (label-vars name)
  (let ((p (label? name)))
    (and p (cdr p))))

(define (rem-label name)
  (set! *label-list* (cdr *label-list*)))

(define (label? name) (assq name *label-list*))

(define (long-string? str)
  (and (string? str) (> (string-length str) 40)))

(define (infix-schlep-exp use op indent exps)
  (define extra-nl? (and (string? op) (string-index op #\nl)))
  (define cnt 0)
  (define (par x indent)
    (cond ((or (pair? x) (symbol? x))
	   (out CONTLINE "(")
	   (schlep-exp NONE use (+ 1 indent) x)
	   (out CONTLINE ")"))
	  (else (schlep-exp NONE use indent x))))
  (cond ((eqv? #\, op)
	 (out CONTLINE "(")
	 (cond ((not (null? exps))
		(cond ((long-string? (car exps))
		       (set! op ",\n\t")
		       (set! extra-nl? #t)))
		(schlep-exp NONE use indent (car exps))
		(set! exps (cdr exps))))
	 (careful-for-each
	  (lambda (x)
	    (cond ((long-string? x) (set! op ",\n\t") (set! extra-nl? #t)))
	    (cond (extra-nl? (set! *output-line* (+ 1 *output-line*))))
	    (out CONTLINE op #\space)
	    (schlep-exp NONE use indent x))
	  exps)
	 (out CONTLINE ")"))
	(else
	 (cond ((not (null? exps))
		(par (car exps) indent)
		(set! exps (cdr exps))))
	 (careful-for-each
	  (lambda (x)
	    (set! cnt (+ 1 cnt))
	    (out (if (or (and (string? op) (char=? #\space (string-ref op 0)))
			 (zero? (modulo cnt 8)))
		     (+ -1 indent)
		     CONTLINE)
		 op)
	    (cond (extra-nl? (set! *output-line* (+ 1 *output-line*))))
	    ;;(report 'infix-schlep-exp "newline in op" x)
	    (par x (+ (if (char? op) 1 (+ -1 (string-length op))) indent)))
	  exps))))

;;(trace-all "/home/jaffer/bin/schlep")(set! *qp-width* 333)

;;; Local Variables:
;;; mode:scheme
;;; End:
(if *script* (exit (schlep.script (list-tail *argv* *optind*))))