parser.scm

   1 ;;;; File: "parser.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 parse-program
   7   (lambda (expr env)
   8     (let ((x (parse-top expr env)))
   9       (cond ((null? x)
  10              (parse 'value #f env))
  11             ((null? (cdr x))
  12              (car x))
  13             (else
  14              (let ((r (make-seq #f x)))
  15                (for-each (lambda (y) (node-parent-set! y r)) x)
  16                r))))))
  17
  18 (define parse-top
  19   (lambda (expr env)
  20     (cond ((and (pair? expr)
  21                 (eq? (car expr) 'define-macro))
  22            (set! *macros*
  23                  (cons (cons (caadr expr)
  24                              (eval `(lambda ,(cdadr expr) . ,(cddr expr))))
  25                        *macros*))
  26            '())
  27           ((and (pair? expr)
  28                 (eq? (car expr) 'begin))
  29            (parse-top-list (cdr expr) env))
  30           ((and (pair? expr)
  31                 (eq? (car expr) 'hide))
  32            (parse-top-hide (cadr expr)  (cddr expr) env))
  33           ((and (pair? expr)
  34                 (eq? (car expr) 'rename))
  35            (parse-top-rename (cadr expr)  (cddr expr) env))
  36           ((and (pair? expr)
  37                 (eq? (car expr) 'define))
  38            (let ((var
  39                   (if (pair? (cadr expr))
  40                       (car (cadr expr))
  41                       (cadr expr)))
  42                  (val
  43                   (if (pair? (cadr expr))
  44                       (cons 'lambda (cons (cdr (cadr expr)) (cddr expr)))
  45                       (caddr expr))))
  46              (let* ((var2 (env-lookup env var))
  47                     (val2 (parse 'value val env))
  48                     (r (make-def #f (list val2) var2)))
  49                (node-parent-set! val2 r)
  50                (var-defs-set! var2 (cons r (var-defs var2)))
  51                (list r))))
  52           (else
  53            (list (parse 'value expr env))))))
  54
  55 (define parse-top-list
  56   (lambda (lst env)
  57     (if (pair? lst)
  58         (append (parse-top (car lst) env)
  59                 (parse-top-list (cdr lst) env))
  60         '())))
  61
  62 (define parse-top-hide
  63   (lambda (renamings body env)
  64     (append
  65      (parse-top-list body
  66                      (env-extend-renamings env renamings))
  67      ;; (parse-top-list
  68      ;;       (map (lambda (x) (list 'define (car x) (cadr x))) renamings)
  69      ;;       env)
  70      )))
  71
  72 (define parse-top-rename
  73   (lambda (renamings body env)
  74     (parse-top-list body
  75                     (env-extend-renamings env renamings))))
  76
  77 (define parse
  78   (lambda (use expr env)
  79     (cond ((self-eval? expr)
  80            (make-cst #f '() expr))
  81           ((symbol? expr)
  82            (let* ((var (env-lookup env expr))
  83                   (r (make-ref #f '() var)))
  84              (var-refs-set! var (cons r (var-refs var)))
  85              (if (not (var-global? var))
  86                  (let* ((unbox (parse 'value '#%unbox env))
  87                         (app (make-call #f (list unbox r))))
  88                    (node-parent-set! r app)
  89                    (node-parent-set! unbox app)
  90                    app)
  91                  r)))
  92           ((and (pair? expr)
  93                 (assq (car expr) *macros*))
  94            => (lambda (p) (parse use (apply (cdr p) (cdr expr)) env)))
  95           ((and (pair? expr)
  96                 (eq? (car expr) 'set!))
  97            (let ((var (env-lookup env (cadr expr))))
  98              (if (var-global? var)
  99                  (let* ((val (parse 'value (caddr expr) env))
 100                         (r (make-set #f (list val) var)))
 101                    (node-parent-set! val r)
 102                    (var-sets-set! var (cons r (var-sets var)))
 103                    r)
 104                  (let* ((body (parse 'value (caddr expr) env))
 105                         (ref (make-ref #f '() var))
 106                         (bs (make-ref #f '() (env-lookup env '#%box-set!)))
 107                         (r (make-call #f (list bs ref body))))
 108                    (node-parent-set! body r)
 109                    (node-parent-set! ref r)
 110                    (node-parent-set! bs r)
 111                    (var-sets-set! var (cons r (var-sets var)))
 112                    r))))
 113           ((and (pair? expr)
 114                 (eq? (car expr) 'quote))
 115            (make-cst #f '() (cadr expr)))
 116           ((and (pair? expr)
 117                 (eq? (car expr) 'if))
 118            (let* ((a (parse 'test (cadr expr) env))
 119                   (b (parse use (caddr expr) env))
 120                   (c (if (null? (cdddr expr))
 121                          (make-cst #f '() #f)
 122                          (parse use (cadddr expr) env)))
 123                   (r (make-if #f (list a b c))))
 124              (node-parent-set! a r)
 125              (node-parent-set! b r)
 126              (node-parent-set! c r)
 127              r))
 128           ((and (pair? expr)
 129                 (eq? (car expr) 'lambda))
 130            (let* ((pattern (cadr expr))
 131                   (ids (extract-ids pattern))
 132                   ;; parent children params rest? entry-label
 133                   (r (make-prc #f '() #f (has-rest-param? pattern) #f))
 134                   (new-env (env-extend env ids r))
 135                   (body (parse-body (cddr expr) new-env))
 136                   (mut-vars
 137                    (apply append
 138                           (map (lambda (id)
 139                                  (let ((v (env-lookup new-env id)))
 140                                    (if (mutable-var? v) (list v) '())))
 141                                ids))))
 142              (if (null? mut-vars)
 143                  (begin
 144                    (prc-params-set! r
 145                                     (map (lambda (id) (env-lookup new-env id))
 146                                          ids))
 147                    (node-children-set! r (list body))
 148                    (node-parent-set! body r)
 149                    r)
 150                  (let* ((prc (make-prc #f (list body) mut-vars #f #f))
 151                         (new-vars (map var-id mut-vars))
 152                         (tmp-env (env-extend env new-vars r))
 153                         (app
 154                          (make-call
 155                           r
 156                           (cons prc
 157                                 (map (lambda (id)
 158                                        (parse 'value
 159                                               (cons '#%box (cons id '()))
 160                                               tmp-env))
 161                                      new-vars)))))
 162                    ;; (lambda (a b) (set! a b))
 163                    ;; => (lambda (_a b) ((lambda (a) (box-set! a b)) (box _a)))
 164                    (for-each (lambda (var) (var-defs-set! var (list prc)))
 165                              mut-vars)
 166                    (for-each (lambda (n) (node-parent-set! n app))
 167                              (cdr (node-children app)))
 168                    (node-parent-set! prc app)
 169                    (prc-params-set! r
 170                                     (map (lambda (id) (env-lookup tmp-env id))
 171                                          ids))
 172                    (node-children-set! r (list app))
 173                    (node-parent-set! body prc)
 174                    r))))
 175           ((and (pair? expr)
 176                 (eq? (car expr) 'letrec))
 177            (let ((ks (map car (cadr expr)))
 178                  (vs (map cadr (cadr expr))))
 179              (parse use
 180                     (cons 'let
 181                           (cons (map (lambda (k) (list k #f)) ks)
 182                                 (append (map (lambda (k v) (list 'set! k v))
 183                                              ks vs) ; letrec*
 184                                         (cddr expr))))
 185                     env)))
 186           ((and (pair? expr)
 187                 (eq? (car expr) 'begin))
 188            (let* ((exprs (map (lambda (x) (parse 'value x env)) (cdr expr)))
 189                   (r (make-seq #f exprs)))
 190              (for-each (lambda (x) (node-parent-set! x r)) exprs)
 191              r))
 192           ((and (pair? expr)
 193                 (eq? (car expr) 'let))
 194            (if (symbol? (cadr expr))
 195                (parse use
 196                       `(letrec ((,(cadr expr) (lambda ,(map car (caddr expr)) .
 197                                                       ,(cdddr expr))))
 198                          (,(cadr expr) . ,(map cadr (caddr expr))))
 199                       env)
 200                (parse use
 201                       (cons (cons 'lambda
 202                                   (cons (map car (cadr expr))
 203                                         (cddr expr)))
 204                             (map cadr (cadr expr)))
 205                       env)))
 206           ((and (pair? expr)
 207                 (eq? (car expr) 'let*))
 208            (if (null? (cadr expr))
 209                (parse use
 210                       (cons 'let (cdr expr))
 211                       env)
 212                (parse use
 213                       (list 'let
 214                             (list (list (caar (cadr expr))
 215                                         (cadar (cadr expr))))
 216                             (cons 'let*
 217                                   (cons (cdr (cadr expr))
 218                                         (cddr expr))))
 219                       env)))
 220           ((and (pair? expr)
 221                 (eq? (car expr) 'and))
 222            (cond ((null? (cdr expr))
 223                   (parse use
 224                          #t
 225                          env))
 226                  ((null? (cddr expr))
 227                   (parse use
 228                          (cadr expr)
 229                          env))
 230                  (else
 231                   (parse use
 232                          (list 'if
 233                                (cadr expr)
 234                                (cons 'and (cddr expr))
 235                                #f)
 236                          env))))
 237           ((and (pair? expr)
 238                 (eq? (car expr) 'or))
 239            (cond ((null? (cdr expr))
 240                   (parse use
 241                          #f
 242                          env))
 243                  ((null? (cddr expr))
 244                   (parse use
 245                          (cadr expr)
 246                          env))
 247                  ((eq? use 'test)
 248                   (parse use
 249                          (list 'if
 250                                (cadr expr)
 251                                #t
 252                                (cons 'or (cddr expr)))
 253                          env))
 254                  (else
 255                   (parse use
 256                          (let ((v (gensym)))
 257                            (list 'let
 258                                  (list (list v (cadr expr)))
 259                                  (list 'if
 260                                        v
 261                                        v
 262                                        (cons 'or (cddr expr)))))
 263                          env))))
 264           ;; primitive substitution here
 265           ;; TODO do this optimization in the following pass instead of at parse time ?
 266           ((and (pair? expr)
 267                 (assoc (car expr) substitute-primitives))
 268            =>
 269            (lambda (prim)
 270              (parse use
 271                     (cons (cdr prim) (cdr expr))
 272                     env)))
 273           ;; binary arthimetic operations can use primitives directly
 274           ((and (pair? expr)
 275                 (= (length (cdr expr)) 2)
 276                 (assoc (car expr) '((+ . #%+) (- . #%-) (* . #%*))))
 277            =>
 278            (lambda (prim)
 279              (parse use
 280                     (cons (cdr prim) (cdr expr))
 281                     env)))
 282           ((and (pair? expr)
 283                 (memq (car expr)
 284                       '(quote quasiquote unquote unquote-splicing lambda if
 285                         set! cond and or case let let* letrec begin do define
 286                         delay)))
 287            (compiler-error "the compiler does not implement the special form" (car expr)))
 288           ((pair? expr)
 289            (let* ((exprs (map (lambda (x) (parse 'value x env)) expr))
 290                   (r (make-call #f exprs)))
 291              (for-each (lambda (x) (node-parent-set! x r)) exprs)
 292              r))
 293           (else
 294            (compiler-error "unknown expression" expr)))))
 295
 296 (define parse-body
 297   (lambda (exprs env)
 298     (parse 'value (cons 'begin exprs) env)))
 299
 300 (define self-eval?
 301   (lambda (expr)
 302     (or (number? expr)
 303         (char? expr)
 304         (boolean? expr)
 305         (string? expr))))
 306
 307 (define extract-ids
 308   (lambda (pattern)
 309     (if (pair? pattern)
 310         (cons (car pattern) (extract-ids (cdr pattern)))
 311         (if (symbol? pattern)
 312             (cons pattern '())
 313             '()))))
 314
 315 (define has-rest-param?
 316   (lambda (pattern)
 317     (if (pair? pattern)
 318         (has-rest-param? (cdr pattern))
 319         (symbol? pattern))))
 320
 321 (define (adjust-unmutable-references! node)
 322   '(pretty-print (list unmut: (node->expr node)))
 323   (if (and (call? node)
 324            '(display "call ")
 325            (ref? (car (node-children node)))
 326            '(display "ref ")
 327            (eq? '#%unbox (var-id (ref-var (car (node-children node)))))
 328            '(display "unbox")
 329            (ref? (cadr (node-children node)))
 330            '(display "ref ")
 331            (not (mutable-var? (ref-var (cadr (node-children node)))))
 332            '(display "unmut! "))
 333       (let* ((parent (node-parent node)) (child (cadr (node-children node))))
 334         (node-parent-set! child parent)
 335         (if parent
 336             (node-children-set! parent
 337                                 (map (lambda (c) (if (eq? c node) child c))
 338                                      (node-children parent))))
 339         child)
 340       (begin (for-each (lambda (n) (adjust-unmutable-references! n))
 341                        (node-children node))
 342              node)))