shithub: femtolisp

ref: df52f0700401359e68f2c67440c0015af36f25e2
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  (lambda (x) (car x))
    OP_CDR            cdr       1  (lambda (x) (cdr x))
    OP_CLOSURE        closure   #f 0
    OP_SETA           seta      #f 0
    OP_JMP            jmp       #f 0
    OP_LOADC00        loadc00   #f 0
    OP_PAIRP          pair?     1  (lambda (x) (pair? x))
    OP_BRNE           brne      #f 0
    OP_LOADT          loadt     #f 0
    OP_LOAD0          load0     #f 0
    OP_LOADC01        loadc01   #f 0
    OP_AREF           aref      2  (lambda (x y) (aref x y))
    OP_ATOMP          atom?     1  (lambda (x) (atom? x))
    OP_BRT            brt       #f 0
    OP_BRNN           brnn      #f 0
    OP_LOAD1          load1     #f 0
    OP_LT             <         2  (lambda (x y) (< x y))
    OP_ADD2           add2      #f 0
    OP_SETCDR         set-cdr!  2  (lambda (x y) (set-cdr! x y))
    OP_LOADF          loadf     #f 0
    OP_CONS           cons      2  (lambda (x y) (cons x y))
    OP_EQ             eq?       2  (lambda (x y) (eq? x y))
    OP_SYMBOLP        symbol?   1  (lambda (x) (symbol? x))
    OP_NOT            not       1  (lambda (x) (not x))

    OP_CADR           cadr      1  (lambda (x) (cadr x))
    OP_NEG            neg       #f 0
    OP_NULLP          null?     1  (lambda (x) (null? x))
    OP_BOOLEANP       boolean?  1  (lambda (x) (boolean? x))
    OP_NUMBERP        number?   1  (lambda (x) (number? x))
    OP_FIXNUMP        fixnum?   1  (lambda (x) (fixnum? x))
    OP_BOUNDP         bound?    1  (lambda (x) (bound? x))
    OP_BUILTINP       builtin?  1  (lambda (x) (builtin? x))
    OP_FUNCTIONP      function? 1  (lambda (x) (function? x))
    OP_VECTORP        vector?   1  (lambda (x) (vector? x))
    OP_NOP            nop       #f 0
    OP_SETCAR         set-car!  2  (lambda (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  (lambda (x y) (eqv? x y))
    OP_EQUAL          equal?    2  (lambda (x y) (equal? x y))
    OP_LIST           list      #f (lambda rest rest)
    OP_APPLY          apply     #f (lambda rest (apply apply rest))
    OP_ADD            +         #f (lambda rest (apply + rest))
    OP_SUB            -         #f (lambda rest (apply - rest))
    OP_MUL            *         #f (lambda rest (apply * rest))
    OP_DIV            /         #f (lambda rest (apply / rest))
    OP_IDIV           div0      2  (lambda rest (apply div0 rest))
    OP_NUMEQ          =         2  (lambda (x y) (= x y))
    OP_COMPARE        compare   2  (lambda (x y) (compare x y))
    OP_ARGC           argc      #f 0
    OP_VECTOR         vector    #f (lambda rest (apply vector rest))
    OP_ASET           aset!     3  (lambda (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_SETC           setc      #f 0
    OP_SETCL          setc.l    #f 0
    OP_VARGC          vargc     #f 0
    OP_TRYCATCH       trycatch  #f 0
    OP_FOR            for       #f 0
    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_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 (drop lst n)
  (if (<= n 0) lst
      (drop (cdr lst) (1- n))))

(define (for-each-n f lst n)
  (if (<= n 0) ()
    (if (pair? lst) (begin (apply f (list-head lst n))
                           (for-each-n f (drop 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))
      (ac (table))
      (lms ())
      (i 0))
  (begin
    (io.write c-header "enum {\n")
    (for-each-n
      (lambda (cop lop argc f)
        (begin
          (io.write c-header "    ")
          (write cop c-header)
          (io.write c-header ",\n")

          (put! e lop i)
          (if argc (put! ac lop argc))
          (set! lms (cons f lms))
          (set! i (1+ i))))
      opcodes 4)
    (io.write c-header "    N_OPCODES\n};\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)))