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