parser.scm

   1 (define (parse source)
   2
   3   (define current-def-proc-id #f)
   4
   5   (define (form? keyword source)
   6     (and (pair? source)
   7          (eq? (car source) keyword)))
   8
   9   (define (expect-form keyword source)
  10     (if (not (form? keyword source))
  11         (error "expected" keyword source)))
  12
  13   (define (get-id source)
  14     (expect-form 'six.identifier source)
  15     (cadr source))
  16
  17   (define (define-variable source cte cont)
  18     (let* ((id (get-id (cadr source)))
  19            (type (caddr source))
  20            (dims (cadddr source))
  21            (val (car (cddddr source))))
  22
  23       ;; variables which, when found in programs, have special meanings
  24       ;; when any of these are encountered, its associated thunk is
  25       ;; called
  26       (define special-variables
  27         (list ;; TODO fit with the predefined variables in cte.scm ?
  28          (cons 'SIXPIC_MEMORY_DIVIDE
  29                (lambda ()
  30                  (set! memory-divide (cadr val)) ; must be a literal
  31                  (expression val cte (lambda (ast cte)
  32                                        (def (list ast) cte)))))))
  33
  34
  35       (define (def asts cte)
  36         (let* ((value
  37                 (alloc-value type current-def-proc-id id))
  38                (ast
  39                 (new-def-variable
  40                  asts id '() type value '() current-def-proc-id))
  41                (cte
  42                 (cte-extend cte (list ast))))
  43           (cont ast
  44                 cte)))
  45       ;; if it's a special variable, call its associated thunk instead
  46       (let ((target (assq id special-variables)))
  47         (if target
  48             ((cdr target))
  49             (if val
  50                 (expression val cte (lambda (ast cte) (def (list ast) cte)))
  51                 (def '() cte))))))
  52
  53   (define (define-procedure source cte cont)
  54     (let* ((id (get-id (cadr source)))
  55            (proc (caddr source)))
  56       (expect-form 'six.procedure proc)
  57       (set! current-def-proc-id id)
  58       (let* ((type
  59               (cadr proc))
  60              (params
  61               (map (lambda (x)
  62                      (let* ((var-id (get-id (car x)))
  63                             (type   (cadr x))
  64                             (value  (alloc-value type id var-id)))
  65                        (new-def-variable '() var-id '() type value '() id))) ;; TODO allocate the value inside new-def-variable ?
  66                    (caddr proc)))
  67              (body
  68               (cadddr proc)))
  69         (expect-form 'six.procedure-body body)
  70         (let* ((value
  71                 (alloc-value type id id))
  72                (ast
  73                 (new-def-procedure '() id '() type value params))
  74                (cte
  75                 (cte-extend cte (list ast))))
  76           (multi-link-parent! params ast)
  77           (let ((res (block body
  78                             (cte-extend cte params)
  79                             (lambda (body-ast body-cte)
  80                               (ast-subasts-set! ast (list body-ast))
  81                               (link-parent! body-ast ast)
  82                               (cont ast
  83                                     cte)))))
  84             (set! current-def-proc-id #f)
  85             res)))))
  86
  87   (define (block source cte cont)
  88     (define (b source cte cont)
  89       (if (null? source)
  90           (cont '() cte)
  91           (let ((head (car source))
  92                 (tail (cdr source)))
  93             (if (or (form? 'six.label head) ; we complete the block with a list of named blocks
  94                     (form? 'six.case  head))
  95                 (named-block-list source
  96                                   cte
  97                                   cont) ; will return a list of named blocks
  98                 (statement head
  99                            cte
 100                            (lambda (ast cte)
 101                              (b tail
 102                                 cte
 103                                 (lambda (asts cte)
 104                                   (cont (cons ast asts)
 105                                         cte)))))))))
 106     (b (cdr source)
 107        cte
 108        (lambda (asts cte)
 109          (cont (new-block asts)
 110                cte))))
 111
 112   ;; handles named blocks (implicit blocks delimited by labels)
 113   ;; useful for switch and goto
 114   (define (named-block-list source cte cont)
 115     (define (b source cte cont name body-so-far)
 116       (if (null? source)
 117           (cont (list (new-named-block name body-so-far)) ; last block
 118                 cte)
 119           (let ((curr (car source)))
 120             (if (or (form? 'six.label curr) ; we reached another named block
 121                     (form? 'six.case  curr))
 122                 (named-block-list source
 123                                   cte
 124                                   (lambda (named-blocks cte)
 125                                     (cont (cons (new-named-block name body-so-far)
 126                                                 named-blocks)
 127                                           cte)))
 128                 (statement curr
 129                            cte
 130                            (lambda (ast cte)
 131                              (b (cdr source)
 132                                 cte
 133                                 cont
 134                                 name
 135                                 (append body-so-far (list ast)))))))))
 136     (let ((new-cont
 137            (lambda (name cte)
 138              (statement (caddar source)
 139                         cte
 140                         (lambda (ast cte)
 141                           (b (cdr source)
 142                              cte
 143                              cont
 144                              name
 145                              ;; the first statement is in the case/label form
 146                              (list ast)))))))
 147
 148       (if (form? 'six.case (car source)) ; the label is a case
 149           (literal (cadar source)
 150                    cte
 151                    (lambda (name cte)
 152                      (new-cont (list 'case (literal-val name)) cte)))
 153           (new-cont (cadar source) cte)))) ; ordinary label
 154
 155   (define (statement source cte cont)
 156     (cond ((form? 'six.define-variable source)
 157            (define-variable source cte cont))
 158           ((form? 'six.if source)
 159            (if (null? (cdddr source))
 160                (if1 source cte cont)
 161                (if2 source cte cont)))
 162           ((form? 'six.switch source)
 163            (switch source cte cont))
 164           ((form? 'six.while source)
 165            (while source cte cont))
 166           ((form? 'six.do-while source)
 167            (do-while source cte cont))
 168           ((form? 'six.for source)
 169            (for source cte cont))
 170           ((form? 'six.return source)
 171            (return source cte cont))
 172           ((form? 'six.break source)
 173            (break source cte cont))
 174           ((form? 'six.continue source)
 175            (continue source cte cont))
 176           ((form? 'six.goto source)
 177            (goto source cte cont))
 178           ((form? 'six.compound source)
 179            (block source cte cont))
 180           (else
 181            (expression  source cte cont))))
 182
 183   (define (return source cte cont)
 184
 185     (define (ret asts cte)
 186       (cont (new-return asts)
 187             cte))
 188
 189     (if (null? (cdr source))
 190         (ret '() cte)
 191         (expression (cadr source)
 192                     cte
 193                     (lambda (ast cte)
 194                       (ret (list ast) cte)))))
 195
 196   (define (break source cte cont)
 197     (cont (new-break)
 198           cte))
 199
 200   (define (continue source cte cont)
 201     (cont (new-continue)
 202           cte))
 203
 204   (define (goto source cte cont)
 205     (cont (new-goto (cadadr source)) ; label
 206           cte))
 207
 208   (define (if1 source cte cont)
 209     (expression (cadr source)
 210                 cte
 211                 (lambda (ast1 cte)
 212                   (statement (caddr source)
 213                              cte
 214                              (lambda (ast2 cte)
 215                                (cont (new-if (list ast1 ast2))
 216                                      cte))))))
 217
 218   (define (if2 source cte cont)
 219     (expression (cadr source)
 220                 cte
 221                 (lambda (ast1 cte)
 222                   (statement (caddr source)
 223                              cte
 224                              (lambda (ast2 cte)
 225                                (statement (cadddr source)
 226                                           cte
 227                                           (lambda (ast3 cte)
 228                                             (cont (new-if (list ast1 ast2 ast3))
 229                                                   cte))))))))
 230
 231   (define (switch source cte cont)
 232     (expression (cadr source)
 233                 cte
 234                 (lambda (ast1 cte) ; we matched the paren expr
 235                   (expect-form 'six.compound (caddr source))
 236                   (block (caddr source)
 237                          cte
 238                          (lambda (ast2 cte)
 239                            (cont (new-switch (cons ast1 (ast-subasts ast2)))
 240                                  cte))))))
 241
 242   (define (while source cte cont)
 243     (expression (cadr source)
 244                 cte
 245                 (lambda (ast1 cte)
 246                   (statement (caddr source)
 247                              cte
 248                              (lambda (ast2 cte)
 249                                (cont (new-while (list ast1 ast2))
 250                                      cte))))))
 251
 252   (define (do-while source cte cont)
 253     (statement (cadr source)
 254                cte
 255                (lambda (ast1 cte)
 256                  (expression (caddr source)
 257                              cte
 258                              (lambda (ast2 cte)
 259                                (cont (new-do-while (list ast1 ast2))
 260                                      cte))))))
 261
 262   (define (for source cte cont)
 263
 264     (define (opt-expr source cte cont)
 265       (if source
 266           (expression source cte cont)
 267           (cont #f cte)))
 268
 269     (statement (cadr source)
 270                cte
 271                (lambda (ast1 cte)
 272                  (opt-expr (caddr source)
 273                            cte
 274                            (lambda (ast2 cte)
 275                              (opt-expr (cadddr source)
 276                                        cte
 277                                        (lambda (ast3 cte)
 278                                          (statement (car (cddddr source))
 279                                                     cte
 280                                                     (lambda (ast4 cte)
 281                                                       (cont (new-for
 282                                                              (list ast1
 283                                                                    (or ast2
 284                                                                        (new-literal 'byte 1))
 285                                                                    (or ast3
 286                                                                        (new-block '()))
 287                                                                    ast4))
 288                                                             cte))))))))))
 289
 290   (define (expression source cte cont)
 291     (cond ((form? 'six.literal source)
 292            (literal source cte cont))
 293           ((form? 'six.prefix source)
 294            ;; this is a hack to support hexadecimal values
 295            ;; SIX does not parse C-style hex values (0x...), but falls back on
 296            ;; the regular parser when it encounters Scheme-style hex values
 297            ;; (#x...) and wraps them in a six.prefix.
 298            ;; TODO support C-style hex values
 299            (literal `(six.literal ,(cadr source)) cte cont))
 300           ((form? 'six.identifier source)
 301            (ref source cte cont))
 302           ((form? 'six.call source)
 303            (call source cte cont))
 304           ((operation? source)
 305            =>
 306            (lambda (op)
 307              (operation op source cte cont)))
 308           (else
 309            (error "expected expression" source))))
 310
 311   (define (operation op source cte cont)
 312     (define (continue ast cte)
 313       (expr-type-set! ast ((op-type-rule op) ast))
 314       (cont (if fold-constants? ((op-constant-fold op) ast) ast)
 315             cte))
 316     (cond ((op1? op)
 317            (expression
 318             (cadr source)
 319             cte
 320             (lambda (ast1 cte)
 321               (continue (new-oper (list ast1) #f op) cte))))
 322           ((op2? op)
 323            (expression
 324             (cadr source)
 325             cte
 326             (lambda (ast1 cte)
 327               (expression
 328                (caddr source)
 329                cte
 330                (lambda (ast2 cte)
 331                  (continue (new-oper (list ast1 ast2) #f op) cte))))))
 332           (else ; ternary operator
 333            (expression
 334             (cadr source)
 335             cte
 336             (lambda (ast1 cte)
 337               (expression
 338                (caddr source)
 339                cte
 340                (lambda (ast2 cte)
 341                  (expression
 342                   (cadddr source)
 343                   cte
 344                   (lambda (ast3 cte)
 345                     (continue (new-oper (list ast1 ast2 ast3) #f op)
 346                               cte))))))))))
 347
 348   (define (call source cte cont)
 349     (let* ((id (get-id (cadr source)))
 350            (binding (cte-lookup cte id)))
 351       (if (def-procedure? binding)
 352           (expressions (cddr source)
 353                        cte
 354                        (lambda (args cte)
 355                          (cont (new-call args (def-procedure-type binding) binding)
 356                                cte)))
 357           (error "expected procedure" source))))
 358
 359   (define (expressions source cte cont)
 360     (cond ((null? source)
 361            (cont '()
 362                  cte))
 363           (else
 364            (let ((head (car source))
 365                  (tail (cdr source)))
 366              (expression head
 367                          cte
 368                          (lambda (ast cte)
 369                            (expressions tail
 370                                         cte
 371                                         (lambda (asts cte)
 372                                           (cont (cons ast asts)
 373                                                 cte)))))))))
 374
 375   (define (literal source cte cont)
 376     (let ((n (cadr source)))
 377       ;; note: literals have the smallest type they can fit in.
 378       ;; this is not standard, so more casts than usual might be needed to
 379       ;; avoid unfortunate truncations
 380       ;; this helps generate shorter code, and can be considered a domain
 381       ;; specific optimization
 382       (cont (new-literal (val->type n) n)
 383             cte)))
 384
 385   (define (ref source cte cont)
 386     (let* ((id (cadr source))
 387            (binding (cte-lookup cte id)))
 388       (if (def-variable? binding)
 389           (cont (new-ref (def-variable-type binding) binding)
 390                 cte)
 391           (error "expected variable" source))))
 392
 393   (define (toplevel source cte cont) ;; TODO have an implicit main
 394     (cond ((form? 'six.define-variable source)
 395            (define-variable source cte cont))
 396           ((form? 'six.define-procedure source)
 397            (define-procedure source cte cont))
 398           (else
 399            (statement source cte cont))))
 400
 401   (define (program source cte cont)
 402
 403     (define (p source cte cont)
 404       (cond ((null? source)
 405              (cont '()
 406                    cte))
 407             (else
 408              (let ((head (car source))
 409                    (tail (cdr source)))
 410                (toplevel head
 411                          cte
 412                          (lambda (ast cte)
 413                            (p tail
 414                               cte
 415                               (lambda (asts cte)
 416                                 (cont (cons ast asts)
 417                                       cte)))))))))
 418
 419     (p source
 420        cte
 421        (lambda (asts cte)
 422          (cont (new-program asts)
 423                cte))))
 424
 425   (program source
 426            initial-cte
 427            (lambda (ast cte)
 428              ast)))