compile.ss

   1 (require (lib "match.ss"))
   2 (require (only (lib "1.ss" "srfi") fold))
   3 (require (only (lib "13.ss" "srfi") string-contains))
   4 (require "python.ss")
   5
   6 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   7 ;; AST Construction
   8 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   9
  10 ;; Match function arguments
  11 ;; (def foo (a b c (d 10) (e "foo") (* args) (* kwargs)) ...)
  12 (define (match-function-args args)
  13   ;; I wish this was a match-lambda ...
  14   (define (valid-arg? arg)
  15     (and (symbol? arg)
  16          (not (eq? arg '*))))
  17   (let ((*args*     (list))
  18         (*defaults* (list))
  19         (*flag*     0))
  20     (let loop ()
  21       (when (and (not (null? args)) (valid-arg? (car args)))
  22         (set! *args* (append *args* (list (car args))))
  23         (set! args (cdr args))
  24         (loop)))
  25     ((match-lambda
  26        (((vars vals) ...)
  27         (set! *defaults* vals)
  28         (set! *args* (append *args* vars)))) args)
  29     (values *args* *defaults* *flag*)))
  30
  31 (define (not-symbol sym)
  32   (lambda (s)
  33     (not
  34      (and (symbol? s)
  35           (string=? (symbol->string s)
  36                     sym)))))
  37
  38 (define T
  39   (match-lambda
  40     ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  41     ;; MATH operators
  42
  43     (('+ left right)
  44      (@> Add (list (T left) (T right))))
  45     (('+ args ...)
  46      ;; fold into multiple forms of (+ A B)
  47      ;; eg: (+ a b c d) => (+ (+ (+ a b) c) d)
  48      (T (fold (lambda (a b) `(+ ,b ,a))
  49               (car args)
  50               (cdr args))))
  51
  52     ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  53     ;; BOOLEAN operators
  54
  55     (('and nodes ...)
  56      (@> And : (map T nodes)))
  57     (('not node)
  58      (@> Not (T node)))
  59
  60
  61     ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  62     ;; COMPARISON operators
  63
  64     (('= first rest ...)
  65      (@> Compare
  66          (T first)
  67          (map (lambda (r)
  68                 (py/tuple (list (ss->py "==") (T r))))
  69               rest)))
  70
  71
  72     ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  73     ;; Variable ASSIGNMENT
  74
  75     (('set! (targets ...) value)
  76      (@> Assign
  77          (list (@> AssTuple
  78                    (map (lambda (t)
  79                           (unpack-assign-name t))
  80                         targets)))
  81          (T value)))
  82
  83     (('set! target value)
  84      (@> Assign
  85          (list (unpack-assign-name target))
  86          (T value)))
  87
  88
  89     ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  90     ;; TUPLE, LIST, DICT
  91
  92     ((':tuple items ...)
  93      (@> Tuple (map T items)))
  94
  95
  96     ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  97     ;; IF, COND
  98
  99     ;;;; (if <exp> (begin ...) else (begin ...)
 100     (('if exp ('begin body1 ...) ('begin body2 ...))
 101      (@> If
 102          (list (py/tuple (list (T exp) (@> Stmt (map T body1)))))
 103          (@> Stmt (map T body2))))
 104
 105     (('if exp ('begin body1 ...))
 106      (@> If
 107          (list (py/tuple (list (T exp) (@> Stmt (map T body1)))))
 108          py/none))
 109
 110     (('if exp body1 body2)
 111      (T `(if ,exp (begin ,body1) (begin ,body2))))
 112
 113     (('if exp body1)
 114      (@> If
 115          (list (py/tuple (list (T exp) (@> Stmt (list (T body1))))))
 116          py/none))
 117
 118     (('cond ((and exp (? (not-symbol "else"))) body ...) ...)
 119      (@> If
 120          (map (lambda (e b)
 121                 (py/tuple (list (T e) (@> Stmt (map T b)))))
 122               exp body)
 123          py/none))
 124     ; TODO: else
 125
 126
 127     ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 128     ;; LOOP constructs
 129
 130     (('for var 'in seq suite ...)
 131      (@> For
 132          (@> AssName var "OP_ASSIGN")
 133          (T seq)
 134          (@> Stmt (map T suite))
 135          py/none))
 136
 137     (('while cond body ...)
 138      (@> While
 139          (T cond)
 140          (@> Stmt (map T body))
 141          py/none))                    ;; TODO: else
 142
 143     (('break)
 144      (@> Break))
 145
 146
 147     ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 148     ;; FUNCTION definition
 149
 150     (('def name (args ...) body ...)
 151      (display args)(newline)
 152      (call-with-values
 153       (lambda () (match-function-args args))
 154       (lambda (args defaults flag)
 155         (let ((ast
 156                (@> Function
 157                    py/none
 158                    name
 159                    (map ss->py args) ;; XXX: @> macro does not do
 160                                      ;; a deep translation of types
 161                    (map T defaults)
 162                    flag              ;; TODO: flags
 163                    py/none           ;; TODO: doc string
 164                    (@> Stmt (map T body)))))
 165           (filename-hack! ast)
 166           ast))))
 167
 168     (('return exp)
 169      (@> Return (T exp)))
 170
 171     ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 172     ;; CLASS definition
 173
 174     (('class name (bases ...) statements ...)
 175      (let ((class (@> Class
 176                       name bases "DOCSTRING"
 177                       (@> Stmt (map T statements)))))
 178        (filename-hack! class)
 179        class))
 180
 181
 182     ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 183     ;; PRINT, IMPORT, ....
 184
 185     ;;;; (print x)
 186     (('print exps ...) ;; ???
 187      (@> Printnl (map T exps) py/none))
 188
 189     ;; >>> print e1, e2,
 190     (('display exps ...)
 191      (@> Print (map T exps) py/none))
 192
 193     ;;;; (import name1 name2 ...)
 194     (('import names ...)
 195      (@> Import (map (lambda (n)
 196                        (py/tuple (list (ss->py n) py/none)))
 197                      names)))
 198
 199
 200     ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 201     ;; APPLY
 202
 203     ((proc args ...)
 204      (@> CallFunc (T proc) (map T args)
 205          py/none py/none))               ;; TODO: *args, **kwargs
 206
 207
 208     ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 209     ;; CONSTANTS, VARIABLES
 210
 211     ;;;; a token -- var, 23, "foobar", 634.34
 212     (name
 213      (cond
 214        ((symbol? name) (unpack-name name))
 215        ((number? name) (@> Const name))
 216        ((string? name) (@> Const name))
 217        (else (error "invalid exp" name))))))
 218
 219 ;; These functions handle names of the forms,
 220 ;;  - foo.bar.baz
 221 ;;  - foo
 222 ;; generating appropriate AST nodes.
 223 ;;
 224 ;; XXX: In future, this functionality must become part of the Lisp ``reader''
 225 ;;
 226 (define (unpack-name name)
 227   (let ((name-s (symbol->string name)))
 228     (if (dotted-name? name-s)
 229         (let ((names (str-split name-s #\.)))
 230           (fold (lambda (a b) (@> Getattr b a))
 231                 (T (string->symbol (car names)))
 232                 (cdr names)))
 233         (@> Name name))))
 234
 235 (define (unpack-assign-name name)
 236   (let ((name-s (symbol->string name)))
 237     (if (dotted-name? name-s)
 238         (let* ((names* (str-split name-s #\.))
 239                (names  (all-but-last names*))
 240                (lname  (last names*)))
 241           (@> AssAttr
 242               (fold (lambda (a b) (@> Getattr b a))
 243                             (T (string->symbol (car names)))
 244                             (cdr names))
 245               lname
 246               "OP_ASSIGN"))
 247         (@> AssName name "OP_ASSIGN"))))
 248
 249 (define (all-but-last l)
 250   (cond ((null? (cdr l)) null)
 251         (else (cons (car l) (all-but-last (cdr l))))))
 252
 253 (define (last l)
 254   (cond ((null? (cdr l)) (car l))
 255         (else (last (cdr l)))))
 256
 257 (define (dotted-name? name)
 258   (cond
 259     ((symbol? name)
 260      (string-contains (symbol->string name) "."))
 261     ((string? name)
 262      (string-contains name "."))
 263     (else
 264      (error "wrong type for `name' --" name))))
 265
 266 ;; From http://schemecookbook.org/Cookbook/StringSplit
 267 (define (str-split str ch)
 268   (let ((len (string-length str)))
 269     (letrec
 270         ((split
 271           (lambda (a b)
 272             (cond
 273               ((>= b len)
 274                (if (= a b)
 275                    '("")
 276                    (cons (substring str a b) '())))
 277               ((char=? ch (string-ref str b))
 278                (if (= a b)
 279                    (cons "" (split (+ 1 a) (+ 1 b)))
 280                    (cons (substring str a b)
 281                          (split (+ 1 b) (+ 1 b)))))
 282               (else (split a (+ 1 b)))))))
 283       (split 0 0))))
 284
 285
 286 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 287 ;; Python Code Generation
 288 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 289
 290 (define (write-code-obj co filename filename-pyc)
 291   (let ((f (@ (: "__builtin__" 'open) filename-pyc "wb")))
 292     (@ (: f 'seek) 0 0)
 293     (@ (: f 'write) (@ (: "imp" 'get_magic)))
 294     (let ((ts (py/int-as-long
 295                (@ (: "__builtin__" 'long)
 296                   (py/getattr (@ (: "os" 'stat)
 297                                  filename)
 298                               "st_mtime")))))
 299       (map (lambda (n)
 300              (@ (: f 'write)
 301                 (@ (: "__builtin__" 'chr) n)))
 302            (map (lambda (n)
 303                   (bitwise-and (arithmetic-shift ts (- n)) #xff))
 304                 (list 0 8 16 24))))
 305     (@ (: "marshal" 'dump) co f)
 306     (@ (: f 'flush))
 307     (@ (: f 'close))))
 308
 309 (define (read-sexp fileh)
 310   (let ((sexp (read fileh)))
 311     (if (eof-object? sexp)
 312         (list)
 313         (cons sexp (read-sexp fileh)))))
 314
 315 ;; XXX: TODO:
 316 ;; I do not understand why I have to do this.
 317 ;; Modules, Functions, Classes "must" have the `filename' attribute?
 318 (define *filename-hack* null)
 319 (define (filename-hack! obj)
 320   (py/setattr obj "filename" (py/str *filename-hack*)))
 321
 322 (define (compile-boa filename filename-pyc)
 323   (set! *filename-hack* filename)
 324   (call-with-input-file filename
 325     (lambda (i)
 326       (let* ((ast (@> Module "<DOCSTRING>" (@> Stmt (map T (read-sexp i)))))
 327              (_   (filename-hack! ast))
 328              (c   (@ (: "compiler" 'pycodegen 'InteractiveCodeGenerator) ast))
 329              (co  (@ (: c 'getCode))))
 330         ;; (py/err-print)
 331         (write-code-obj co filename filename-pyc)
 332         ;; diassemble it for debugging
 333         ;; (@ (: "dis" 'dis) co)
 334         'ok))))
 335
 336 ;; Primitive command line options interface.
 337 (define cmd-arg
 338   (let ((ARGS '((source 0 "examples/test.boa")
 339                 (output 1 "test.pyc"))))
 340     (lambda (arg)
 341       (let loop ((a ARGS))
 342         (if (eq? arg (caar a))
 343             (if (< (cadar a) (vector-length argv))
 344                 (vector-ref argv (cadar a))
 345                 (caddar a))
 346             (loop (cdr a)))))))
 347
 348 (compile-boa (cmd-arg 'source) (cmd-arg 'output))