shithub: femtolisp

ref: 14c196a5da48284123d615418c80b6fbc87d7f46
dir: /gen.lsp/

View raw version
(define opcodes '(
  ; C opcode, lisp compiler opcode, arg count, builtin lambda
    OP_LOADA0         loada0    #f      0
    OP_LOADA1         loada1    #f      0
    OP_LOADV          loadv     #f      0
    OP_BRF            brf       #f      0
    OP_POP            pop       #f      0
    OP_CALL           call      #f      0
    OP_TCALL          tcall     #f      0
    OP_LOADG          loadg     #f      0
    OP_LOADA          loada     #f      0
    OP_LOADC          loadc     #f      0
    OP_RET            ret       #f      0
    OP_DUP            dup       #f      0
    OP_CAR            car       1       (λ (x) (car x))
    OP_CDR            cdr       1       (λ (x) (cdr x))
    OP_CLOSURE        closure   #f      0
    OP_SETA           seta      #f      0
    OP_JMP            jmp       #f      0
    OP_LOADC0         loadc0    #f      0
    OP_PAIRP          pair?     1       (λ (x) (pair? x))
    OP_BRNE           brne      #f      0
    OP_LOADT          loadt     #f      0
    OP_LOAD0          load0     #f      0
    OP_LOADC1         loadc1    #f      0
    OP_AREF           aref      2       (λ (x y) (aref x y))
    OP_ATOMP          atom?     1       (λ (x) (atom? x))
    OP_BRT            brt       #f      0
    OP_BRNN           brnn      #f      0
    OP_LOAD1          load1     #f      0
    OP_LT             <         2       (λ (x y) (< x y))
    OP_ADD2           add2      #f      0
    OP_SETCDR         set-cdr!  2       (λ (x y) (set-cdr! x y))
    OP_LOADF          loadf     #f      0
    OP_CONS           cons      2       (λ (x y) (cons x y))
    OP_EQ             eq?       2       (λ (x y) (eq? x y))
    OP_SYMBOLP        symbol?   1       (λ (x) (symbol? x))
    OP_NOT            not       1       (λ (x) (not x))
    OP_CADR           cadr      1       (λ (x) (cadr x))
    OP_NEG            neg       #f      0
    OP_NULLP          null?     1       (λ (x) (null? x))
    OP_BOOLEANP       boolean?  1       (λ (x) (boolean? x))
    OP_NUMBERP        number?   1       (λ (x) (number? x))
    OP_FIXNUMP        fixnum?   1       (λ (x) (fixnum? x))
    OP_BOUNDP         bound?    1       (λ (x) (bound? x))
    OP_BUILTINP       builtin?  1       (λ (x) (builtin? x))
    OP_FUNCTIONP      function? 1       (λ (x) (function? x))
    OP_VECTORP        vector?   1       (λ (x) (vector? x))
    OP_SHIFT          shift     #f      0
    OP_SETCAR         set-car!  2       (λ (x y) (set-car! x y))
    OP_JMPL           jmp.l     #f      0
    OP_BRFL           brf.l     #f      0
    OP_BRTL           brt.l     #f      0
    OP_EQV            eqv?      2       (λ (x y) (eqv? x y))
    OP_EQUAL          equal?    2       (λ (x y) (equal? x y))
    OP_LIST           list      ANYARGS (λ rest rest)
    OP_APPLY          apply     -2      (λ rest (apply apply rest))
    OP_ADD            +         ANYARGS (λ rest (apply + rest))
    OP_SUB            -         -1      (λ rest (apply - rest))
    OP_MUL            *         ANYARGS (λ rest (apply * rest))
    OP_DIV            /         -1      (λ rest (apply / rest))
    OP_IDIV           div0      2       (λ rest (apply div0 rest))
    OP_NUMEQ          =         2       (λ (x y) (= x y))
    OP_COMPARE        compare   2       (λ (x y) (compare x y))
    OP_ARGC           argc      #f      0
    OP_VECTOR         vector    ANYARGS (λ rest (apply vector rest))
    OP_ASET           aset!     3       (λ (x y z) (aset! x y z))
    OP_LOADNIL        loadnil   #f      0
    OP_LOADI8         loadi8    #f      0
    OP_LOADVL         loadv.l   #f      0
    OP_LOADGL         loadg.l   #f      0
    OP_LOADAL         loada.l   #f      0
    OP_LOADCL         loadc.l   #f      0
    OP_SETG           setg      #f      0
    OP_SETGL          setg.l    #f      0
    OP_SETAL          seta.l    #f      0
    OP_VARGC          vargc     #f      0
    OP_TRYCATCH       trycatch  #f      0
    OP_FOR            for       3       (λ (a b f) (for a b (λ (x) (f x))))
    OP_TAPPLY         tapply    #f      0
    OP_SUB2           sub2      #f      0
    OP_LARGC          largc     #f      0
    OP_LVARGC         lvargc    #f      0
    OP_CALLL          call.l    #f      0
    OP_TCALLL         tcall.l   #f      0
    OP_BRNEL          brne.l    #f      0
    OP_BRNNL          brnn.l    #f      0
    OP_BRN            brn       #f      0
    OP_BRNL           brn.l     #f      0
    OP_OPTARGS        optargs   #f      0
    OP_BRBOUND        brbound   #f      0
    OP_KEYARGS        keyargs   #f      0
    OP_BOX            box       #f      0
    OP_BOXL           box.l     #f      0
    OP_BOOL_CONST_F   dummy_f   #f      0
    OP_BOOL_CONST_T   dummy_t   #f      0
    OP_THE_EMPTY_LIST dummy_nil #f      0
    OP_EOF_OBJECT     dummy_eof #f      0
))

(define (for-each-n f lst n)
  (when (and (> n 0) (pair? lst)) (begin (apply f (list-head lst n))
                                         (for-each-n f (list-tail lst n) n))))

(let ((c-header     (file "opcodes.h"        :write :create :truncate))
      (instructions (file "instructions.lsp" :write :create :truncate))
      (builtins     (file "builtins.lsp"     :write :create :truncate))
      (e (table))
      (cl (table))
      (ac (table))
      (lms ())
      (i 0))
  (begin
    (io-write c-header "enum {\n")
    (for-each-n
      (λ (cop lop argc f)
        (begin
          (io-write c-header "\t")
          (write cop c-header)
          (io-write c-header ",\n")

          (put! e lop i)
          (if argc (put! cl cop (list lop argc)))
          (if (and (number? argc) (>= argc 0)) (put! ac lop argc))
          (set! lms (cons f lms))
          (set! i (1+ i))))
      opcodes 4)
    (io-write c-header "\tN_OPCODES\n};\n\n")
    (io-write c-header "static const Builtin builtins[] = {\n")
    (table-foreach
      (λ (c la) (begin (io-write c-header "\t[")
                       (write c c-header)
                       (io-write c-header "] = {\"")
                       (write (car la) c-header)
                       (io-write c-header "\", ")
                       (write (cadr la) c-header)
                       (io-write c-header "},\n")))
      cl)
    (io-write c-header "};\n")
    (io-close c-header)

    (write `(define Instructions ,e) instructions)
    (io-write instructions "\n\n")
    (write `(define arg-counts ,ac) instructions)
    (io-close instructions)
    (set! lms (cons vector (reverse! lms)))
    (write `(define *builtins* ,lms) builtins)
    (io-close builtins)))