ref: f001b95402211734a1a6ac053e73fb4183ee7958
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)))