parser.scm

   1 (define (parse source)
   2
   3   (define (form? keyword source)
   4     (and (pair? source)
   5          (eq? (car source) keyword)))
   6
   7   (define (expect-form keyword source)
   8     (if (not (form? keyword source))
   9         (error "expected" keyword source)))
  10
  11   (define (get-id source)
  12     (expect-form 'six.identifier source)
  13     (cadr source))
  14
  15   (define (define-variable source cte cont)
  16     (let* ((id (get-id (cadr source)))
  17            (type (caddr source))
  18            (dims (cadddr source))
  19            (val (car (cddddr source))))
  20
  21       (define (def asts cte)
  22         (let* ((value
  23                 (alloc-value type))
  24                (ast
  25                 (new-def-variable asts id '() type value '()))
  26                (cte
  27                 (cte-extend cte (list ast))))
  28           (cont ast
  29                 cte)))
  30
  31       (if val
  32           (expression val cte (lambda (ast cte) (def (list ast) cte)))
  33           (def '() cte))))
  34
  35   (define (define-procedure source cte cont)
  36     (let* ((id (get-id (cadr source)))
  37            (proc (caddr source)))
  38       (expect-form 'six.procedure proc)
  39       (let* ((type
  40               (cadr proc))
  41              (params
  42               (map (lambda (x)
  43                      (let* ((type
  44                              (cadr x))
  45                             (value
  46                              (alloc-value type)))
  47                        (new-def-variable '() (get-id (car x)) '() type value '())))
  48                    (caddr proc)))
  49              (body
  50               (cadddr proc)))
  51         (expect-form 'six.procedure-body body)
  52         (let* ((value
  53                 (alloc-value type))
  54                (ast
  55                 (new-def-procedure '() id '() type value params))
  56                (cte
  57                 (cte-extend cte (list ast))))
  58           (multi-link-parent! params ast)
  59           (block body
  60                  (cte-extend cte params)
  61                  (lambda (body-ast body-cte)
  62                    (ast-subasts-set! ast (list body-ast))
  63                    (link-parent! body-ast ast)
  64                    (cont ast
  65                          cte)))))))
  66
  67   (define (block source cte cont)
  68     (define (b source cte cont)
  69       (if (null? source)
  70           (cont '() cte)
  71           (let ((head (car source))
  72                 (tail (cdr source)))
  73             (if (or (form? 'six.label head) ; we complete the block with a list of named blocks
  74                     (form? 'six.case  head))
  75                 (named-block-list source
  76                                   cte
  77                                   cont) ; will return a list of named blocks
  78                 (statement head
  79                            cte
  80                            (lambda (ast cte)
  81                              (b tail
  82                                 cte
  83                                 (lambda (asts cte)
  84                                   (cont (cons ast asts)
  85                                         cte)))))))))
  86     (b (cdr source)
  87        cte
  88        (lambda (asts cte)
  89          (cont (new-block asts)
  90                cte))))
  91
  92   ;; returns a list of the named blocks (implicit blocks delimited by labels) present in the given tree
  93   ;; useful for switch and goto
  94   (define (named-block-list source cte cont)
  95     (define (b source cte cont name body-so-far)
  96       (if (null? source)
  97           (cont (list (new-named-block name body-so-far)) ; last block
  98                 cte)
  99           (let ((curr (car source)))
 100             (if (or (form? 'six.label curr) ; we reached another named block
 101                     (form? 'six.case  curr))
 102                 (named-block-list source
 103                                   cte
 104                                   (lambda (named-blocks cte)
 105                                     (cont (cons (new-named-block name body-so-far)
 106                                                 named-blocks)
 107                                           cte)))
 108                 (statement curr
 109                            cte
 110                            (lambda (ast cte)
 111                              (b (cdr source)
 112                                 cte
 113                                 cont
 114                                 name
 115                                 (append body-so-far (list ast)))))))))
 116     (let ((new-cont
 117            (lambda (name cte)
 118              (b (cdr source)
 119                 cte
 120                 cont
 121                 name
 122                 '()))))
 123       (if (form? 'six.case (car source)) ; the label is a case
 124         (literal (cadar source)
 125                  cte
 126                  (lambda (name cte)
 127                    (new-cont (list 'case (literal-val name)) cte)))
 128         (new-cont (cadar source) cte)))) ; ordinary label
 129
 130   (define (statement source cte cont)
 131     (cond ((form? 'six.define-variable source)
 132            (define-variable source cte cont))
 133           ((form? 'six.if source)
 134            (if (null? (cdddr source))
 135                (if1 source cte cont)
 136                (if2 source cte cont)))
 137           ((form? 'six.switch source)
 138            (switch source cte cont))
 139           ((form? 'six.while source)
 140            (while source cte cont))
 141           ((form? 'six.do-while source)
 142            (do-while source cte cont))
 143           ((form? 'six.for source)
 144            (for source cte cont))
 145           ((form? 'six.return source)
 146            (return source cte cont))
 147           ((form? 'six.break source)
 148            (break source cte cont))
 149           ((form? 'six.continue source)
 150            (continue source cte cont))
 151           ((form? 'six.goto source)
 152            (goto source cte cont))
 153           ((form? 'six.compound source)
 154            (block source cte cont))
 155           (else
 156            (expression  source cte cont))))
 157
 158   (define (return source cte cont)
 159
 160     (define (ret asts cte)
 161       (cont (new-return asts)
 162             cte))
 163
 164     (if (null? (cdr source))
 165         (ret '() cte)
 166         (expression (cadr source)
 167                     cte
 168                     (lambda (ast cte)
 169                       (ret (list ast) cte)))))
 170
 171   (define (break source cte cont)
 172     (cont (new-break)
 173           cte))
 174
 175   (define (continue source cte cont)
 176     (cont (new-continue)
 177           cte))
 178
 179   (define (goto source cte cont)
 180     (cont (new-goto (cadadr source)) ; label
 181           cte))
 182
 183   (define (if1 source cte cont)
 184     (expression (cadr source)
 185                 cte
 186                 (lambda (ast1 cte)
 187                   (statement (caddr source)
 188                              cte
 189                              (lambda (ast2 cte)
 190                                (cont (new-if (list ast1 ast2))
 191                                      cte))))))
 192
 193   (define (if2 source cte cont)
 194     (expression (cadr source)
 195                 cte
 196                 (lambda (ast1 cte)
 197                   (statement (caddr source)
 198                              cte
 199                              (lambda (ast2 cte)
 200                                (statement (cadddr source)
 201                                           cte
 202                                           (lambda (ast3 cte)
 203                                             (cont (new-if (list ast1 ast2 ast3))
 204                                                   cte))))))))
 205
 206   (define (switch source cte cont)
 207     (expression (cadr source)
 208                 cte
 209                 (lambda (ast1 cte) ; we matched the paren expr
 210                   (expect-form 'six.compound (caddr source))
 211                   (block (caddr source)
 212                          cte
 213                          (lambda (ast2 cte)
 214                            (cont (new-switch (cons ast1 (ast-subasts ast2))) ; we only need the contents of the generated block, which would be a named block list
 215                                  cte))))))
 216
 217   (define (while source cte cont)
 218     (expression (cadr source)
 219                 cte
 220                 (lambda (ast1 cte)
 221                   (statement (caddr source)
 222                              cte
 223                              (lambda (ast2 cte)
 224                                (cont (new-while (list ast1 ast2))
 225                                      cte))))))
 226
 227   (define (do-while source cte cont)
 228     (statement (cadr source)
 229                cte
 230                (lambda (ast1 cte)
 231                  (expression (caddr source)
 232                              cte
 233                              (lambda (ast2 cte)
 234                                (cont (new-do-while (list ast1 ast2))
 235                                      cte))))))
 236
 237   (define (for source cte cont)
 238
 239     (define (opt-expr source cte cont)
 240       (if source
 241           (expression source cte cont)
 242           (cont #f cte)))
 243
 244     (statement (cadr source)
 245                cte
 246                (lambda (ast1 cte)
 247                  (opt-expr (caddr source)
 248                            cte
 249                            (lambda (ast2 cte)
 250                              (opt-expr (cadddr source)
 251                                        cte
 252                                        (lambda (ast3 cte)
 253                                          (statement (car (cddddr source))
 254                                                     cte
 255                                                     (lambda (ast4 cte)
 256                                                       (cont (new-for
 257                                                              (list ast1
 258                                                                    (or ast2
 259                                                                        (new-literal 'int 1))
 260                                                                    (or ast3
 261                                                                        (new-block '()))
 262                                                                    ast4))
 263                                                             cte))))))))))
 264
 265   (define (expression source cte cont)
 266     (cond ((form? 'six.literal source)
 267            (literal source cte cont))
 268           ((form? 'six.identifier source)
 269            (ref source cte cont))
 270           ((form? 'six.call source)
 271            (call source cte cont))
 272           ((operation? source)
 273            =>
 274            (lambda (op)
 275              (operation op source cte cont)))
 276           (else
 277            (error "expected expression" source))))
 278
 279   (define (operation op source cte cont)
 280     (if (op1? op)
 281         (expression (cadr source)
 282                     cte
 283                     (lambda (ast1 cte)
 284                       (let ((ast
 285                              (new-oper (list ast1) #f op)))
 286                         (expr-type-set! ast ((op-type-rule op) ast))
 287                         (cont ((op-constant-fold op) ast)
 288                               cte))))
 289         (expression (cadr source)
 290                     cte
 291                     (lambda (ast1 cte)
 292                       (expression (caddr source)
 293                                   cte
 294                                   (lambda (ast2 cte)
 295                                     (let ((ast
 296                                            (new-oper (list ast1 ast2) #f op)))
 297                                       (expr-type-set! ast ((op-type-rule op) ast))
 298                                       (cont ((op-constant-fold op) ast)
 299                                             cte))))))))
 300
 301   (define (call source cte cont)
 302     (let* ((id (get-id (cadr source)))
 303            (binding (cte-lookup cte id)))
 304       (if (def-procedure? binding)
 305           (expressions (cddr source)
 306                        cte
 307                        (lambda (args cte)
 308                          (cont (new-call args (def-procedure-type binding) binding)
 309                                cte)))
 310           (error "expected procedure" source))))
 311
 312   (define (expressions source cte cont)
 313     (cond ((null? source)
 314            (cont '()
 315                  cte))
 316           (else
 317            (let ((head (car source))
 318                  (tail (cdr source)))
 319              (expression head
 320                          cte
 321                          (lambda (ast cte)
 322                            (expressions tail
 323                                         cte
 324                                         (lambda (asts cte)
 325                                           (cont (cons ast asts)
 326                                                 cte)))))))))
 327
 328   (define (literal source cte cont)
 329     (cont (new-literal 'int (cadr source))
 330           cte))
 331
 332   (define (ref source cte cont)
 333     (let* ((id (cadr source))
 334            (binding (cte-lookup cte id)))
 335       (if (def-variable? binding)
 336           (cont (new-ref (def-variable-type binding) binding)
 337                 cte)
 338           (error "expected variable" source))))
 339
 340   (define (toplevel source cte cont) ;; TODO have an implicit main
 341     (cond ((form? 'six.define-variable source)
 342            (define-variable source cte cont))
 343           ((form? 'six.define-procedure source)
 344            (define-procedure source cte cont))
 345           (else
 346            (statement source cte cont))))
 347
 348   (define (program source cte cont)
 349
 350     (define (p source cte cont)
 351       (cond ((null? source)
 352              (cont '()
 353                    cte))
 354             (else
 355              (let ((head (car source))
 356                    (tail (cdr source)))
 357                (toplevel head
 358                          cte
 359                          (lambda (ast cte)
 360                            (p tail
 361                               cte
 362                               (lambda (asts cte)
 363                                 (cont (cons ast asts)
 364                                       cte)))))))))
 365
 366     (p source
 367        cte
 368        (lambda (asts cte)
 369          (cont (new-program asts)
 370                cte))))
 371
 372   (program source
 373            (initial-cte)
 374            (lambda (ast cte)
 375              ast)))