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.goto source)
 150            (goto source cte cont))
 151           ((form? 'six.compound source)
 152            (block source cte cont))
 153           (else
 154            (expression  source cte cont))))
 155
 156   (define (return source cte cont)
 157
 158     (define (ret asts cte)
 159       (cont (new-return asts)
 160             cte))
 161
 162     (if (null? (cdr source))
 163         (ret '() cte)
 164         (expression (cadr source)
 165                     cte
 166                     (lambda (ast cte)
 167                       (ret (list ast) cte)))))
 168
 169   (define (break source cte cont)
 170     (cont (new-break)
 171           cte))
 172
 173   (define (goto source cte cont)
 174     (cont (new-goto (cadadr source)) ; label
 175           cte))
 176
 177   (define (if1 source cte cont)
 178     (expression (cadr source)
 179                 cte
 180                 (lambda (ast1 cte)
 181                   (statement (caddr source)
 182                              cte
 183                              (lambda (ast2 cte)
 184                                (cont (new-if (list ast1 ast2))
 185                                      cte))))))
 186
 187   (define (if2 source cte cont)
 188     (expression (cadr source)
 189                 cte
 190                 (lambda (ast1 cte)
 191                   (statement (caddr source)
 192                              cte
 193                              (lambda (ast2 cte)
 194                                (statement (cadddr source)
 195                                           cte
 196                                           (lambda (ast3 cte)
 197                                             (cont (new-if (list ast1 ast2 ast3))
 198                                                   cte))))))))
 199
 200   (define (switch source cte cont)
 201     (expression (cadr source)
 202                 cte
 203                 (lambda (ast1 cte) ; we matched the paren expr
 204                   (expect-form 'six.compound (caddr source))
 205                   (block (caddr source)
 206                          cte
 207                          (lambda (ast2 cte)
 208                            (cont (new-switch (cons ast1 (ast-subasts ast2))) ; we only need the contents of the generated block, which would be a named block list
 209                                  cte))))))
 210
 211   (define (while source cte cont)
 212     (expression (cadr source)
 213                 cte
 214                 (lambda (ast1 cte)
 215                   (statement (caddr source)
 216                              cte
 217                              (lambda (ast2 cte)
 218                                (cont (new-while (list ast1 ast2))
 219                                      cte))))))
 220
 221   (define (do-while source cte cont)
 222     (statement (cadr source)
 223                cte
 224                (lambda (ast1 cte)
 225                  (expression (caddr source)
 226                              cte
 227                              (lambda (ast2 cte)
 228                                (cont (new-do-while (list ast1 ast2))
 229                                      cte))))))
 230
 231   (define (for source cte cont)
 232
 233     (define (opt-expr source cte cont)
 234       (if source
 235           (expression source cte cont)
 236           (cont #f cte)))
 237
 238     (statement (cadr source)
 239                cte
 240                (lambda (ast1 cte)
 241                  (opt-expr (caddr source)
 242                            cte
 243                            (lambda (ast2 cte)
 244                              (opt-expr (cadddr source)
 245                                        cte
 246                                        (lambda (ast3 cte)
 247                                          (statement (car (cddddr source))
 248                                                     cte
 249                                                     (lambda (ast4 cte)
 250                                                       (cont (new-for
 251                                                              (list ast1
 252                                                                    (or ast2
 253                                                                        (new-literal 'int 1))
 254                                                                    (or ast3
 255                                                                        (new-block '()))
 256                                                                    ast4))
 257                                                             cte))))))))))
 258
 259   (define (expression source cte cont)
 260     (cond ((form? 'six.literal source)
 261            (literal source cte cont))
 262           ((form? 'six.identifier source)
 263            (ref source cte cont))
 264           ((form? 'six.call source)
 265            (call source cte cont))
 266           ((operation? source)
 267            =>
 268            (lambda (op)
 269              (operation op source cte cont)))
 270           (else
 271            (error "expected expression" source))))
 272
 273   (define (operation op source cte cont)
 274     (if (op1? op)
 275         (expression (cadr source)
 276                     cte
 277                     (lambda (ast1 cte)
 278                       (let ((ast
 279                              (new-oper (list ast1) #f op)))
 280                         (expr-type-set! ast ((op-type-rule op) ast))
 281                         (cont ((op-constant-fold op) ast)
 282                               cte))))
 283         (expression (cadr source)
 284                     cte
 285                     (lambda (ast1 cte)
 286                       (expression (caddr source)
 287                                   cte
 288                                   (lambda (ast2 cte)
 289                                     (let ((ast
 290                                            (new-oper (list ast1 ast2) #f op)))
 291                                       (expr-type-set! ast ((op-type-rule op) ast))
 292                                       (cont ((op-constant-fold op) ast)
 293                                             cte))))))))
 294
 295   (define (call source cte cont)
 296     (let* ((id (get-id (cadr source)))
 297            (binding (cte-lookup cte id)))
 298       (if (def-procedure? binding)
 299           (expressions (cddr source)
 300                        cte
 301                        (lambda (args cte)
 302                          (cont (new-call args (def-procedure-type binding) binding)
 303                                cte)))
 304           (error "expected procedure" source))))
 305
 306   (define (expressions source cte cont)
 307     (cond ((null? source)
 308            (cont '()
 309                  cte))
 310           (else
 311            (let ((head (car source))
 312                  (tail (cdr source)))
 313              (expression head
 314                          cte
 315                          (lambda (ast cte)
 316                            (expressions tail
 317                                         cte
 318                                         (lambda (asts cte)
 319                                           (cont (cons ast asts)
 320                                                 cte)))))))))
 321
 322   (define (literal source cte cont)
 323     (cont (new-literal 'int (cadr source))
 324           cte))
 325
 326   (define (ref source cte cont)
 327     (let* ((id (cadr source))
 328            (binding (cte-lookup cte id)))
 329       (if (def-variable? binding)
 330           (cont (new-ref (def-variable-type binding) binding)
 331                 cte)
 332           (error "expected variable" source))))
 333
 334   (define (toplevel source cte cont) ;; TODO have an implicit main
 335     (cond ((form? 'six.define-variable source)
 336            (define-variable source cte cont))
 337           ((form? 'six.define-procedure source)
 338            (define-procedure source cte cont))
 339           (else
 340            (statement source cte cont))))
 341
 342   (define (program source cte cont)
 343
 344     (define (p source cte cont)
 345       (cond ((null? source)
 346              (cont '()
 347                    cte))
 348             (else
 349              (let ((head (car source))
 350                    (tail (cdr source)))
 351                (toplevel head
 352                          cte
 353                          (lambda (ast cte)
 354                            (p tail
 355                               cte
 356                               (lambda (asts cte)
 357                                 (cont (cons ast asts)
 358                                       cte)))))))))
 359
 360     (p source
 361        cte
 362        (lambda (asts cte)
 363          (cont (new-program asts)
 364                cte))))
 365
 366   (program source
 367            (initial-cte)
 368            (lambda (ast cte)
 369              ast)))