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 ;; TODO use the predefined stuff in cte.scm ?
  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 ;; TODO pass it the first statement
 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   ;; TODO returns that ?
 146   (define (named-block-list source cte cont)
 147     (define (b source cte cont name body-so-far)
 148       (if (null? source)
 149           (cont (list (new-named-block name body-so-far)) ; last block
 150                 cte)
 151           (let ((curr (car source)))
 152             (if (or (form? 'six.label curr) ; we reached another named block
 153                     (form? 'six.case  curr))
 154                 (named-block-list source
 155                                   cte
 156                                   (lambda (named-blocks cte)
 157                                     (cont (cons (new-named-block name body-so-far)
 158                                                 named-blocks)
 159                                           cte)))
 160                 (statement curr
 161                            cte
 162                            (lambda (ast cte)
 163                              (b (cdr source)
 164                                 cte
 165                                 cont
 166                                 name
 167                                 (append body-so-far (list ast)))))))))
 168     (let ((new-cont
 169            (lambda (name cte)
 170              (statement (caddar source)
 171                         cte
 172                         (lambda (ast cte)
 173                           (b (cdr source)
 174                              cte
 175                              cont
 176                              name
 177                              ;; the first statement is in the case/label form
 178                              (list ast)))))))
 179
 180       (if (form? 'six.case (car source)) ; the label is a case
 181           (literal (cadar source)
 182                    cte
 183                    (lambda (name cte)
 184                      (new-cont (list 'case (literal-val name)) cte)))
 185           (new-cont (cadar source) cte)))) ; ordinary label
 186
 187   (define (statement source cte cont)
 188     (cond ((form? 'six.define-variable source)
 189            (define-variable source cte cont))
 190           ((form? 'six.if source)
 191            (if (null? (cdddr source))
 192                (if1 source cte cont)
 193                (if2 source cte cont)))
 194           ((form? 'six.switch source)
 195            (switch source cte cont))
 196           ((form? 'six.while source)
 197            (while source cte cont))
 198           ((form? 'six.do-while source)
 199            (do-while source cte cont))
 200           ((form? 'six.for source)
 201            (for source cte cont))
 202           ((form? 'six.return source)
 203            (return source cte cont))
 204           ((form? 'six.break source)
 205            (break source cte cont))
 206           ((form? 'six.continue source)
 207            (continue source cte cont))
 208           ((form? 'six.goto source)
 209            (goto source cte cont))
 210           ((form? 'six.compound source)
 211            (block source cte cont))
 212           (else
 213            (expression  source cte cont))))
 214
 215   (define (return source cte cont)
 216
 217     (define (ret asts cte)
 218       (cont (new-return asts)
 219             cte))
 220
 221     (if (null? (cdr source))
 222         (ret '() cte)
 223         (expression (cadr source)
 224                     cte
 225                     (lambda (ast cte)
 226                       (ret (list ast) cte)))))
 227
 228   (define (break source cte cont)
 229     (cont (new-break)
 230           cte))
 231
 232   (define (continue source cte cont)
 233     (cont (new-continue)
 234           cte))
 235
 236   (define (goto source cte cont)
 237     (cont (new-goto (cadadr source)) ; label
 238           cte))
 239
 240   (define (if1 source cte cont)
 241     (expression (cadr source)
 242                 cte
 243                 (lambda (ast1 cte)
 244                   (statement (caddr source)
 245                              cte
 246                              (lambda (ast2 cte)
 247                                (cont (new-if (list ast1 ast2))
 248                                      cte))))))
 249
 250   (define (if2 source cte cont)
 251     (expression (cadr source)
 252                 cte
 253                 (lambda (ast1 cte)
 254                   (statement (caddr source)
 255                              cte
 256                              (lambda (ast2 cte)
 257                                (statement (cadddr source)
 258                                           cte
 259                                           (lambda (ast3 cte)
 260                                             (cont (new-if (list ast1 ast2 ast3))
 261                                                   cte))))))))
 262
 263   (define (switch source cte cont)
 264     (expression (cadr source)
 265                 cte
 266                 (lambda (ast1 cte) ; we matched the paren expr
 267                   (expect-form 'six.compound (caddr source))
 268                   (block (caddr source)
 269                          cte
 270                          (lambda (ast2 cte)
 271                            (cont (new-switch (cons ast1 (ast-subasts ast2))) ; we only need the contents of the generated block, which would be a named block list
 272                                  cte))))))
 273
 274   (define (while source cte cont)
 275     (expression (cadr source)
 276                 cte
 277                 (lambda (ast1 cte)
 278                   (statement (caddr source)
 279                              cte
 280                              (lambda (ast2 cte)
 281                                (cont (new-while (list ast1 ast2))
 282                                      cte))))))
 283
 284   (define (do-while source cte cont)
 285     (statement (cadr source)
 286                cte
 287                (lambda (ast1 cte)
 288                  (expression (caddr source)
 289                              cte
 290                              (lambda (ast2 cte)
 291                                (cont (new-do-while (list ast1 ast2))
 292                                      cte))))))
 293
 294   (define (for source cte cont)
 295
 296     (define (opt-expr source cte cont)
 297       (if source
 298           (expression source cte cont)
 299           (cont #f cte)))
 300
 301     (statement (cadr source)
 302                cte
 303                (lambda (ast1 cte)
 304                  (opt-expr (caddr source)
 305                            cte
 306                            (lambda (ast2 cte)
 307                              (opt-expr (cadddr source)
 308                                        cte
 309                                        (lambda (ast3 cte)
 310                                          (statement (car (cddddr source))
 311                                                     cte
 312                                                     (lambda (ast4 cte)
 313                                                       (cont (new-for
 314                                                              (list ast1
 315                                                                    (or ast2
 316                                                                        (new-literal 'int 1))
 317                                                                    (or ast3
 318                                                                        (new-block '()))
 319                                                                    ast4))
 320                                                             cte))))))))))
 321
 322   (define (expression source cte cont)
 323     (cond ((form? 'six.literal source)
 324            (literal source cte cont))
 325           ((form? 'six.identifier source)
 326            (ref source cte cont))
 327           ((form? 'six.call source)
 328            (call source cte cont))
 329           ((operation? source)
 330            =>
 331            (lambda (op)
 332              (operation op source cte cont)))
 333           (else
 334            (error "expected expression" source))))
 335
 336   (define (operation op source cte cont)
 337     (if (op1? op)
 338         (expression (cadr source)
 339                     cte
 340                     (lambda (ast1 cte)
 341                       (let ((ast
 342                              (new-oper (list ast1) #f op)))
 343                         (expr-type-set! ast ((op-type-rule op) ast))
 344                         (cont ((op-constant-fold op) ast)
 345                               cte))))
 346         (expression (cadr source)
 347                     cte
 348                     (lambda (ast1 cte)
 349                       (expression (caddr source)
 350                                   cte
 351                                   (lambda (ast2 cte)
 352                                     (let ((ast
 353                                            (new-oper (list ast1 ast2) #f op)))
 354                                       (expr-type-set! ast ((op-type-rule op) ast))
 355                                       (cont ((op-constant-fold op) ast)
 356                                             cte))))))))
 357
 358   (define (call source cte cont)
 359     (let* ((id (get-id (cadr source)))
 360            (binding (cte-lookup cte id)))
 361       (if (def-procedure? binding)
 362           (expressions (cddr source)
 363                        cte
 364                        (lambda (args cte)
 365                          (cont (new-call args (def-procedure-type binding) binding)
 366                                cte)))
 367           (error "expected procedure" source))))
 368
 369   (define (expressions source cte cont)
 370     (cond ((null? source)
 371            (cont '()
 372                  cte))
 373           (else
 374            (let ((head (car source))
 375                  (tail (cdr source)))
 376              (expression head
 377                          cte
 378                          (lambda (ast cte)
 379                            (expressions tail
 380                                         cte
 381                                         (lambda (asts cte)
 382                                           (cont (cons ast asts)
 383                                                 cte)))))))))
 384
 385   (define (literal source cte cont)
 386     (let ((n (cadr source)))
 387       (cont (new-literal (cond ((and (>= n 0) (< n 256))
 388                                 'byte)
 389                                ((and (>= n 0) (< n 65536))
 390                                 'int16)
 391                                (else
 392                                 'int))
 393                          n)
 394           cte)))
 395
 396   (define (ref source cte cont)
 397     (let* ((id (cadr source))
 398            (binding (cte-lookup cte id)))
 399       (if (def-variable? binding)
 400           (cont (new-ref (def-variable-type binding) binding)
 401                 cte)
 402           (error "expected variable" source))))
 403
 404   (define (toplevel source cte cont) ;; TODO have an implicit main
 405     (cond ((form? 'six.define-variable source)
 406            (define-variable source cte cont))
 407           ((form? 'six.define-procedure source)
 408            (define-procedure source cte cont))
 409           (else
 410            (statement source cte cont))))
 411
 412   (define (program source cte cont)
 413
 414     (define (p source cte cont)
 415       (cond ((null? source)
 416              (cont '()
 417                    cte))
 418             (else
 419              (let ((head (car source))
 420                    (tail (cdr source)))
 421                (toplevel head
 422                          cte
 423                          (lambda (ast cte)
 424                            (p tail
 425                               cte
 426                               (lambda (asts cte)
 427                                 (cont (cons ast asts)
 428                                       cte)))))))))
 429
 430     (p source
 431        cte
 432        (lambda (asts cte)
 433          (cont (new-program asts)
 434                cte))))
 435
 436   (program source
 437            initial-cte
 438            (lambda (ast cte)
 439              ast)))