shithub: femtolisp

ref: 7bcf6ac7b612306d197d063aaf6d971ca5dd2e3f
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_CONSP          cons?      1       (λ (x) (cons? x))
    OP_BRNE           brne       #f      0
    OP_LOADT          loadt      #f      0
    OP_LOAD0          load0      #f      0
    OP_LOADC1         loadc1     #f      0
    OP_AREF2          aref2      #f      0
    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      (λ rest (apply aset! rest))
    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_AREF           aref       -2      (λ rest (apply aref rest))
    OP_LOADVOID       loadvoid   #f      0
    OP_EOF_OBJECT     dummy_eof  #f      0
))

(define (for-each-n f lst n)
  (when (and (> n 0) (cons? 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))
      (c-code       (file "opcodes.c"        :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 "extern const Builtin builtins[N_OPCODES];\n")
    (io-close c-header)
    (io-write c-code "#include \"flisp.h\"\n\n")
    (io-write c-code "const Builtin builtins[N_OPCODES] = {\n")
    (for-each
      (λ (c la) (begin (io-write c-code "\t[")
                       (write c c-code)
                       (io-write c-code "] = {\"")
                       (write (car la) c-code)
                       (io-write c-code "\", ")
                       (write (cadr la) c-code)
                       (io-write c-code "},\n")))
      cl)
    (io-write c-code "};\n")
    (io-close c-code)

    (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)))