parser.scm

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