ref: 4679ff506c0070253da0d452b3fcfaf9bf047130
dir: /gen.lsp/
(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_LOADC00 loadc00 #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_LOADC01 loadc01 #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_NOP nop #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_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))
(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)))