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