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