picobit.scm

   1 ;;;; File: "picobit.scm", Time-stamp: <2006-05-08 16:04:37 feeley>
   2
   3 ;;;; Copyright (C) 2004-2009 by Marc Feeley and Vincent St-Amour
   4 ;;;; All Rights Reserved.
   5
   6 (define-macro (dummy)
   7   (proper-tail-calls-set! #f)
   8   #f)
   9 ;(dummy)
  10
  11 ;-----------------------------------------------------------------------------
  12
  13 (define compiler-error
  14   (lambda (msg . others)
  15     (display "*** ERROR -- ")
  16     (display msg)
  17     (for-each (lambda (x) (display " ") (write x)) others)
  18     (newline)
  19     (exit 1)))
  20
  21 ;-----------------------------------------------------------------------------
  22
  23 (include "utilities.scm")
  24 (include "node.scm")
  25 (include "env.scm")
  26 (include "parser.scm")
  27 (include "context.scm")
  28 (include "comp.scm")
  29 (include "asm.scm")
  30 (include "encoding.scm")
  31
  32 ;-----------------------------------------------------------------------------
  33
  34 (define expand-includes
  35   (lambda (exprs)
  36     (map (lambda (e)
  37            (if (eq? (car e) 'include)
  38                (cons 'begin
  39                      (expand-includes
  40                       (with-input-from-file (cadr e) read-all)))
  41                e))
  42          exprs)))
  43
  44 (define parse-file
  45   (lambda (filename)
  46     (let* ((library
  47             (with-input-from-file "library.scm" read-all))
  48            (toplevel-exprs
  49             (expand-includes
  50              (append library
  51                      (with-input-from-file filename read-all))))
  52            (global-env
  53             (make-global-env))
  54            (parsed-prog
  55             (parse-top (cons 'begin toplevel-exprs) global-env)))
  56
  57       (for-each
  58        (lambda (node)
  59          (mark-needed-global-vars! global-env node))
  60        parsed-prog)
  61
  62       (extract-parts
  63        parsed-prog
  64        (lambda (defs after-defs)
  65
  66          (define make-seq-preparsed
  67            (lambda (exprs)
  68              (let ((r (make-seq #f exprs)))
  69                (for-each (lambda (x) (node-parent-set! x r)) exprs)
  70                r)))
  71
  72          (define make-call-preparsed
  73            (lambda (exprs)
  74              (let ((r (make-call #f exprs)))
  75                (for-each (lambda (x) (node-parent-set! x r)) exprs)
  76                r)))
  77
  78          (if (var-needed?
  79               (env-lookup global-env '#%readyq))
  80              (make-seq-preparsed
  81               (list (make-seq-preparsed defs)
  82                     (make-call-preparsed
  83                      (list (parse 'value '#%start-first-process global-env)
  84                            (let* ((pattern
  85                                    '())
  86                                   (ids
  87                                    (extract-ids pattern))
  88                                   (r
  89                                    (make-prc #f
  90                                              '()
  91                                              #f
  92                                              (has-rest-param? pattern)
  93                                              #f))
  94                                   (new-env
  95                                    (env-extend global-env ids r))
  96                                   (body
  97                                    (make-seq-preparsed after-defs)))
  98                              (prc-params-set!
  99                               r
 100                               (map (lambda (id) (env-lookup new-env id))
 101                                    ids))
 102                              (node-children-set! r (list body))
 103                              (node-parent-set! body r)
 104                              r)))
 105                     (parse 'value
 106                            '(#%exit)
 107                            global-env)))
 108              (make-seq-preparsed
 109               (append defs
 110                       after-defs
 111                       (list (parse 'value
 112                                    '(#%halt)
 113                                    global-env))))))))))
 114
 115 (define extract-parts
 116   (lambda (lst cont)
 117     (if (or (null? lst)
 118             (not (def? (car lst))))
 119         (cont '() lst)
 120         (extract-parts
 121          (cdr lst)
 122          (lambda (d ad)
 123            (cont (cons (car lst) d) ad))))))
 124
 125 ;------------------------------------------------------------------------------
 126
 127 (define execute
 128   (lambda (hex-filename)
 129 '
 130     (if #f
 131         (begin
 132           (shell-command "gcc -o picobit-vm picobit-vm.c")
 133           (shell-command (string-append "./picobit-vm " hex-filename)))
 134         (shell-command (string-append "./robot . 1 " hex-filename)))))
 135
 136 ;------------------------------------------------------------------------------
 137
 138 (define compile
 139   (lambda (filename)
 140     (let* ((node (parse-file filename))
 141            (hex-filename
 142             (string-append
 143              (path-strip-extension filename)
 144              ".hex")))
 145
 146       (adjust-unmutable-references! node)
 147
 148 ;      (pp (node->expr node))
 149
 150       (let ((ctx (comp-none node (make-init-context))))
 151         (let ((prog (linearize (optimize-code (context-code ctx)))))
 152 ;         (pp (list code: prog env: (context-env ctx)))
 153           (assemble prog hex-filename)
 154           (execute hex-filename))))))
 155
 156
 157 (define main
 158   (lambda (filename)
 159     (compile filename)))
 160
 161 ;------------------------------------------------------------------------------
 162
 163 '
 164 (define (asm-write-hex-file filename)
 165   (with-output-to-file filename
 166     (lambda ()
 167
 168       (define (print-hex n)
 169         (display (string-ref "0123456789ABCDEF" n)))
 170
 171       (define (print-byte n)
 172         (display ", 0x")
 173         (print-hex (quotient n 16))
 174         (print-hex (modulo n 16)))
 175
 176       (define (print-line type addr bytes)
 177         (let ((n (length bytes))
 178               (addr-hi (quotient addr 256))
 179               (addr-lo (modulo addr 256)))
 180 ;          (display ":")
 181 ;          (print-byte n)
 182 ;          (print-byte addr-hi)
 183 ;          (print-byte addr-lo)
 184 ;          (print-byte type)
 185           (for-each print-byte bytes)
 186           (let ((sum
 187                  (modulo (- (apply + n addr-hi addr-lo type bytes)) 256)))
 188 ;            (print-byte sum)
 189             (newline))))
 190
 191       (let loop ((lst (cdr asm-code-stream))
 192                  (pos asm-start-pos)
 193                  (rev-bytes '()))
 194         (if (not (null? lst))
 195           (let ((x (car lst)))
 196             (if (vector? x)
 197               (let ((kind (vector-ref x 0)))
 198                 (if (not (eq? kind 'LISTING))
 199                   (compiler-internal-error
 200                     "asm-write-hex-file, code stream not assembled"))
 201                 (loop (cdr lst)
 202                       pos
 203                       rev-bytes))
 204               (let ((new-pos
 205                      (+ pos 1))
 206                     (new-rev-bytes
 207                      (cons x
 208                            (if (= (modulo pos 8) 0)
 209                                (begin
 210                                  (print-line 0
 211                                              (- pos (length rev-bytes))
 212                                              (reverse rev-bytes))
 213                                  '())
 214                                rev-bytes))))
 215                 (loop (cdr lst)
 216                       new-pos
 217                       new-rev-bytes))))
 218           (begin
 219             (if (not (null? rev-bytes))
 220                 (print-line 0
 221                             (- pos (length rev-bytes))
 222                             (reverse rev-bytes)))
 223             (print-line 1 0 '())))))))