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