home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / scm / wb1a1.lha / wb / comp.scm < prev    next >
Encoding:
Text File  |  1993-06-29  |  28.9 KB  |  925 lines
  1. ;;;; compiler.scm: Program for compiling SCMINT code to C
  2. ;;; Copyright (C) 1991, 1992, 1993 Aubrey Jaffer.
  3.  
  4. (define __STDC__ #f)
  5. ;;; (define __STDC__ #t) if you want ANSI function prototypes.
  6.  
  7. ;;; REPORT an error or warning
  8. (define report
  9.   (lambda args
  10.     (display "WARNING: char ")
  11.     (display (file-position *compile-input*))
  12.     (display "-> line ")
  13.     (display *output-line*)
  14.     (display #\  )
  15.     (display (list *procedure*))
  16.     (display ": ")
  17.     (apply qreport args)))
  18.  
  19. (define qreport
  20.   (lambda args
  21.     (for-each (lambda (x) (write x) (display #\ )) args)
  22.     (newline)))
  23.  
  24. ;;;delete the next four lines if you are not using SLIB.
  25. (require 'rev3-procedures)        ;this brings in last-pair
  26. (require 'debug)
  27. (set! *qp-width* 100)
  28. (define qreport qp)
  29.  
  30. ;;; This allows us to test without generating files
  31. (define *compile-input* (current-input-port))
  32. (define *compile-output* (current-output-port))
  33. (define *prototype-output* (current-output-port))
  34.  
  35. (define *included-files* '())
  36. (define *label-list* '())
  37. (define *procedure* #f)
  38. (define *output-line* 0)
  39. (define tokcntr 0)
  40. (define VOID 'VOID)
  41. (define EXTERN 'EXTERN)
  42. (define VAL 'VAL)
  43. (define LONG 'LONG)
  44. (define BOOL 'BOOL)
  45. (define CONTLINE -80)
  46.  
  47. (define RETURN "return")
  48. (define NONE "")
  49. (define COMMA ",")
  50. (define SEMI ";")
  51.  
  52. ;;; OUT indents and displays the arguments
  53. (define (out indent . args)
  54.   (cond ((>= indent 0)
  55.      (newline *compile-output*)
  56.      (set! *output-line* (+ 1 *output-line*))
  57.      (do ((j indent (- j 8)))
  58.          ((> 8 j)
  59.           (do ((i j (- i 1)))
  60.           ((>= 0 i))
  61.         (display #\  *compile-output*)))
  62.        (display #\     *compile-output*))))
  63.   (for-each (lambda (a)
  64.           (cond ((symbol? a)
  65.              (c-ify-symbol a *compile-output*))
  66.             (else
  67.              (display a *compile-output*))))
  68.         args))
  69.  
  70. ;;; C-IFY-SYMBOL removes or translates characters from name and prints to port
  71. (define (c-ify-symbol name port)
  72.   (define visible? #f)
  73.   (for-each
  74.    (lambda (c)
  75.      (let ((tc (cond ((char-alphabetic? c) c)
  76.              ((char-numeric? c) c)
  77.              ((char=? c #\-) #\_)
  78.              ((char=? c #\_) #\_)
  79.              ((char=? c #\?) "_P")
  80.              (else #f))))
  81.        (if tc (begin (set! visible? #t) (display tc port)))))
  82.    (string->list (symbol->string name)))
  83.   (if (not visible?) (report "C-invisible symbol?" name)))
  84.  
  85. ;;; TMPIFY makes a name for a temporary variable
  86. (define (tmpify sym)
  87.   (string->symbol (string-append "T_" (symbol->string sym))))
  88.  
  89. ;;; LBLIFY makes a name for a label
  90. (define (lblify sym)
  91.   (string->symbol (string-append "L_" (symbol->string sym))))
  92.  
  93. (define LONG 'LONG)
  94. (define INT 'INT)
  95. (define PTR 'PTR)
  96. (define ARRAY 'ARRAY)
  97. (define PAIR 'PAIR)
  98.  
  99. ;;; TYPTRANS is a translation table from variable name to C type.
  100. (define typtrans
  101.   '(("pos" INT) ("tab" PTR) ("ara" ARRAY) ("end" INT) ("siz" INT) ("eld" INT)
  102.         ("ort" SHORT) ("ent" (PTR ENTRY)) ("nts" (PTR ENTRY))
  103.         ("buk" (PTR ENTRY)) ("ile" PORT) ("ype" INT)
  104.         ("num" LONG) ("blk" (ARRAY UCHAR)) ("-id" LONG)
  105.         ("fct" LONG) ("-ct" LONG)
  106.         ("lck" (PTR LCK)) ("ntr" INT) ("unt" INT)
  107.         ("flc" (PTR LONG)) ("vel" INT) ("len" INT)
  108.         ("pkt" (ARRAY INT)) ("ame" (PTR UCHAR))
  109.         ("ind" (PTR ENTRY)) ("-bt" (PTR HAND))
  110.         ("str" (ARRAY UCHAR)) ("sed" LONG) ("han" (PTR HAND))
  111.         ("egd" (PTR SEGD)) ("ong" LONG) ("ime" LONG)
  112.         ("fun" (FUNCTION INT)) ("unc" (FUNCTION INT))))
  113.  
  114. ;;; VARTYPE gives a guess for the type of var
  115. (define (vartype var)
  116.   (let* ((str (symbol->string var))
  117.      (len (string-length str)))
  118.     (let ((v (if (>= len 3)
  119.          (assoc (substring str (- len 3) len) typtrans)
  120.          #f)))
  121.       (if (and v (memq (cadr v) '(ARRAY PTR)) (>= len 4))
  122.       (list (cadr v)
  123.         (vartype (string->symbol (substring str 0 (- len 4)))))
  124.       (or (and v (cadr v)) INT)))))
  125.  
  126. ;;; PROCTYPE - gives a guess for the type of proc
  127. (define (proctype proc)
  128.   (let* ((str (symbol->string proc)))
  129.     (case (string-ref str (- (string-length str) 1))
  130.       ((#\?) BOOL)
  131.       ((#\!) VOID)
  132.       (else (or (vartype proc)
  133.         (begin (report "unknown type" proc)
  134.                VAL))))))
  135.  
  136. (define (type->exptype type)
  137.   (case type
  138.     ((VOID BOOL LONG) type)
  139.     (else VAL)))
  140.  
  141. (define (outtype indent type name val)
  142.   (cond ((symbol? type)
  143.      (out indent
  144.           (case type
  145.         ((INT) "int")
  146.         ((BOOL) "int")
  147.         ((LONG) "unsigned long")
  148.         ((SHORT) "short")
  149. ;;;        ((CHAR) "char")
  150.         ((UCHAR) "unsigned char")
  151.         ((LCK) "LCK")
  152.         ((SEGD) "SEGD")
  153.         ((HAND) "HAND")
  154.         ((ENTRY) "ENTRY")
  155.         ((PORT) "int")
  156.         ((VAL) "SCM")
  157.         (else type))
  158.           #\  name) #t)
  159.     ((pair? type)
  160.      (case (car type)
  161.        ((PTR)
  162.         (outtype indent (cadr type) NONE VOID)
  163.         (out CONTLINE "*" name) #t)
  164.        ((ARRAY)
  165.         (outtype indent (cadr type) NONE VOID)
  166.         (cond ((and (pair? val)
  167.             (memq (car val) '(MAKE-VECTOR MAKE-STRING))
  168.             (pair? (cdr val))
  169.             (null? (cddr val)))
  170.            (out CONTLINE name "[")
  171.            (compile-exp "]" INT indent (cadr val)) #f)
  172.           ((and (pair? val)
  173.             (memq (car val) '(VECTOR STRING)))
  174.            (out CONTLINE name "[]") #t)
  175.           ((string? val)
  176.            (out CONTLINE name "[]") #t)
  177.           ((vector? val)
  178.            (out CONTLINE name "[]") #t)
  179.           ((eq? val EXTERN)
  180.            (out CONTLINE name "[]") #t)
  181.           (else
  182.            (out CONTLINE "*" name) #t)))
  183.        ((FUNCTION)
  184.         (out indent (string-append (symbol->string (cadr type)) "_function ")  name) #f)
  185. ;       ((FUNCTION)
  186. ;        (outtype indent (cadr type) NONE VOID)
  187. ;        (out CONTLINE "(*" name ")()") #f)
  188.        (else (report "unknown type" type name) #f)))
  189.     (else (report "unknown type" type name) #f)))
  190.  
  191. ;;; OUTBINDING - indents and prints out local binding
  192. (define (outbinding indent b)
  193.   (let ((type (vartype (car b))))
  194.     (cond ((var-involved? (car b) (cadr b))
  195.        (report "rebinding variable" b)
  196.        (outtmpbnd indent (car b) (cadr b))
  197.        (outuntmpbnd indent (car b)))
  198.       ((outtype indent type (car b) (cadr b))
  199.        (out CONTLINE " = ")
  200.        (compile-exp SEMI (type->exptype type) indent (cadr b)))
  201.       (else
  202. ;       (report "var can't be assigned" b)
  203.        (out CONTLINE ";")))))
  204.  
  205. ;;; OUTBINDINGS - indents and prints out local bindings
  206. (define (outbindings indent b)
  207.   (for-each (lambda (b) (outbinding indent b)) b))
  208.  
  209. (define (outtmpbnd indent var val)
  210.   (let ((type (vartype var)))
  211.     (cond ((outtype indent type (tmpify var) val)
  212.        (out CONTLINE " = ")
  213.        (compile-exp SEMI (type->exptype type) indent val))
  214.       (else
  215.        (report "temp can't be assigned" var val)
  216.        (out CONTLINE ";")))))
  217.  
  218. (define (outuntmpbnd indent var)
  219.   (outtype indent (vartype var) var VOID)
  220.   (out CONTLINE " = " (tmpify var) SEMI))
  221.  
  222. ;;; OUTLETBINDINGS - indents and prints out local simultaneous bindings
  223. (define (outletbindings indent bindings types?)
  224.   (if (not (null? bindings))
  225.       (let* ((vars (map car bindings))
  226.          (exps (map cadr bindings))
  227.          (invol (map
  228.              (lambda (b)
  229.                (var-involved-except? (car b) bindings b))
  230.              bindings)))
  231.     (for-each
  232.      (lambda (v b i) (if i (outtmpbnd indent (car b) (cadr b))))
  233.      vars bindings invol)
  234. ;    (if types? (outbinding indent (car bindings))
  235. ;        (let ((vtype (vartype (caar bindings))))
  236. ;          (out indent (caar bindings) " = ")
  237. ;          (compile-exp SEMI (type->exptype vtype) indent (cadar bindings))))
  238.     (for-each
  239.      (lambda (v b i)
  240.        (let ((type (vartype (car b))))
  241.          (cond (i (if types? (outuntmpbnd indent v)
  242.               (out indent v " = " (tmpify v) SEMI)))
  243.            ((not types?)
  244.             (out indent (car b))
  245.             (out CONTLINE " = ")
  246.             (compile-exp SEMI (type->exptype type) indent (cadr b)))
  247.            ((outtype indent type (car b) (cadr b))
  248.             (out CONTLINE " = ")
  249.             (compile-exp SEMI (type->exptype type) indent (cadr b)))
  250.            (else        ;(report "can't initialize" b)
  251.              (out CONTLINE SEMI)))))
  252.      (reverse vars) (reverse bindings) (reverse invol)))))
  253.  
  254. (define (var-involved-except? var sexps own)
  255.   (if (null? sexps) #f
  256.       (if (eq? (car sexps) own)
  257.       (var-involved-except? var (cdr sexps) own)
  258.       (or (var-involved? var (cdar sexps))
  259.           (var-involved-except? var (cdr sexps) own)))))
  260.  
  261. (define (var-involved? var sexp )
  262.   (if (pair? sexp)
  263.       (or (var-involved? var (car sexp))
  264.       (var-involved? var (cdr sexp)))
  265.       (eq? sexp var)))
  266.  
  267. (define (outcomment indent str)
  268.   (out indent "/*" str "*/")
  269.   (out indent))
  270.  
  271. (define (descmfilify file)
  272.   (let ((sl (string-length file)))
  273.   (cond ((< sl 4) file)
  274.     ((string-ci=? (substring file (- sl 4) sl) ".scm")
  275.      (substring file 0 (- sl 4)))
  276.     (else file))))
  277.  
  278. (define (out-include spec)
  279.   (cond ((and (pair? spec) (eq? (car spec) 'quote) (symbol? (cadr spec))))
  280.     (else
  281.      (out 0 "#include ")
  282.      (cond ((not (pair? spec))
  283.         (out CONTLINE "\"" (descmfilify spec) ".h\""))
  284.            ((and (eq? 'IN-VICINITY (car spec))
  285.              (eq? 'LIBRARY-VICINITY (caadr spec)))
  286.         (out CONTLINE "<" (descmfilify (caddr spec)) ".h>"))
  287.            (else
  288.         (out CONTLINE "\"" (descmfilify (caddr spec)) ".h\"")
  289.         (if (not (member (caddr spec) *included-files*))
  290.             (set! *included-files*
  291.               (cons (caddr spec) *included-files*))))))))
  292.  
  293. (define (do-includes)
  294.   (cond ((not (null? *included-files*))
  295.      (display "include files are:") (newline)
  296.      (for-each (lambda (f) (write f) (newline)) *included-files*)
  297.      (set! *included-files* ())))
  298.   (newline) (display "done.") (newline))
  299.  
  300. ;;; COMPILE files.
  301. (define compile
  302.   (lambda files
  303.     (for-each (lambda (f) (compile1 f ".c")) files)
  304.     (do-includes)))
  305.  
  306. ;;; COMPILEH - compile file to file.h.  Include files are done this way.
  307. (define compileh
  308.   (lambda files
  309.     (for-each (lambda (f) (compile1 f ".h")) files)
  310.     (do-includes)))
  311.  
  312. ;;; COMPILE1 - compile file.scm to file.suffix
  313. (define (compile1 file suffix)
  314.   (define ofile (string-append (descmfilify file) suffix))
  315.   (display "compiling ")
  316.   (write file)
  317.   (display " -> ")
  318.   (write ofile)
  319.   (newline)
  320.   (set! *compile-input* (open-input-file file))
  321.   (set! *compile-output* (open-output-file ofile))
  322.   (cond ((equal? ".c" suffix)
  323.      (if __STDC__ (display "ANSI "))
  324.      (display "prototypes -> ")
  325.      (write (string-append (descmfilify file) ".h"))
  326.      (newline)
  327.      (set! *prototype-output*
  328.            (open-output-file (string-append (descmfilify file) ".h")))))
  329.   (set! *output-line* 0)
  330.   (set! tokcntr 0)
  331.   (if (equal? ".c" suffix)
  332.       (compile-tops)
  333.       (compileh-tops))
  334.   (close-input-port *compile-input*)
  335.   (close-output-port *compile-output*)
  336.   (if (equal? ".c" suffix)
  337.       (begin (close-output-port *prototype-output*)
  338.          (set! *prototype-output* (current-output-port))))
  339.   (set! *compile-input* (current-input-port))
  340.   (set! *compile-output* (current-output-port)))
  341.  
  342. ;;; COMPILEH-TOPS - compile top level forms.
  343. (define (compileh-tops)
  344.   (let ((sexp (read *compile-input*)))
  345.     (cond ((eof-object? sexp))
  346.       (else
  347.        (compileh-top sexp)
  348.        (compileh-tops)))))
  349.  
  350. ;;; COMPILEH-TOP - compile top level form sexp.
  351. (define (compileh-top sexp)
  352.   (cond ((symbol? sexp) (set! *procedure* sexp))
  353.     ((and (pair? sexp) (eq? (car sexp) 'QUOTE))
  354.      (set! *procedure* (cadr sexp)))
  355.     ((string? sexp) (outcomment 0 sexp))
  356.     ((not (pair? sexp))
  357.      (report "top level atom?" sexp))
  358.     (else
  359.      (case (car sexp)
  360.        ((load require)        ;If you redefine load, you lose
  361.         (out-include (cadr sexp)))
  362.        ((begin)
  363.         (for-each compileh-top (cdr sexp)))
  364.        ((define)
  365.         (if (pair? (cadr sexp))
  366.         (let* ((ptype (or *procedure* (proctype (caadr sexp))))
  367.                (use (type->exptype ptype)))
  368.           (set! *procedure* (caadr sexp))
  369.           (out 0 "#define " (caadr sexp)) ;name
  370.           (infix-compile-exp VAL #\, CONTLINE (cdadr sexp)) ;arglist
  371.           (out CONTLINE " ")
  372.           (compile-bracketed-begin (if (eq? VOID use) SEMI NONE)
  373.                        use CONTLINE (cddr sexp)))
  374.         (begin (out 0 "#define " (cadr sexp) #\  )
  375.                (compile-exp NONE VAL CONTLINE
  376.                     (if (and (pair? (caddr sexp))
  377.                          (eq? 'QUOTE (caaddr sexp))
  378.                          (eq? (cadr sexp) (cadr (caddr sexp))))
  379.                     (begin (set! tokcntr (+ 1 tokcntr)) tokcntr)
  380.                     (caddr sexp)))))
  381.         (out 0))
  382.        (else
  383.         (report "statement not in procedure" sexp)))
  384.      (set! *procedure* #f))))
  385.  
  386. ;;; COMPILE-TOPS - compile top level forms.
  387. (define (compile-tops)
  388.   (let ((sexp (read *compile-input*)))
  389.     (cond ((eof-object? sexp))
  390.       (else
  391.        (compile-top sexp)
  392.        (compile-tops)))))
  393.  
  394. ;;; COMPILE-TOP - compile top level form sexp.
  395. (define (compile-top sexp)
  396.   (cond ((symbol? sexp) (set! *procedure* sexp))
  397.     ((and (pair? sexp) (eq? (car sexp) 'QUOTE))
  398.      (set! *procedure* (cadr sexp)))
  399.     ((string? sexp) (outcomment 0 sexp))
  400.     ((not (pair? sexp))
  401.      (report "top level atom?" sexp))
  402.     (else
  403.      (case (car sexp)
  404.        ((load require)        ;If you redefine load, you lose
  405.         (out-include (cadr sexp)))
  406.        ((begin)
  407.         (for-each compile-top (cdr sexp)))
  408.        ((define)
  409.         (if (pair? (cadr sexp))
  410.         (let ((ptype (or *procedure* (proctype (caadr sexp)))))
  411.           (set! *procedure* (caadr sexp))
  412.           (let ((compile-output *compile-output*)
  413.             (output-line *output-line*))
  414.             (set! *compile-output* *prototype-output*)
  415.             (outtype 0 ptype (caadr sexp) VOID) ;name
  416.             (out CONTLINE "(")
  417.             (if __STDC__
  418.             (if (null? (cdadr sexp)) (out CONTLINE "void")
  419.                 (let ((bs (cdadr sexp)))
  420.                   (outtype CONTLINE (vartype (car bs)) (car bs) VOID)
  421.                   (for-each (lambda (b)
  422.                       (out CONTLINE COMMA)
  423.                       (outtype CONTLINE (vartype b) b VOID))
  424.                     (cdr bs)))))
  425.             (out CONTLINE ");")
  426.             (out 0)
  427.             (set! *compile-output* compile-output)
  428.             (set! *output-line* output-line))
  429.           (add-label (caadr sexp) (cdadr sexp))
  430.           (outtype 0 ptype (caadr sexp) VOID) ;name
  431.           (infix-compile-exp VAL #\, CONTLINE (cdadr sexp)) ;arglist
  432.           (for-each (lambda (b)
  433.                   (outtype 5 (vartype b) b VOID)
  434.                   (out CONTLINE SEMI))
  435.                 (cdadr sexp))
  436.           (out 0 #\{)
  437.           (out 0 (lblify (caadr sexp)) #\:)
  438.           (cond ((has-defines? (cddr sexp))
  439.              (out 2)
  440.              (compile-bracketed-begin
  441.               RETURN (type->exptype ptype) 2 (cddr sexp)))
  442.             (else
  443.              (compile-body RETURN (type->exptype ptype) 2 (cddr sexp))))
  444.           (out 0 #\})
  445.           (rem-label (caadr sexp)))
  446.         (begin
  447.           (let ((compile-output *compile-output*)
  448.             (output-line *output-line*))
  449.             (set! *compile-output* *prototype-output*)
  450.             (out 0 "extern ")
  451.             (outtype CONTLINE (vartype (cadr sexp)) (cadr sexp)
  452.                  (and (caddr sexp) 'EXTERN)) ;name
  453.             (out CONTLINE SEMI)
  454.             (out 0)
  455.             (set! *compile-output* compile-output)
  456.             (set! *output-line* output-line))
  457.           (outbinding 0 (cdr sexp))))
  458.         (out 0))
  459.        (else
  460.         (report "statement not in procedure" sexp)))
  461.      (set! *procedure* #f))))
  462.  
  463. (define (has-defines? body)
  464.   (cond ((null? body) #f)
  465.     ((null? (cdr body)) #f)
  466.     ((not (pair? (car body))) (has-defines? (cdr body)))
  467.     ((eq? 'BEGIN (caar body)) (has-defines? (cdar body)))
  468.     (else (eq? 'DEFINE (caar body)))))
  469.  
  470. ;;; COMPILE-BODY - compile body
  471. (define (compile-body termin use indent body)
  472.   (if (and (not (eq? RETURN termin)) (not (eq? use VOID)))
  473.       (report "body value not at top level" body))
  474.   (cond ((not (pair? body))
  475.      (if (not (eq? use VOID))
  476.          (report "short body?" body)))
  477.     ((null? (cdr body))
  478.      (out indent)
  479.      (compile-exp termin use indent (car body)))
  480.     ((string? (car body))
  481.      (outcomment indent (car body))
  482.      (compile-body termin use indent (cdr body)))
  483.     ((not (eq? (caar body) 'DEFINE))
  484.      (out indent)
  485.      (compile-exp SEMI VOID indent (car body))
  486.      (compile-body termin use indent (cdr body)))
  487.     ((symbol? (cadar body))
  488.      (outbinding indent (cdar body))
  489.      (compile-body termin use indent (cdr body)))
  490.     (else (add-label (caadar body) (cdadar body))
  491.           (for-each (lambda (b)
  492.               (outtype indent (vartype b) b VOID)
  493.               (out CONTLINE SEMI))
  494.             (cdadar body))
  495.           (compile-body termin use indent (cdr body))
  496.           (if (and (eq? use VOID) (eq? termin RETURN))
  497.           (out indent "return;"))
  498.           (out 0 (lblify (caadar body)) #\:)
  499.           (compile-body termin use indent (cddar body))
  500.           (rem-label (caadar body)))))
  501.  
  502. (define (compile-goto indent sexp)
  503.   (let ((lv (filter (lambda (l)
  504.               (not (eq? (car l) (cadr l))))
  505.             (map list (label-vars (car sexp)) (cdr sexp)))))
  506.     (cond ((pair? lv)
  507.        (out CONTLINE "{")
  508.        (outletbindings (+ 1 indent) lv #f)
  509.        (out (+ 1 indent) "goto " (lblify (car sexp)) #\;)
  510.        (out indent "}"))
  511.       (else
  512.        (out CONTLINE "goto " (lblify (car sexp)) #\;)))))
  513.  
  514. (define (filter pred? lst)
  515.   (cond ((null? lst) lst)
  516.     ((pred? (car lst))
  517.      (cons (car lst) (filter pred? (cdr lst))))
  518.     (else (filter pred? (cdr lst)))))
  519.  
  520. ;;; LOOKUP - translate from table or return arg as string
  521. (define (lookup arg tab)
  522.   (let* ((p (assq arg tab))
  523.      (l (if p (cdr p) arg)))
  524.     (if (symbol? l) (symbol->string l) l)))
  525.  
  526. ;;; COMPILE-EXP - compile expression
  527. (define (compile-exp termin use indent sexp)
  528.   (cond ((not (pair? sexp))        ;atoms
  529.      (cond ((eq? RETURN termin)    ;return from here
  530.         (case use
  531.           ((VAL BOOL LONG)
  532.            (out CONTLINE "return ")
  533.            (compile-exp SEMI use (+ indent 7) sexp))
  534.           ((VOID)        ;shouldn't happen
  535.            (if sexp
  536.                (begin (report "void function returning?" sexp)
  537.                   (compile-exp SEMI use indent sexp)))
  538.            (out indent "return;"))))
  539.            ((string? sexp)
  540.         (out CONTLINE #\" sexp #\" termin))
  541.            ((integer? sexp)
  542.         (out CONTLINE sexp (if (eq? use LONG) #\L "") termin))
  543.            ((char? sexp)
  544.         (out CONTLINE "'"
  545.              (case sexp
  546.                ((#\newline) "\\n")
  547.                ((#\tab) "\\t")
  548.                ((#\backspace) "\\b")
  549.                ((#\return) "\\r")
  550.                ((#\page) "\\f")
  551.                ((#\null) "\\0")
  552.                (else sexp))
  553.              "'"
  554.              termin))
  555.            ((vector? sexp)
  556.         (out CONTLINE #\{)
  557.         (infix-compile-exp VAL #\, indent (vector->list sexp))
  558.         (out CONTLINE "}" termin))
  559.            ((eq? VOID use)
  560.         (if sexp (report "returning value?" sexp))
  561.         (out CONTLINE termin))
  562.            (else (out CONTLINE (case sexp ((#f) 0) ((#t) "!0") (else sexp)) termin))))
  563.     ((and (pair? (car sexp))
  564.           (eq? 'LAMBDA (caar sexp)))
  565.      (compile-exp termin use indent
  566.               (append (list 'LET (map list (cadar sexp) (cdr sexp)))
  567.                   (cddar sexp))))
  568.      ((case (car sexp)
  569.        ((IF)
  570.         (compile-if termin use indent (cdr sexp)) #t)
  571.        ((OR)
  572.         (compile-or termin use indent (cdr sexp)) #t)
  573.        ((AND)
  574.         (compile-and termin use indent (cdr sexp)) #t)
  575.        ((COND)
  576.         (compile-cond termin use indent (cdr sexp)) #t)
  577.        ((BEGIN)
  578.         (compile-begin termin use indent (cdr sexp)) #t)
  579.        ((DO)
  580.         (compile-do termin use indent (cdr sexp)) #t)
  581.        ((LET)
  582.         (compile-let termin use indent (cdr sexp)) #t)
  583.        ((LET*)
  584.         (compile-let* termin use indent (cdr sexp)) #t)
  585.        ((CASE)
  586.         (compile-case termin use indent (cdr sexp)) #t)
  587.        (else
  588.         (and (label? (car sexp))
  589.          (cond ((not (eq? termin RETURN))
  590.             (if (eq? (car sexp) *procedure*) #f
  591.                 (report "internal recursion not tail recursion" sexp))
  592.             #f)
  593.                (else
  594.             (compile-goto indent sexp)
  595.             #t))))))
  596.     (else
  597.      (if (and (eq? RETURN termin) (not (eq? use VOID)))
  598.          (begin (out CONTLINE "return ")
  599.             (set! indent (+ indent 7))))
  600.      (case (car sexp)
  601.        ((SET!)
  602.         (if (not (eq? use void)) (report "returning to void?" sexp))
  603.         (out CONTLINE (cadr sexp) " = ")
  604.         (compile-exp NONE (type->exptype (vartype (cadr sexp))) indent (caddr sexp)))
  605.        ((VECTOR-SET! STRING-SET!)
  606.         (if (not (eq? use void)) (report "returning to void?" sexp))
  607.         (compile-exp NONE VAL indent (cadr sexp))
  608.         (out CONTLINE #\[)
  609.         (compile-exp NONE VAL indent (caddr sexp))
  610.         (out CONTLINE #\] " = ")    ;TBD could be smarter about type of expression in vector-set!
  611.         (compile-exp NONE VAL indent (cadddr sexp)))
  612.        ((VECTOR-REF STRING-REF)
  613.         (compile-exp NONE VAL CONTLINE (cadr sexp))
  614.         (out CONTLINE #\[)
  615.         (compile-exp NONE VAL CONTLINE (caddr sexp))
  616.         (out CONTLINE #\]))
  617.        ((VECTOR STRING)
  618.         (out CONTLINE #\{)
  619.         (infix-compile-exp use "," (+ 2 indent) (cdr sexp))
  620.         (out CONTLINE #\}))
  621.        ((VECTOR-SET-LENGTH!)
  622.         (out CONTLINE "realloc(")
  623.         (compile-exp NONE use (+ 2 indent) (cadr sexp))
  624.         (out CONTLINE ", (")
  625.         (compile-exp NONE use (+ 2 indent) (caddr sexp))
  626.         (out CONTLINE ") * (sizeof (void *)))"))
  627.        ((MAKE-VECTOR)
  628.         (case (length sexp)
  629.           ((2) (out CONTLINE "malloc((")
  630.            (compile-exp NONE use (+ 2 indent) (cadr sexp))
  631.            (out CONTLINE ") * (sizeof (void *)))"))
  632.           ((3) (if (not (member (caddr sexp) '(#f () 0)))
  633.                (report "cannot initialize to other than 0 " sexp))
  634.            (out CONTLINE "calloc(")
  635.            (compile-exp NONE use (+ 2 indent) (cadr sexp))
  636.            (out CONTLINE ", (sizeof (void *)))"))))
  637.        ((STRING-LENGTH VECTOR-LENGTH)
  638.         (out CONTLINE "sizeof(")
  639.         (compile-exp NONE use (+ 2 indent) (cadr sexp))
  640.         (out CONTLINE (if (eq? 'STRING-LENGTH (car sexp)) ")-1" ")")))
  641.        ((NUMBER? CHAR?)
  642.         (out CONTLINE "(1)"))
  643.        ((ZERO? NEGATIVE? POSITIVE? NOT INTEGER->CHAR CHAR->INTEGER MAKE-STRING LOGNOT)
  644.         (out CONTLINE
  645.          (lookup (car sexp)
  646.              '((NOT . "!") (ZERO? . "!") (NEGATIVE? . "0 > ")
  647.                        (POSITIVE? . "0 < ") (INTEGER->CHAR . "")
  648.                        (CHAR->INTEGER . "(unsigned)")
  649.                        (MAKE-STRING . "(unsigned char *)malloc")
  650.                        (LOGNOT . "~")))
  651.          "(")
  652.         (compile-exp NONE use (+ 2 indent)(cadr sexp))
  653.         (out CONTLINE ")"))
  654.        ((- + * REMAINDER QUOTIENT LOGIOR LOGAND LOGXOR)
  655.         (infix-compile-exp use
  656.                    (lookup (car sexp)
  657.                        '((REMAINDER . %) (QUOTIENT . /)
  658.                              (LOGIOR . |) (LOGAND . &)
  659.                              (LOGXOR . ^)))
  660.                    indent
  661.                    (cdr sexp)))
  662.        ((< > = <= >= EQ? EQV? CHAR<? CHAR>? CHAR<=? CHAR>=? CHAR=?)
  663.         (infix-compile-exp VAL
  664.                    (lookup (car sexp)
  665.                        '((= . ==) (EQ? . ==) (EQV? . ==)
  666.                      (CHAR<? . <) (CHAR>? . >)
  667.                      (CHAR<=? . <=) (CHAR>=? . >=) (CHAR=? . ==)))
  668.                    indent
  669.                    (cdr sexp)))
  670.        (else
  671.         (cond ((pair? (car sexp))        ;computed function
  672.            (out indent "(*(")
  673.            (compile-exp NONE VAL (+ 3 indent) (car sexp))
  674.            (out CONTLINE "))")
  675.            (out (+ 2 indent)))
  676.           (else (out CONTLINE (car sexp))))
  677.         (infix-compile-exp VAL #\, (+ 2 indent) (cdr sexp))))
  678.      (cond ((eq? VOID use)
  679. ;        (if (not (eq? VOID (proctype (car sexp))))
  680. ;            (report "void function returning?" sexp))
  681.         (out CONTLINE (if (eq? COMMA termin) COMMA SEMI))
  682. ;        (if (eq? RETURN termin) (out indent "return;"))
  683.         )
  684.            ((eq? RETURN termin)
  685.         (out CONTLINE #\;))
  686.            (else (out CONTLINE termin))))))
  687.  
  688. (define (compile-begin termin use indent exps)
  689.   (cond ((null? exps) (outcomment CONTLINE "null begin?"))
  690.     ((null? (cdr exps))
  691.      (compile-exp termin use indent (car exps)))
  692.     (else (compile-bracketed-begin termin use indent exps))))
  693.  
  694. (define (compile-bracketed-begin termin use indent exps)
  695.   (cond ((and (not (eq? RETURN termin)) (not (eq? VOID use)))
  696.      (out CONTLINE #\()
  697.      (compile-exps use (+ 1 indent) exps)
  698.      (out CONTLINE #\) termin))
  699.     ((and (pair? exps)
  700.           (null? (cdr exps))
  701.           (pair? (car exps))
  702.           (or (not (eq? use VOID))
  703.           (memq (caar exps) '(BEGIN DO LET LET*))))
  704.      (compile-exp termin use indent (car exps)))
  705.     (else
  706.      (out CONTLINE #\{)
  707.      (compile-body termin use (+ 1 indent) exps)
  708.      (out indent "}"))))
  709.  
  710. ;;; COMPILE-EXPS - compile expressions separated by commas
  711. (define (compile-exps use indent exps)
  712.   (cond ((null? (cdr exps))
  713.      (compile-exp NONE use indent (car exps)))
  714.     (else
  715.      (compile-exp COMMA VOID indent (car exps))
  716.      ;VOID causes if statements inside parenthesis.
  717.      (compile-exps use indent (cdr exps)))))
  718.  
  719. (define (clause->sequence clause)
  720.   (cond ((not (pair? clause)) (report "bad clause" clause) clause)
  721.     ((null? (cdr clause)) (car clause))
  722.     (else (cons 'BEGIN clause))))
  723.  
  724. (define (compile-cond termin use indent clauses)
  725.   (if (not (null? clauses))
  726.       (let* ((clause (car clauses)))
  727.     (cond ((null? (cdr clause))
  728.            (compile-or termin use indent (list (car clause)
  729.                         (cons 'COND (cdr clauses)))))
  730.           ((eq? 'ELSE (car clause))
  731.            (compile-begin termin use indent (cdr clause)))
  732.           ((not (null? (cdr clauses)))
  733.            (compile-if termin use indent
  734.                (list (car clause)
  735.                  (clause->sequence (cdr clause))
  736.                  (cons 'COND (cdr clauses)))))
  737.           (else
  738.            (compile-if termin use indent
  739.                (list (car clause)
  740.                  (clause->sequence (cdr clause)))))))))
  741.  
  742. (define (compile-if termin use indent exps)
  743.   (if (and (not (eq? RETURN termin)) (not (eq? use VOID)))
  744.       (begin
  745.     (compile-exp NONE BOOL (+ 4 indent) (car exps))
  746.     (out (+ 1 indent) #\?)
  747.     (compile-exp NONE use (+ 2 indent) (cadr exps))
  748.     (out (+ 1 indent) #\:)
  749.     (if (null? (cddr exps))
  750.         (report "value from if missing" exps)
  751.         (compile-exp termin use (+ 2 indent) (caddr exps))))
  752.       (begin
  753.     (out CONTLINE "if (")
  754.     (compile-exp NONE BOOL (+ 4 indent) (car exps))
  755.     (out CONTLINE ")")
  756.     (out (+ 2 indent))
  757.     (if (null? (cddr exps))
  758.         (compile-begin termin use (+ 2 indent) (cdr exps)) ;no else
  759.         (begin            ;have an else clause
  760.           (if (and (eq? use VOID) (cadr exps))
  761.           (compile-bracketed-begin termin use (+ 2 indent) (list (cadr exps)))
  762.           (compile-begin termin use (+ 2 indent) (list (cadr exps))))
  763.           (out indent "else ")
  764.           (compile-begin termin use indent (cddr exps)))))))
  765.  
  766. (define (compile-or termin use indent exps)
  767.   (if (eq? termin RETURN)
  768.       (case (length exps)
  769.     ((0) (if (eq? VOID use)
  770.          (out CONTLINE "return;")
  771.          (out CONTLINE "return 0;")))
  772.     ((1) (compile-exp termin use indent (car exps)))
  773.     (else
  774.      (case use
  775.        ((BOOL) (out CONTLINE "return ")
  776.            (compile-or SEMI use (+ 7 indent) exps))
  777.        ((VOID) (compile-or SEMI use indent exps)
  778.            (out indent "return;"))
  779.        (else
  780.         (cond ((symbol? (car exps))
  781.            (compile-if termin use indent
  782.                    (list (car exps) (car exps) (cons 'OR (cdr exps)))))
  783.           (else
  784.            (let ((procedure-tmp-symbol (tmpify *procedure*)))
  785.              (compile-let* termin use indent
  786.                    `(((,procedure-tmp-symbol ,(car exps)))
  787.                      (or ,procedure-tmp-symbol ,@(cdr exps)))))))))))
  788.       (case (length exps)
  789.     ((0) (out CONTLINE 0))
  790.     ((1) (compile-exp termin use indent (car exps)))
  791.     (else
  792.      (case use
  793.        ((VAL LONG) (report "or of values not handled properly"))
  794.        ((BOOL) (infix-compile-exp BOOL " || " indent exps))
  795.        ((VOID) (compile-if termin use indent
  796.                    (list (car exps) #f (cons 'OR (cdr exps))))))))))
  797.  
  798. (define (compile-and termin use indent exps)
  799.   (case (length exps)
  800.     ((0) (out CONTLINE (if termin "" "return ") "!0"))
  801.     ((1) (compile-exp termin use indent (car exps)))
  802.     (else
  803.      (case use
  804.        ((BOOL) (infix-compile-exp use " && " indent exps))
  805.        ((VAL)
  806.     (compile-if termin use indent (list (car exps)
  807.                       (cons 'AND (cdr exps))
  808.                       #f)))
  809.        ((VOID)
  810.     (cond (termin
  811.            (compile-if termin use indent
  812.                (list (cons 'AND (but-last-pair exps))
  813.                  (car (last-pair exps)))))
  814.           (else (compile-and SEMI use indent exps)
  815.             (out indent "return;"))))))))
  816.  
  817. (define (but-last-pair lst)
  818.   (cond ((null? (cdr lst)) '())
  819.     (else
  820.      (cons (car lst) (but-last-pair (cdr lst))))))
  821.  
  822. (define (compile-let termin use indent exps)
  823.   (cond ((symbol? (car exps))
  824.      (add-label (car exps) (map car (cadr exps)))
  825.      (out CONTLINE #\{)
  826.      (outletbindings (+ indent 1) (cadr exps) #t)
  827.      (out 0 (lblify (car exps)) #\:)
  828.      (compile-body termin use (+ indent 1) (cddr exps))
  829.      (out indent "}")
  830.      (rem-label (car exps)))
  831.     (else
  832.      (out CONTLINE #\{)
  833.      (outletbindings (+ indent 1) (car exps) #t)
  834.      (compile-body termin use (+ indent 1) (cdr exps))
  835.      (out indent "}"))))
  836.  
  837. (define (compile-let* termin use indent exps)
  838.   (out CONTLINE #\{)
  839.   (outbindings (+ 1 indent) (car exps))
  840.   (compile-body termin use (+ 1 indent) (cdr exps))
  841.   (out indent "}"))
  842.  
  843. (define (compile-do termin use indent exps)
  844.   (if (and (not (eq? RETURN termin)) (not (eq? use VOID)))
  845.       (report "DO value not at top level" exps))
  846.   (out CONTLINE #\{)
  847.   (outletbindings (+ 2 indent)
  848.           (map (lambda (b) (list (car b) (cadr b))) (car exps))
  849.           #t)
  850.   (out (+ 2 indent) "while (")
  851.   (compile-exp NONE BOOL (+ 7 indent) (list 'NOT (caadr exps)))
  852.   (out CONTLINE ") {")
  853.   (compile-body SEMI VOID (+ 4 indent) (cddr exps))
  854.   (outletbindings
  855.    (+ 4 indent)
  856.    (filter (lambda (l) l)
  857.        (map (lambda (b) (and (= 3 (length b)) (list (car b) (caddr b))))
  858.         (car exps)))
  859.    #f)
  860.   (out (+ 2 indent) "}")
  861.   (compile-body termin use (+ 2 indent) (cdadr exps))
  862.   (out indent "}"))
  863.  
  864. (define (compile-case termin use indent exps)
  865.   (if (and (not (eq? RETURN termin)) (not (eq? use VOID)))
  866.       (report "CASE value not at top level" exps))
  867.   (out indent "switch (")
  868.   (compile-exp NONE VAL (+ 8 indent) (car exps))
  869.   (out CONTLINE ") {")
  870.   (for-each
  871.    (lambda (x)
  872.      (cond ((eq? (car x) 'ELSE)
  873.         (out indent "default:"))
  874.        (else (for-each (lambda (x)
  875.                  (out indent "case " x ":"))
  876.                (car x))))
  877.      (compile-body termin use (+ 3 indent) (cdr x))
  878.      (if (not (eq? RETURN termin))
  879.      (out (+ 3 indent) "break;")))
  880.    (cdr exps))
  881.   (out indent "}"))
  882.  
  883. (define (add-label name arglist)
  884.   (set! *label-list* (cons (cons name arglist) *label-list*)))
  885.  
  886. (define (label-vars name)
  887.   (let ((p (label? name)))
  888.     (and p (cdr p))))
  889.  
  890. (define (rem-label name)
  891.   (set! *label-list* (cdr *label-list*)))
  892.  
  893. (define (label? name) (assq name *label-list*))
  894.  
  895. (define (infix-compile-exp use op indent exps)
  896.   (define (par x indent)
  897.     (if (or (pair? x) (symbol? x))
  898.     (begin
  899.       (out CONTLINE #\()
  900.       (compile-exp NONE use (+ 1 indent) x)
  901.       (out CONTLINE #\)))
  902.     (compile-exp NONE use indent x)))
  903.   (cond ((eqv? #\, op)
  904.      (out CONTLINE #\()
  905.      (if (not (null? exps))
  906.          (begin (compile-exp NONE use indent (car exps))
  907.             (set! exps (cdr exps))))
  908.      (for-each
  909.       (lambda (x)
  910.         (out CONTLINE op #\ )
  911.         (compile-exp NONE use indent x))
  912.       exps)
  913.      (out CONTLINE #\)))
  914.     (else
  915.      (if (not (null? exps))
  916.          (begin (par (car exps) indent)
  917.             (set! exps (cdr exps))))
  918.      (for-each
  919.       (lambda (x)
  920.         (out (if (and (string? op) (char=? #\  (string-ref op 0)))
  921.              indent CONTLINE)
  922.          op)
  923.         (par x (+ (if (char? op) 1 (string-length op)) indent)))
  924.       exps))))
  925.