syntax-case.patch

   1 === modified file 'compile.ss'
   2 --- compile.ss  2007-05-20 14:25:27 +0000
   3 +++ compile.ss  2007-05-30 09:17:20 +0000
   4 @@ -1,4 +1,5 @@
   5  (require (lib "match.ss"))
   6 +(require (lib "stx.ss" "syntax")) ;; provides module-or-top-identifier=?
   7  (require (only (lib "1.ss" "srfi") fold))
   8  (require (only (lib "13.ss" "srfi") string-contains))
   9  (require "python.ss")
  10 @@ -35,112 +36,113 @@
  11            (string=? (symbol->string s)
  12                      sym)))))
  13
  14 -(define T
  15 -  (match-lambda
  16 +(define (T expr)
  17 +  (syntax-case* expr (: + and not = set! :tuple if begin cond for in while break print)
  18 +    module-or-top-identifier=?
  19      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  20      ;; MATH operators
  21
  22 -    (('+ left right)
  23 -     (@> Add (list (T left) (T right))))
  24 -    (('+ args ...)
  25 +    ((+ left right)
  26 +     (@>* Add 7 (list (T #'left) (T #'right))))
  27 +    ((+ args ...)
  28       ;; fold into multiple forms of (+ A B)
  29       ;; eg: (+ a b c d) => (+ (+ (+ a b) c) d)
  30       (T (fold (lambda (a b) `(+ ,b ,a))
  31 -              (car args)
  32 -              (cdr args))))
  33 +              (car (syntax->list #'(args ...)))
  34 +              (cdr (syntax->list #'(args ...))))))
  35
  36      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37      ;; BOOLEAN operators
  38
  39 -    (('and nodes ...)
  40 -     (@> And : (map T nodes)))
  41 -    (('not node)
  42 -     (@> Not (T node)))
  43 +    ((and nodes ...)
  44 +     (@> And : (map T (syntax->list #'(nodes ...)))))
  45 +    ((not node)
  46 +     (@> Not (T #'node)))
  47
  48
  49      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  50      ;; COMPARISON operators
  51
  52 -    (('= first rest ...)
  53 +    ((= first rest ...)
  54       (@> Compare
  55 -         (T first)
  56 +         (T #'first)
  57           (map (lambda (r)
  58 -                (py/tuple (list (ss->py "==") (T r))))
  59 -              rest)))
  60 +                (py/tuple (list (ss->py "==") (T (syntax->list #'r)))))
  61 +              (syntax->list #'(rest ...)))))
  62
  63
  64      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  65      ;; Variable ASSIGNMENT
  66
  67 -    (('set! (targets ...) value)
  68 +    ((set! (targets ...) value)
  69       (@> Assign
  70           (list (@> AssTuple
  71                     (map (lambda (t)
  72                            (unpack-assign-name t))
  73 -                        targets)))
  74 -         (T value)))
  75 +                        (syntax->list #'(targets ...)))))
  76 +         (T #'value)))
  77
  78 -    (('set! target value)
  79 +    ((set! target value)
  80       (@> Assign
  81 -         (list (unpack-assign-name target))
  82 -         (T value)))
  83 +         (list (unpack-assign-name (syntax-object->datum #'target)))
  84 +         (T #'value)))
  85
  86
  87      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  88      ;; TUPLE, LIST, DICT
  89
  90 -    ((':tuple items ...)
  91 -     (@> Tuple (map T items)))
  92 +    ((:tuple items ...)
  93 +     (@> Tuple (map T (syntax->list #'(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 +    ((if exp (begin body1 ...) (begin body2 ...))
 125 +     (@> If
 126 +         (list (py/tuple (list (T #'exp) (@> Stmt (map T (syntax->list #'(body1 ...)))))))
 127 +         (@> Stmt (map T (syntax->list #'(body2 ...))))))
 128 +
 129 +    ((if exp (begin body1 ...))
 130 +     (@> If
 131 +         (list (py/tuple (list (T #'exp) (@> Stmt (map T (syntax->list #'(body1 ...)))))))
 132 +         py/none))
 133 +
 134 +    ;((if exp body1 body2)
 135 +    ; (T `(if ,exp (begin ,body1) (begin ,body2))))
 136 +
 137 +    ((if exp body1 ...)
 138 +     (@> If
 139 +         (list (py/tuple (list (T #'exp) (@> Stmt (list (T (syntax->list #'(body1 ...))))))))
 140 +         py/none))
 141 +
 142 +;    ((cond ((and exp (? (not-symbol "else"))) body ...) ...)
 143 +;     (@> If
 144 +;         (map (lambda (e b)
 145 +;                (py/tuple (list (T #'e) (@> Stmt (map T (syntax->list #'(b ...)))))))
 146 +;              exp body)
 147 +;         py/none))
 148      ; TODO: else
 149
 150
 151      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 152      ;; LOOP constructs
 153
 154 -    (('for var 'in seq suite ...)
 155 +    ((for var in seq suite ...)
 156       (@> For
 157 -         (@> AssName var "OP_ASSIGN")
 158 -         (T seq)
 159 -         (@> Stmt (map T suite))
 160 +         (@> AssName (syntax-object->datum #'var) "OP_ASSIGN")
 161 +         (T #'seq)
 162 +         (@> Stmt (map T (syntax->list #'(suite ...))))
 163           py/none))
 164
 165 -    (('while cond body ...)
 166 +    ((while cond body ...)
 167       (@> While
 168 -         (T cond)
 169 -         (@> Stmt (map T body))
 170 +         (T #'cond)
 171 +         (@> Stmt (map T (syntax->list #'(body ...))))
 172           py/none))                    ;; TODO: else
 173
 174 -    (('break)
 175 +    ((break)
 176       (@> Break))
 177
 178
 179 @@ -148,33 +150,34 @@
 180      ;; FUNCTION definition
 181
 182      (('def name (args ...) body ...)
 183 -     (display args)(newline)
 184 -     (call-with-values
 185 -      (lambda () (match-function-args args))
 186 -      (lambda (args defaults flag)
 187 -        (let ((ast
 188 -               (@> Function
 189 -                   py/none
 190 -                   name
 191 -                   (map ss->py args) ;; XXX: @> macro does not do
 192 -                                    ;; a deep translation of types
 193 -                   (map T defaults)
 194 -                   flag              ;; TODO: flags
 195 -                   py/none           ;; TODO: doc string
 196 -                   (@> Stmt (map T body)))))
 197 -          (filename-hack! ast)
 198 -          ast))))
 199 +     (begin
 200 +       ;(display #'args)(newline)
 201 +       (call-with-values
 202 +        (lambda () (match-function-args (syntax->list #'(args ...))))
 203 +        (lambda (args defaults flag)
 204 +          (let ((ast
 205 +                 (@> Function
 206 +                     py/none
 207 +                     #'name
 208 +                     (map ss->py args) ;; XXX: @> macro does not do
 209 +                     ;; a deep translation of types
 210 +                     (map T defaults)
 211 +                     flag              ;; TODO: flags
 212 +                     py/none           ;; TODO: doc string
 213 +                     (@> Stmt (map T (syntax->list #'(body ...)))))))
 214 +            (filename-hack! ast)
 215 +            ast)))))
 216
 217      (('return exp)
 218 -     (@> Return (T exp)))
 219 +     (@> Return (T #'exp)))
 220
 221      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 222      ;; CLASS definition
 223
 224      (('class name (bases ...) statements ...)
 225       (let ((class (@> Class
 226 -                     name bases "DOCSTRING"
 227 -                     (@> Stmt (map T statements)))))
 228 +                     #'name (syntax->list #'(bases ...)) "DOCSTRING"
 229 +                     (@> Stmt (map T (syntax->list #'(statements ...)))))))
 230         (filename-hack! class)
 231         class))
 232
 233 @@ -183,38 +186,40 @@
 234      ;; PRINT, IMPORT, ....
 235
 236      ;;;; (print x)
 237 -    (('print exps ...) ;; ???
 238 -     (@> Printnl (map T exps) py/none))
 239 +    ((print exps ...) ;; ???
 240 +     (display (syntax-line #'(exps ...)))
 241 +     (@>* Printnl (syntax-line #'print) (map T (syntax->list #'(exps ...))) py/none))
 242
 243      ;; >>> print e1, e2,
 244 -    (('display exps ...)
 245 -     (@> Print (map T exps) py/none))
 246 +    ((display exps ...)
 247 +     (@> Print (map T (syntax->list #'(exps ...))) py/none))
 248
 249      ;;;; (import name1 name2 ...)
 250 -    (('import names ...)
 251 +    ((import names ...)
 252       (@> Import (map (lambda (n)
 253                         (py/tuple (list (ss->py n) py/none)))
 254 -                     names)))
 255 +                     (syntax->list #'(names ...)))))
 256
 257
 258      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 259      ;; APPLY
 260
 261      ((proc args ...)
 262 -     (@> CallFunc (T proc) (map T args)
 263 +     (@> CallFunc (T #'proc) (map T (syntax->list #'(args ...)))
 264           py/none py/none))               ;; TODO: *args, **kwargs
 265 -
 266 +
 267
 268      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 269      ;; CONSTANTS, VARIABLES
 270
 271      ;;;; a token -- var, 23, "foobar", 634.34
 272      (name
 273 -     (cond
 274 -       ((symbol? name) (unpack-name name))
 275 -       ((number? name) (@> Const name))
 276 -       ((string? name) (@> Const name))
 277 -       (else (error "invalid exp" name))))))
 278 +     (let ((nam (syntax-object->datum #'name)))
 279 +       (cond
 280 +         ((symbol? nam) (unpack-name nam))
 281 +         ((number? nam) (@>* Const 7 nam))
 282 +         ((string? nam) (@>* Const 7 nam))
 283 +         (else (error "invalid exp" nam)))))))
 284
 285  ;; These functions handle names of the forms,
 286  ;;  - foo.bar.baz
 287 @@ -240,8 +245,8 @@
 288                 (lname  (last names*)))
 289            (@> AssAttr
 290                (fold (lambda (a b) (@> Getattr b a))
 291 -                            (T (string->symbol (car names)))
 292 -                            (cdr names))
 293 +                    (T (string->symbol (car names)))
 294 +                    (cdr names))
 295                lname
 296                "OP_ASSIGN"))
 297          (@> AssName name "OP_ASSIGN"))))
 298 @@ -298,7 +303,7 @@
 299                                "st_mtime")))))
 300        (map (lambda (n)
 301               (@ (: f 'write)
 302 -                (@ (: "__builtin__" 'chr) n)))
 303 +                (@ (: "__builtin__" 'chr) n) ))
 304             (map (lambda (n)
 305                    (bitwise-and (arithmetic-shift ts (- n)) #xff))
 306                  (list 0 8 16 24))))
 307 @@ -307,7 +312,7 @@
 308      (@ (: f 'close))))
 309
 310  (define (read-sexp fileh)
 311 -  (let ((sexp (read fileh)))
 312 +  (let ((sexp (read-syntax "d:\\Code\\boalisp\\lineno.boa" fileh)))
 313      (if (eof-object? sexp)
 314          (list)
 315          (cons sexp (read-sexp fileh)))))
 316 @@ -323,6 +328,7 @@
 317    (set! *filename-hack* filename)
 318    (call-with-input-file filename
 319      (lambda (i)
 320 +      (port-count-lines! i)
 321        (let* ((ast (@> Module "<DOCSTRING>" (@> Stmt (map T (read-sexp i)))))
 322               (_   (filename-hack! ast))
 323               (c   (@ (: "compiler" 'pycodegen 'InteractiveCodeGenerator) ast))
 324
 325 === modified file 'examples/test.boa'
 326 --- examples/test.boa   2007-05-18 11:20:08 +0000
 327 +++ examples/test.boa   2007-05-24 04:58:08 +0000
 328 @@ -1,6 +1,6 @@
 329
 330  (def foo (a b (c 99) (d 101))
 331 -  (print a)
 332 +  (print a3)
 333    (print b)
 334    (return (+ c d (+ c d) (+ d 3))))
 335
 336
 337 === modified file 'python.ss'
 338 --- python.ss   2007-05-18 11:20:08 +0000
 339 +++ python.ss   2007-05-29 20:11:30 +0000
 340 @@ -188,4 +188,14 @@
 341        ((_ node c1 ...)
 342         (@> node : (list c1 ...)))))
 343
 344 +  (define-syntax @>*
 345 +    (syntax-rules (:)
 346 +      ((_ node lineno : c-list)
 347 +       (let ((a (apply (ast (symbol->string 'node))
 348 +                       (map ss->py c-list))))
 349 +         (py/setattr a "lineno" (py/int lineno))
 350 +         a))
 351 +      ((_ node lineno c1 ...)
 352 +       (@>* node lineno : (list c1 ...)))))
 353 +
 354    'ok)
 355 \ No newline at end of file
 356