開発環境
- macOS Sierra - Apple (OS)
- Emacs (Text Editor)
- C, Scheme (プログラミング言語)
- Clang/LLVM (コンパイラ, Xcode - Apple)
- 参考書籍等
Cを高級アセンブラーとした、Scheme の コンパイラー(ksc)、インタプリター(ksi)の作成で、メモリ管理を Ben GC を利用することに。ということで、これをきっかけに最初からすべて書き直してみることに。(一気にどれだけ書けるか試してみたからコードは読みにくかったり。)
最初のCのコードの生成には Gauche(gosh) を利用。
コンパイラとインタプリタを作成してみたから、簡単な10の階乗、100の階乗の計算で速度がどれくらい違うか比較。
temp.scm
(begin
(load "./lib/stdlib/base.scm")
(define (fact n)
(if (= n 1)
1
(* (fact (- n 1)) n)))
(fact 100)
)
入出力結果(Terminal)
$ time ./ksc temp => compiled real 1m32.562s user 1m39.567s sys 0m6.211s $ time ./temp => 3628800 real 0m0.012s user 0m0.007s sys 0m0.003s $ time ./ksi < temp.scm > => 3628800 > real 0m0.649s user 0m0.745s sys 0m0.042s $ time ./ksc temp => compiled real 1m35.664s user 1m45.133s sys 0m8.209s $ time ./temp => 93326215443944152681699238856266700490715968264381621468592963895217599993229915608941463976156518286253697920827223758251185210916864000000000000000000000000 real 0m0.014s user 0m0.010s sys 0m0.003s $ time ./ksi < temp.scm > => 93326215443944152681699238856266700490715968264381621468592963895217599993229915608941463976156518286253697920827223758251185210916864000000000000000000000000 > real 0m3.603s user 0m4.070s sys 0m0.211s $
理論から予想した通り、コンパイルした方が速い。けど、コンパイルに時間かかりすぎだったり…
大きめの数値での実験も追加。(メモリーの消費を抑えるために、階乗を求める手続きの定義を変更。)
temp.scm
(begin
(load "./lib/stdlib/base.scm")
(define (fact n)
(define (iter n result)
(if (= n 1)
result
(iter (- n 1) (* n result))))
(iter n 1))
(fact 500000)
)
入出力結果(Terminal)
$ time ./ksc temp => compiled real 1m35.103s user 1m40.650s sys 0m6.178s $ time ./temp >| temp.txt real 2m34.485s user 3m14.191s sys 0m18.721s $ time gosh < temp.scm real 4m17.029s user 6m20.572s sys 0m22.049s $
コンパイル時間はあまり変わらず。速度は Gauche(gosh) より速くなった。(ksi では遅すぎるから実行せず。)
この結果が一般化できるなら、時間がかかってもコンパイル、コンパイラーの価値があるかも。ただ、Gauche との違いは翻訳の恩恵というより、GNU MPのおかげかも。(Gauche の数値(任意精度の整数)は独自の実装？)
コード
ksc.scm
((lambda ()
(define (- z1 . zs)
(if (null? zs)
(* -1 z1)
((lambda ()
(define (iter z zs)
(if (null? zs)
z
(iter (+ z (* -1 (car zs))) (cdr zs))))
(iter z1 zs)))))
(define (append . lists)
(define (iter1 list1 list2)
(if (null? list1)
list2
(iter1 (cdr list1) (cons (car list1) list2))))
(define (iter2 list-of-list list)
(if (null? list-of-list)
list
(iter2 (cdr list-of-list)
(iter1 (reverse (car list-of-list))
list))))
(define r (reverse lists))
(if (null? r)
'()
(iter2 (cdr r) (car r))))
(define (cadr pair) (car (cdr pair)))
(define (cddr pair) (cdr (cdr pair)))
(define (caadr pair) (car (cadr pair)))
(define (cdadr pair) (cdr (cadr pair)))
(define (cdddr pair) (cdr (cddr pair)))
(define (cadddr pair) (car (cdddr pair)))
(define (error message . objs)
(define (iter objs)
(if (not (null? objs))
((lambda ()
(display (car objs) (current-error-port))
(display " " (current-error-port))
(iter (cdr objs))))))
(if (not (string=? message ""))
(begin
(display message (current-error-port))
(display message (current-error-port))))
(iter objs)
(display "\n" (current-error-port))
(exit 1))
(define (length list)
(define (iter list n)
(if (null? list)
n
(iter (cdr list) (+ n 1))))
(iter list 0))
(define (list . args) args)
(define (list-ref list k)
(if (= k 0)
(car list)
(list-ref (cdr list) (- k 1))))
(define (map proc list)
(define (iter list result)
(if (null? list)
result
(iter (cdr list) (cons (proc (car list)) result))))
(iter (reverse list) '()))
(define (memq obj list)
(cond ((null? list) '())
((eq? obj (car list)) list)
(#t (memq obj (cdr list)))))
(define (not obj) (if obj #f #t))
(define (reverse list)
(define (iter list result)
(if (null? list)
result
(iter (cdr list)
(cons (car list) result))))
(iter list '()))
(define (string-append . strings)
(define (iter1 strings result)
(if (null? strings)
(reverse result)
(iter1 (cdr strings) (cons (string->list (car strings))
result))))
(define (iter2 list-of-list)
(if (null? list-of-list)
'()
(append (car list-of-list)
(iter2 (cdr list-of-list)))))
(list->string (iter2 (iter1 strings '()))))
(define (const-string s)
(define (iter chars)
(if (null? chars)
"strempty_ptr"
(string-append "strnew(" (const (car chars)) ", "
(iter (cdr chars)) ")")))
(iter (string->list s)))
(define (const-symbol->string obj)
(define s (symbol->string obj))
(define (iter chars)
(cond ((null? chars) '())
((eqv? #\" (car chars))
(cons #\\ (cons (car chars) (iter (cdr chars)))))
((eqv? #\alarm (car chars))
(cons #\\ (cons #\a (iter (cdr chars)))))
((eqv? #\backspace (car chars))
(cons #\\ (cons #\b (iter (cdr chars)))))
((eqv? #\newline (car chars))
(cons #\\ (cons #\n (iter (cdr chars)))))
((eqv? #\return (car chars))
(cons #\\ (cons #\r (iter (cdr chars)))))
((eqv? #\tab (car chars))
(cons #\\ (cons #\t (iter (cdr chars)))))
((eqv? #\\ (car chars))
(cons #\\ (cons #\\ (iter (cdr chars)))))
(#t (cons (car chars) (iter (cdr chars))))))
(list->string (iter (string->list s))))
(define undef (if #f #f))
(define (const obj)
(cond ((number? obj)
(if (exact? obj)
(string-append "qnew(\"" (number->string obj) "\")")
(string-append "znew_s_s(\"" (number->string (real-part obj)) "\",\""
(number->string (imag-part obj)) "\")")))
((pair? obj)
(string-append "pnew(" (const (car obj)) ", " (const (cdr obj)) ")"))
((null? obj) "empty_ptr")
((symbol? obj)
(string-append "symvnew(\"" (const-symbol->string obj) "\")"))
((string? obj) (const-string obj))
((char? obj) (string-append
"cnewuc(" (number->string (char->integer obj)) ")"))
((eq? obj undef) "undef_ptr")
((boolean? obj) (if obj "true_ptr" "false_ptr"))
(#t error "const" obj)))
(define (caddr p) (car (cdr (cdr p))))
(define (print-code code port)
(define (iter code)
(if (not (null? code))
((lambda ()
(display (car code) port)
(iter (cdr code))))))
(display '|#include "obj.h"\n#include "parse.tab.h"\n| port)
(display '|int main(int argc, char **argv) {| port)
(display '|init();| port)
(display '|scm_argv = empty_ptr;| port)
(display '|for (int i = argc - 1; i >= 0; i--){| port)
(display '|glong items_written;| port)
(display '|gunichar *s = g_utf8_to_ucs4(argv[i], -1, NULL, &items_written, NULL);|
port)
(display '|ObjPtr p = strempty_ptr;| port)
(display '|for (glong i = items_written - 1; i >= 0; i--) {| port)
(display '|p = strnew(cnewuc(s[i]), p);| port)
(display '|}| port)
(display '|scm_argv = pnew(p, scm_argv);| port)
(display '|g_free(s);| port)
(display '|}| port)
(display '|ObjPtr val, proc, argl, cont = NULL;| port)
(display '|ObjPtr env = setup_environment();| port)
(iter (caddr code))
(display '|if (err_p(val)){| port)
(display '|ewrite(val);} else {| port)
(display '|printf("=> ");| port)
(display '|cdisplay(val, oport);}| port)
(display '|printf("\x5c;n");}| port))
(define (self-evaluating? exp)
(cond ((number? exp) #t)
((string? exp) #t)
((eq? undef exp) #t)
((boolean? exp) #t)
((char? exp) #t)
((null? exp) #t)
(#t #f)))
(define (variable? exp) (symbol? exp))
(define (quoted? exp)
(tagged-list? exp 'quote))
(define (text-of-quotation exp) (cadr exp))
(define (tagged-list? exp tag)
(if (pair? exp)
(eq? (car exp) tag)
#f))
(define (assignment? exp)
(tagged-list? exp 'set!))
(define (assignment-variable exp) (cadr exp))
(define (assignment-value exp) (caddr exp))
(define (definition? exp)
(tagged-list? exp 'define))
(define (definition-variable exp)
(if (symbol? (cadr exp))
(cadr exp)
(caadr exp)))
(define (definition-value exp)
(if (symbol? (cadr exp))
(caddr exp)
(make-lambda (cdadr exp)
(cddr exp))))
(define (lambda? exp) (tagged-list? exp 'lambda))
(define (lambda-parameters exp)
((lambda (obj)
(define (iter o)
(cond ((or (symbol? o) (null? o)) obj)
((and (pair? o) (symbol? (car o))) (iter (cdr o)))
(#t (error "syntax error: lambda-parameters --" exp))))
(iter obj))
(cadr exp)))
(define (lambda-body exp) (cddr exp))
(define (make-lambda parameters body) (cons 'lambda (cons parameters body)))
(define (if? exp) (tagged-list? exp 'if))
(define (if-predicate exp) (cadr exp))
(define (if-consequent exp) (caddr exp))
(define (if-alternative exp)
(if (not (null? (cdddr exp)))
(cadddr exp)))
(define (make-if predicate consequent alternative)
(list 'if predicate consequent alternative))
(define (begin? exp) (tagged-list? exp 'begin))
(define (begin-actions exp) (cdr exp))
(define (sequence->exp seq)
(cond ((null? seq) seq)
((last-exp? seq) (first-exp seq))
(#t (make-begin seq))))
(define (make-begin seq) (cons 'begin seq))
(define (cond? exp) (tagged-list? exp 'cond))
(define (cond-clauses exp) (cdr exp))
(define (cond-predicate clause) (car clause))
(define (cond-actions clause) (cdr clause))
(define (cond->if exp)
(expand-clauses (cond-clauses exp)))
(define (expand-clauses clauses)
(if (not (null? clauses))
((lambda (first rest)
(make-if (cond-predicate first)
(sequence->exp (cond-actions first))
(expand-clauses rest)))
(car clauses)
(cdr clauses))))
(define (and? exp) (tagged-list? exp 'and))
(define (and->if clauses)
(if (null? clauses)
#t
(make-if (car clauses) (and->if (cdr clauses)) #f)))
(define (or? exp) (tagged-list? exp 'or))
(define (or->if clauses)
(if (null? clauses)
#f
(make-if (car clauses) #t (or->if (cdr clauses)))))
(define (load? exp) (tagged-list? exp 'load))
(define (load->exp exp) (read (open-input-file (cadr exp))))
(define (last-exp? seq) (null? (cdr seq)))
(define (first-exp seq) (car seq))
(define (rest-exps seq) (cdr seq))
(define (application? exp) (pair? exp))
(define (operator exp) (car exp))
(define (operands exp) (cdr exp))
(define (no-operands? ops) (null? ops))
(define (first-operand ops) (car ops))
(define (rest-operands ops) (cdr ops))
(define (compile exp target linkage)
(cond ((self-evaluating? exp)
(compile-self-evaluating exp target linkage))
((quoted? exp) (compile-quoted exp target linkage))
((variable? exp)
(compile-variable exp target linkage))
((assignment? exp)
(compile-assignment exp target linkage))
((definition? exp)
(compile-definition exp target linkage))
((if? exp) (compile-if exp target linkage))
((lambda? exp) (compile-lambda exp target linkage))
((begin? exp)
(compile-sequence (begin-actions exp)
target
linkage))
((cond? exp) (compile (cond->if exp) target linkage))
((and? exp) (compile (and->if (cdr exp)) target linkage))
((or? exp) (compile (or->if (cdr exp)) target linkage))
((load? exp) (compile (load->exp exp) target linkage))
((application? exp)
(compile-application exp target linkage))
(#t
(error "Unknown expression type -- COMPILE" exp))))
(define (make-instruction-sequence needs modifies statements)
(list needs modifies statements))
(define (empty-instruction-sequence)
(make-instruction-sequence '() '() '()))
(define (compile-linkage linkage)
(cond ((eq? linkage 'return)
(make-instruction-sequence '(cont) '()
'(|goto *(cont->ptr);|)))
((eq? linkage 'next)
(empty-instruction-sequence))
(#t
(make-instruction-sequence '() '()
(list '|goto | linkage '|;|)))))
(define (end-with-linkage linkage instruction-sequence)
(preserving '(cont)
instruction-sequence
(compile-linkage linkage)))
(define (compile-self-evaluating exp target linkage)
(end-with-linkage
linkage
(make-instruction-sequence '() (list target)
(list target '| = | (const exp) '|;|))))
(define (compile-quoted exp target linkage)
(end-with-linkage
linkage
(make-instruction-sequence
'() (list target)
(list target '| = | (const (text-of-quotation exp)) '|;|))))
(define (compile-variable exp target linkage)
(end-with-linkage
linkage
(make-instruction-sequence
'(env) (list target)
(list target '| = lookup_variable_value(| (const exp) '|, env);|))))
(define (compile-assignment exp target linkage)
(define var (assignment-variable exp))
(define get-value-code (compile (assignment-value exp) 'val 'next))
(end-with-linkage
linkage
(preserving
'(env)
get-value-code
(make-instruction-sequence
'(env val) (list target)
(list target '| = set_variable_value(| (const var) '|, val, env);|)))))
(define (compile-definition exp target linkage)
(define var (definition-variable exp))
(define get-value-code (compile (definition-value exp) 'val 'next))
(end-with-linkage
linkage
(preserving '(env)
get-value-code
(make-instruction-sequence
'(env val) (list target)
(list target '| = define_variable(| (const var) '|, val, env);|)))))
(define label-counter 0)
(define (new-label-number)
(set! label-counter (+ 1 label-counter))
label-counter)
(define (make-label name)
(string->symbol
(string-append (symbol->string name)
(number->string (new-label-number)))))
(define (label-inst label)
(make-instruction-sequence '() '() (list label '|:|)))
(define (compile-if exp target linkage)
(define f-branch (make-label 'false_branch))
(define after-if (make-label 'after_if))
(define consequent-linkage (if (eq? linkage 'next) after-if linkage))
(define p-code (compile (if-predicate exp) 'val 'next))
(define c-code (compile (if-consequent exp) target consequent-linkage))
(define a-code (compile (if-alternative exp) target linkage))
(preserving '(env cont)
p-code
(append-instruction-sequences
(make-instruction-sequence
'(val) '()
(list '|if (val == false_ptr) {goto | f-branch '|;}|))
(parallel-instruction-sequences
c-code
(append-instruction-sequences (label-inst f-branch) a-code))
(if (eq? linkage 'next)
(label-inst after-if)
(empty-instruction-sequence)))))
(define (compile-sequence seq target linkage)
(if (last-exp? seq)
(compile (first-exp seq) target linkage)
(preserving '(env cont)
(compile (first-exp seq) target 'next)
(compile-sequence (rest-exps seq) target linkage))))
(define (compile-lambda exp target linkage)
((lambda (proc-entry after-lambda)
((lambda (lambda-linkage)
(append-instruction-sequences
(tack-on-instruction-sequence
(end-with-linkage
lambda-linkage
(make-instruction-sequence
'(env) (list target)
(list target '| = cprocnew(&&| proc-entry '|, env);|)))
(compile-lambda-body exp proc-entry))
(label-inst after-lambda)))
(if (eq? linkage 'next) after-lambda linkage)))
(make-label 'entry)
(make-label 'after_lambda)))
(define (compile-lambda-body exp proc-entry)
((lambda (formals)
(append-instruction-sequences
(make-instruction-sequence
'(env proc argl) '(env)
(list proc-entry '|:|
'|env = compiled_procedure_env(proc);|
'|env = extend_environment(| (const formals) '|, argl, env);|))
(compile-sequence (lambda-body exp) 'val 'return)))
(lambda-parameters exp)))
(define (compile-application exp target linkage)
(define proc-code (compile (operator exp) 'proc 'next))
(define operand-codes (map (lambda (operand) (compile operand 'val 'next))
(operands exp)))
(preserving '(env cont)
proc-code
(preserving
'(proc cont)
(construct-arglist operand-codes)
(compile-procedure-call target linkage))))
(define (construct-arglist operand-codes)
((lambda (operand-codes)
(if (null? operand-codes)
(make-instruction-sequence '() '(argl)
'(|argl = empty_ptr;|))
((lambda (code-to-get-last-arg)
(if (null? (cdr operand-codes))
code-to-get-last-arg
(preserving '(env)
code-to-get-last-arg
(code-to-get-rest-args
(cdr operand-codes)))))
(append-instruction-sequences
(car operand-codes)
(make-instruction-sequence '(val) '(argl)
'(|argl = pnew(val, empty_ptr);|))))))
(reverse operand-codes)))
(define (code-to-get-rest-args operand-codes)
((lambda (code-for-next-arg)
(if (null? (cdr operand-codes))
code-for-next-arg
(preserving '(env)
code-for-next-arg
(code-to-get-rest-args (cdr operand-codes)))))
(preserving '(argl)
(car operand-codes)
(make-instruction-sequence
'(val argl) '(argl)
'(|argl = pnew(val, argl);|)))))
(define (compile-procedure-call target linkage)
((lambda (before-call primitive-branch after-call)
((lambda (compiled-linkage)
(append-instruction-sequences
(make-instruction-sequence
'(proc) '()
(list before-call '|:|
'|if (proc->t == PROC_APPLY) {|
'|proc = argl->p->l; argl = argl->p->r->p->l;|
'|goto | before-call '|;}|
'|if (proc->t == PROC) { goto | primitive-branch '|;}|
'|if (proc->t != CPROC) {|
'|fprintf(stderr, "unknown procedure type -- ");|
'|cdisplay(proc, eport);|
'|fprintf(stderr, "\x5c;n");|
'|exit(1);}|))
(parallel-instruction-sequences
(compile-proc-appl target compiled-linkage)
(append-instruction-sequences
(label-inst primitive-branch)
(end-with-linkage
linkage
(make-instruction-sequence
'(proc argl)
(list target)
(list target '| = proc->proc->fn(argl);|)))))
(if (eq? linkage 'next)
(label-inst after-call)
(empty-instruction-sequence))))
(if (eq? linkage 'next) after-call linkage)))
(make-label 'before_call)
(make-label 'primitive_branch)
(make-label 'after_call)))
(define all-regs '(env proc val argl cont))
(define (compile-proc-appl target linkage)
(cond ((and (eq? target 'val) (not (eq? linkage 'return)))
(make-instruction-sequence
'(proc) all-regs
(list '|cont = contnew(&&| linkage '|);|
'|val = compiled_procedure_entry(proc);|
'|goto *(val->ptr);|)))
((and (not (eq? target 'val))
(not (eq? linkage 'return)))
((lambda (proc-return)
(make-instruction-sequence
'(proc) all-regs
(list '|cont = contnew(&&| proc-return '|);|
'|val = compiled_procedure_entry(proc);|
'|goto *(val->ptr);|
proc-return '|:|
target '| = val;|
'|goto | linkage '|;|)))
(make-label 'proc_return)))
((and (eq? target 'val) (eq? linkage 'return))
(make-instruction-sequence
'(proc cont) all-regs
'(|val = compiled_procedure_entry(proc);|
|goto *(val->ptr);|)))
((and (not (eq? target 'val)) (eq? linkage 'return))
(error "return linkage, target not val -- COMPILE"
target))))
(define (registers-needed s)
(if (symbol? s) '() (car s)))
(define (registers-modified s)
(if (symbol? s) '() (cadr s)))
(define (statements s)
(if (symbol? s) (list s) (caddr s)))
(define (needs-register? seq reg)
(memq reg (registers-needed seq)))
(define (modifies-register? seq reg)
(memq reg (registers-modified seq)))
(define (append-instruction-sequences . seqs)
(define (append-2-sequences seq1 seq2)
(make-instruction-sequence
(list-union (registers-needed seq1)
(list-difference (registers-needed seq2)
(registers-modified seq1)))
(list-union (registers-modified seq1)
(registers-modified seq2))
(append (statements seq1) (statements seq2))))
(define (append-seq-list seqs)
(if (null? seqs)
(empty-instruction-sequence)
(append-2-sequences (car seqs)
(append-seq-list (cdr seqs)))))
(append-seq-list seqs))
(define (list-union s1 s2)
(cond ((null? s1) s2)
((memq (car s1) s2) (list-union (cdr s1) s2))
(#t (cons (car s1) (list-union (cdr s1) s2)))))
(define (list-difference s1 s2)
(cond ((null? s1) '())
((memq (car s1) s2) (list-difference (cdr s1) s2))
(#t (cons (car s1)
(list-difference (cdr s1) s2)))))
(define (preserving regs seq1 seq2)
(if (null? regs)
(append-instruction-sequences seq1 seq2)
((lambda (first-reg)
(if (and (needs-register? seq2 first-reg)
(modifies-register? seq1 first-reg))
(preserving (cdr regs)
(make-instruction-sequence
(list-union (list first-reg)
(registers-needed seq1))
(list-difference (registers-modified seq1)
(list first-reg))
(append (list '|save(| first-reg '|);|)
(statements seq1)
(list first-reg '| = restore();|)))
seq2)
(preserving (cdr regs) seq1 seq2)))
(car regs))))
(define (tack-on-instruction-sequence seq body-seq)
(make-instruction-sequence
(registers-needed seq)
(registers-modified seq)
(append (statements seq) (statements body-seq))))
(define (parallel-instruction-sequences seq1 seq2)
(make-instruction-sequence
(list-union (registers-needed seq1)
(registers-needed seq2))
(list-union (registers-modified seq1)
(registers-modified seq2))
(append (statements seq1) (statements seq2))))
(define commands (command-line))
(if (= (length commands) 2)
((lambda ()
(define name (list-ref commands 1))
(define output-filename (string-append name ".c"))
(define input-file (open-input-file (string-append name ".scm")))
(define output-file (open-output-file output-filename))
(define exp (read input-file))
(define code (compile exp 'val 'next))
(print-code code output-file)
(flush-output-port output-file)
(define n (system (string-append "cc -O3 `pkg-config --cflags glib-2.0` -I/opt/local/include `pkg-config --libs glib-2.0` -L/opt/local/lib -L./ -lgmp -lmpfr -lmpc -lfl -lgc -lkscm " output-filename " -o " name)))
(if (= n 0)
'compiled
(error "error:" n))
))
(error "usage: ksc name"))
))
ksi.scm
(begin
(load "./lib/stdlib/base.scm")
(load "./lib/stdlib/cxr.scm")
(define apply-in-underlying-scheme apply)
(define error-in-underlying-scheme error)
(define (error message . objs)
(display "ERROR: ")
(display message)
(define (iter objs)
(if (null? objs)
(begin
(newline)
(driver-loop))
(begin
(display " ")
(write (car objs))
(iter (cdr objs)))))
(iter objs))
(define (eval exp env)
(cond ((self-evaluating? exp) exp)
((variable? exp) (lookup-variable-value exp env))
((quoted? exp) (text-of-quotation exp))
((assignment? exp) (eval-assignment exp env))
((definition? exp) (eval-definition exp env))
((if? exp) (eval-if exp env))
((lambda? exp)
(make-procedure (lambda-parameters exp)
(lambda-body exp)
env))
((begin? exp)
(eval-sequence (begin-actions exp) env))
((cond? exp) (eval (cond->if exp) env))
((and? exp) (eval (and->if (cdr exp)) env))
((or? exp) (eval (or->if (cdr exp)) env))
((load? exp) (eval (load->exp exp) env))
((application? exp)
(apply (eval (operator exp) env)
(list-of-values (operands exp) env)))
(#t
(error "unknown expression type -- eval" exp))))
(define (apply procedure arguments)
(cond ((primitive-procedure? procedure)
(apply-primitive-procedure procedure arguments))
((compound-procedure? procedure)
(eval-sequence
(procedure-body procedure)
(extend-environment
(procedure-parameters procedure)
arguments
(procedure-environment procedure))))
(#t
(error
"unknown procedure type -- apply" procedure))))
(define (list-of-values exps env)
(if (no-operands? exps)
'()
(cons (eval (first-operand exps) env)
(list-of-values (rest-operands exps) env))))
(define (eval-if exp env)
(if (eval (if-predicate exp) env)
(eval (if-consequent exp) env)
(eval (if-alternative exp) env)))
(define (eval-sequence exps env)
(if (last-exp? exps)
(eval (first-exp exps) env)
((lambda ()
(eval (first-exp exps) env)
(eval-sequence (rest-exps exps) env)))))
(define (eval-assignment exp env)
(set-variable-value! (assignment-variable exp)
(eval (assignment-value exp) env)
env))
(define (eval-definition exp env)
(define-variable!
(definition-variable exp)
(eval (definition-value exp) env)
env))
(define (self-evaluating? exp)
(or (number? exp)
(char? exp)
(string? exp)
(boolean? exp)
(eq? exp (if #f #f))))
(define (variable? exp) (symbol? exp))
(define (quoted? exp)
(tagged-list? exp 'quote))
(define (text-of-quotation exp) (cadr exp))
(define (tagged-list? exp tag)
(if (pair? exp)
(eq? (car exp) tag)
#f))
(define (assignment? exp)
(tagged-list? exp 'set!))
(define (assignment-variable exp) (cadr exp))
(define (assignment-value exp) (caddr exp))
(define (definition? exp)
(tagged-list? exp 'define))
(define (definition-variable exp)
(if (symbol? (cadr exp))
(cadr exp)
(caadr exp)))
(define (definition-value exp)
(if (symbol? (cadr exp))
(caddr exp)
(make-lambda (cdadr exp)
(cddr exp))))
(define (lambda? exp) (tagged-list? exp 'lambda))
(define (lambda-parameters exp) (cadr exp))
(define (lambda-body exp) (cddr exp))
(define (make-lambda parameters body)
(cons 'lambda (cons parameters body)))
(define (if? exp) (tagged-list? exp 'if))
(define (if-predicate exp) (cadr exp))
(define (if-consequent exp) (caddr exp))
(define (if-alternative exp)
(if (not (null? (cdddr exp)))
(cadddr exp)))
(define (begin? exp) (tagged-list? exp 'begin))
(define (make-if predicate consequent alternative)
(list 'if predicate consequent alternative))
(define (begin? exp) (tagged-list? exp 'begin))
(define (begin-actions exp) (cdr exp))
(define (last-exp? seq) (null? (cdr seq)))
(define (first-exp seq) (car seq))
(define (rest-exps seq) (cdr seq))
(define (sequence->exp seq)
(cond ((null? seq) seq)
((last-exp? seq) (first-exp seq))
(#t (make-begin seq))))
(define (make-begin seq) (cons 'begin seq))
(define (application? exp) (pair? exp))
(define (operator exp) (car exp))
(define (operands exp) (cdr exp))
(define (no-operands? ops) (null? ops))
(define (first-operand ops) (car ops))
(define (rest-operands ops) (cdr ops))
(define (cond? exp) (tagged-list? exp 'cond))
(define (cond-clauses exp) (cdr exp))
(define (cond-predicate clause) (car clause))
(define (cond-actions clause) (cdr clause))
(define (cond->if exp)
(expand-clauses (cond-clauses exp)))
(define (expand-clauses clauses)
(if (not (null? clauses))
((lambda (first rest)
(make-if (cond-predicate first)
(sequence->exp (cond-actions first))
(expand-clauses rest)))
(car clauses)
(cdr clauses))))
(define (and? exp) (tagged-list? exp 'and))
(define (and->if clauses)
(if (null? clauses)
#t
(make-if (car clauses) (and->if (cdr clauses)) #f)))
(define (or? exp) (tagged-list? exp 'or))
(define (or->if clauses)
(if (null? clauses)
#f
(make-if (car clauses) #t (or->if (cdr clauses)))))
(define (load? exp) (tagged-list? exp 'load))
(define (load->exp exp) (read (open-input-file (cadr exp))))
(define (make-procedure parameters body env)
(list 'procedure parameters body env))
(define (compound-procedure? p)
(tagged-list? p 'procedure))
(define (procedure-parameters p) (cadr p))
(define (procedure-body p) (caddr p))
(define (procedure-environment p) (cadddr p))
(define (enclosing-environment env) (cdr env))
(define (first-frame env) (car env))
(define the-empty-environment '())
(define (make-frame variables values)
(cons variables values))
(define (frame-variables frame) (car frame))
(define (frame-values frame) (cdr frame))
(define (add-binding-to-frame! var val frame)
(set-car! frame (cons var (car frame)))
(set-cdr! frame (cons val (cdr frame))))
(define (extend-environment vars vals base-env)
(define (iter vars vals vars0 vals0)
(cond ((symbol? vars) (cons (make-frame (cons vars vars0)
(cons vals vals0))
base-env))
((and (pair? vars) (pair? vals))
(iter (cdr vars)
(cdr vals)
(cons (car vars) vars0)
(cons (car vals) vals0)))
((and (null? vars) (null? vals)) (cons (make-frame vars0 vals0)
base-env))
((null? vars)
(error "too many arguments supplied" vars vals))
(#t (error "too few arguments supplied" vars vals))))
(iter vars vals '() '()))
(define (lookup-variable-value var env)
(define (env-loop env)
(define (scan vars vals)
(cond ((null? vars)
(env-loop (enclosing-environment env)))
((eq? var (car vars))
(car vals))
(#t (scan (cdr vars) (cdr vals)))))
(if (eq? env the-empty-environment)
(error "unbound variable --" var)
((lambda (frame)
(scan (frame-variables frame)
(frame-values frame)))
(first-frame env))))
(env-loop env))
(define (set-variable-value! var val env)
(define (env-loop env)
(define (scan vars vals)
(cond ((null? vars)
(env-loop (enclosing-environment env)))
((eq? var (car vars))
(set-car! vals val))
(#t (scan (cdr vars) (cdr vals)))))
(if (eq? env the-empty-environment)
(error "unbound variable -- set!" var)
((lambda (frame)
(scan (frame-variables frame)
(frame-values frame)))
(first-frame env))))
(env-loop env))
(define (define-variable! var val env)
((lambda (frame)
(define (scan vars vals)
(cond ((null? vars)
(add-binding-to-frame! var val frame))
((eq? var (car vars))
(set-car! vals val))
(#t (scan (cdr vars) (cdr vals)))))
(scan (frame-variables frame)
(frame-values frame)))
(first-frame env)))
(define (primitive-procedure? proc)
(tagged-list? proc 'primitive))
(define (primitive-implementation proc) (cdr proc))
(define primitive-procedures
(list (cons '* *)
(cons '+ +)
(cons '/ /)
(cons '< <)
(cons '= =)
(cons 'apply apply)
(cons 'boolean? boolean?)
(cons 'car car)
(cons 'cdr cdr)
(cons 'ceiling ceiling)
(cons 'char->integer char->integer)
(cons 'char? char?)
(cons 'close-port close-port)
(cons 'cons cons)
(cons 'current-error-port current-error-port)
(cons 'current-input-port current-input-port)
(cons 'eof-object eof-object)
(cons 'eof-object? eof-object?)
(cons 'eq? eq?)
(cons 'eqv? eqv?)
(cons 'error error-in-underlying-scheme)
(cons 'error-object-irritants error-object-irritants)
(cons 'error-object-message error-object-message)
(cons 'error-object? error-object?)
(cons 'exact exact)
(cons 'exact? exact?)
(cons 'file-error? file-error?)
(cons 'floor floor)
(cons 'flush-output-port flush-output-port)
(cons 'input-port-open? input-port-open?)
(cons 'input-port? input-port?)
(cons 'integer->char integer->char)
(cons 'list->string list->string)
(cons 'number->string number->string)
(cons 'number? number?)
(cons 'numerator numerator)
(cons 'output-port-open? output-port-open?)
(cons 'output-port? output-port?)
(cons 'pair? pair?)
(cons 'procedure? procedure?)
(cons 'raise raise)
(cons 'read-char read-char)
(cons 'read-error? read-error?)
(cons 'round round)
(cons 'set-car! set-car!)
(cons 'set-cdr! set-cdr!)
(cons 'string->list string->list)
(cons 'string->symbol string->symbol)
(cons 'string-set! string-set!)
(cons 'string? string?)
(cons 'symbol->string symbol->string)
(cons 'symbol? symbol?)
(cons 'textual-port? textual-port?)
(cons 'truncate truncate)
;; char library
(cons 'char-alphabetic? char-alphabetic?)
(cons 'char-downcase char-downcase)
(cons 'char-foldcase char-foldcase)
(cons 'char-lower-case? char-lower-case?)
(cons 'char-numeric? char-numeric?)
(cons 'char-upcase char-upcase)
(cons 'char-upper-case? char-upper-case?)
(cons 'char-whitespace? char-whitespace?)
(cons 'digit-value digit-value)
;; complex library
(cons 'angle angle)
(cons 'imag-part imag-part)
(cons 'real-part real-part)
;; inexact library
(cons 'exp exp)
(cons 'infinite? infinite?)
(cons 'log log)
(cons 'nan? nan?)
))
(define (primitive-procedure-names)
(map car
primitive-procedures))
(define (primitive-procedure-objects)
(map (lambda (proc) (cons 'primitive (cdr proc)))
primitive-procedures))
(define (setup-environment)
((lambda (initial-env)
initial-env)
(extend-environment (primitive-procedure-names)
(primitive-procedure-objects)
the-empty-environment)))
(define the-global-environment (setup-environment))
(define (apply-primitive-procedure proc args)
((lambda (obj)
(if (error-object? obj)
(begin
(display "ERROR: ")
(display (error-object-message obj))
(define (iter objs)
(if (null? objs)
(begin
(newline)
(driver-loop))
(begin
(display " ")
(write (car objs))
(iter (cdr objs)))))
(iter (error-object-irritants obj)))
obj))
(apply-in-underlying-scheme
(primitive-implementation proc) args)))
(define (driver-loop)
(display '|> |)
((lambda (input)
(if (eof-object? input)
(exit)
((lambda (output)
(user-print output))
(eval input the-global-environment))))
(read))
(driver-loop))
(define (repl)
(eval '(begin
(load "./lib/stdlib/base.scm")
(load "./lib/stdlib/case-lambda.scm")
(load "./lib/stdlib/char.scm")
(load "./lib/stdlib/complex.scm")
(load "./lib/stdlib/cxr.scm")
(load "./lib/stdlib/file.scm")
(load "./lib/stdlib/inexact.scm")
(load "./lib/stdlib/lazy.scm")
(load "./lib/stdlib/load.scm")
(load "./lib/stdlib/process-context.scm")
(load "./lib/stdlib/read.scm")
(load "./lib/stdlib/repl.scm")
(load "./lib/stdlib/time.scm")
(load "./lib/stdlib/write.scm"))
the-global-environment)
(driver-loop))
(define (user-print obj)
(display '|=> |)
(cond ((primitive-procedure? obj)
(write (primitive-implementation obj)))
((compound-procedure? obj)
(display '|#<compound-procedure: |)
(display (procedure-parameters obj))
(display " ")
(display (procedure-body obj))
(display '| (<procedure-env>)>|))
(#t (write obj)))
(newline))
(repl)
)
obj.h
#pragma once
/** \file */
#include <stdio.h> // FILE
#include <stdbool.h> // bool
#include <stdlib.h> // free, malloc
#include <glib.h> // gunichar
#include <gmp.h> // mpq_t
#include <mpfr.h>
#include <mpc.h> // mpc_t
typedef void *Ptr;
typedef enum Type Type;
typedef struct Obj Obj;
typedef Obj *ObjPtr;
typedef struct Pair Pair;
typedef Pair *PairPtr;
typedef struct Proc Proc;
typedef Proc *ProcPtr;
typedef struct Port Port;
typedef Port *PortPtr;
typedef ObjPtr (*fn_type)(ObjPtr);
enum Type {
EMPTY,
PAIR,
SYM,
SYMV,
COMPLEX,
RATIONAL, /* 5 */
IPORT,
OPORT,
IPORT_CLOSED,
OPORT_CLOSED,
UNDEF,
BOOLEAN_TRUE,
BOOLEAN_FALSE,
STREMPTY, /* 10 */
PROC,
CPROC,
PROC_APPLY,
CHAR,
STR,
CONT, /* 15 */
OEOF,
ERR,
RERR,
FERR,
};
struct Obj {
Type t;
union {
PairPtr p;
char *s;
mpc_t z;
mpq_t q;
PortPtr port;
ProcPtr proc;
gunichar uc;
Ptr ptr;
};
};
struct Pair {
ObjPtr l;
ObjPtr r;
};
struct Proc {
char *name;
fn_type fn;
};
struct Port {
char *name;
FILE *fh;
};
extern ObjPtr empty_ptr;
extern ObjPtr undef_ptr;
extern ObjPtr true_ptr;
extern ObjPtr false_ptr;
extern ObjPtr strempty_ptr;
extern ObjPtr quote_ptr;
extern ObjPtr eof_ptr;
extern ObjPtr oport;
extern ObjPtr eport;
ObjPtr pnew(ObjPtr l, ObjPtr r);
ObjPtr strnew(ObjPtr l, ObjPtr r);
char *cscmstr_to_utf8(ObjPtr p);
ObjPtr symnew(char *s);
ObjPtr symvnew(char *s);
ObjPtr contnew(Ptr p);
ObjPtr qnew(char *s);
ObjPtr znewfr(char *s);
void zreal(char *s);
void zrealq(char *s);
ObjPtr znew_fr_fr(char sgn, char *s);
ObjPtr znew_fr_q(char sgn, char *s);
ObjPtr znew_fr(char *s);
ObjPtr znew_q(char *s);
ObjPtr znew_s_s(char *s1, char *s);
ObjPtr cnewuc(gunichar uc);
bool err_p(ObjPtr p);
void ewrite(ObjPtr p);
ObjPtr scm_write();
void cdisplay(ObjPtr p, ObjPtr port);
void cwrite(ObjPtr p, ObjPtr port);
extern ObjPtr cread();
ObjPtr cprocnew(Ptr entry, ObjPtr p);
ObjPtr compiled_procedure(ObjPtr p);
ObjPtr compiled_procedure_env(ObjPtr p);
ObjPtr extend_environment(ObjPtr p1, ObjPtr p2, ObjPtr p3);
ObjPtr setup_environment();
ObjPtr define_variable(ObjPtr var, ObjPtr val, ObjPtr env);
ObjPtr set_variable_value(ObjPtr var, ObjPtr val, ObjPtr env);
bool primitive_procedure_p(ObjPtr p);
void save(ObjPtr p);
ObjPtr restore();
ObjPtr lookup_variable_value(ObjPtr var, ObjPtr env);
bool primitive_procedure_p(ObjPtr p);
ObjPtr compiled_procedure_entry(ObjPtr p);
extern ObjPtr scm_argv;
void init();
obj.c
#include "obj.h"
#include <gc.h>
static Obj empty = {.t = EMPTY};
ObjPtr empty_ptr = ∅
static Obj undef = {.t = UNDEF};
ObjPtr undef_ptr = &undef;
static Obj otrue = {.t = BOOLEAN_TRUE};
ObjPtr true_ptr = &otrue;
static Obj ofalse = {.t = BOOLEAN_FALSE};
ObjPtr false_ptr = &ofalse;
static Obj strempty = {.t = STREMPTY};
ObjPtr strempty_ptr = &strempty;
ObjPtr quote_ptr = NULL;
static Obj oeof = {.t = OEOF};
ObjPtr eof_ptr = &oeof;
static Obj oapply = {.t = PROC_APPLY};
ObjPtr apply_ptr = &oapply;
ObjPtr iport = NULL;
ObjPtr oport = NULL;
ObjPtr eport = NULL;
ObjPtr cur_iport = NULL;
ObjPtr cur_oport = NULL;
ObjPtr cur_eport = NULL;
ObjPtr num_err(char *name, ObjPtr argl);
ObjPtr domain_err(char *name, ObjPtr argl);
static size_t clength(ObjPtr p);
ObjPtr utf8_to_scmstr(const char *s);
void cwrite(ObjPtr p, ObjPtr port);
ObjPtr enew(ObjPtr m, ObjPtr o);
ObjPtr scm_eqv_p(ObjPtr argl) {
if (clength(argl) != 2) {
return num_err("eqv?", argl);
}
ObjPtr p1 = argl->p->l;
if (err_p(p1)) {
return p1;
}
Type t1 = p1->t;
ObjPtr p2 = argl->p->r->p->l;
if (err_p(p2)) {
return p2;
}
Type t2 = p2->t;
switch (t1) {
case BOOLEAN_TRUE:
case BOOLEAN_FALSE:
case SYM:
case SYMV:
case EMPTY:
case PAIR:
case STR:
case STREMPTY:
case PROC:
case CPROC:
case PROC_APPLY:
case UNDEF:
case IPORT:
case OPORT:
case IPORT_CLOSED:
case OPORT_CLOSED:
case OEOF:
return p1 == p2 ? true_ptr : false_ptr;
case COMPLEX: {
if (t2 == COMPLEX) {
return mpc_cmp(p1->z, p2->z) == 0 ? true_ptr : false_ptr;
}
return false_ptr;
}
case RATIONAL: {
if (t2 == RATIONAL) {
return mpq_equal(p1->q, p2->q) ? true_ptr : false_ptr;
}
return false_ptr;
}
case CHAR: {
if (t2 == CHAR) {
return p1->uc == p2->uc ? true_ptr : false_ptr;
}
return false_ptr;
}
case CONT:
return false_ptr;
case ERR:
case RERR:
case FERR:
return p1 == p2 ? true_ptr : false_ptr;
}
}
ObjPtr scm_eq_p(ObjPtr argl) {
if (clength(argl) != 2) {
return num_err("eq?", argl);
}
if (err_p(argl->p->l)) {
return argl->p->l;
}
if (err_p(argl->p->l)) {
return argl->p->l;
}
if (err_p(argl->p->r->p->l)) {
return argl->p->r->p->l;
}
return argl->p->l == argl->p->r->p->l ? true_ptr : false_ptr;
}
static ObjPtr onew(Type t) {
ObjPtr out = GC_MALLOC(sizeof(Obj));
out->t = t;
return out;
}
static ObjPtr stack = NULL;
void save(ObjPtr p) { stack = pnew(p, stack); }
ObjPtr restore() {
ObjPtr p = stack->p->l;
stack = stack->p->r;
return p;
}
static ObjPtr cpnew(Type t, ObjPtr l, ObjPtr r) {
ObjPtr out = onew(t);
out->p = GC_MALLOC(sizeof(Pair));
out->p->l = l;
out->p->r = r;
return out;
}
/* environment */
static ObjPtr add_binding_to_frame(ObjPtr var, ObjPtr val, ObjPtr frame) {
frame->p->l = pnew(var, frame->p->l);
frame->p->r = pnew(val, frame->p->r);
return undef_ptr;
}
static ObjPtr make_frame(ObjPtr variables, ObjPtr values) {
return pnew(variables, values);
}
ObjPtr enclosing_environment(ObjPtr env) { return env->p->r; }
static ObjPtr first_frame(ObjPtr env) { return env->p->l; }
static ObjPtr frame_variables(ObjPtr frame) { return frame->p->l; }
static ObjPtr frame_values(ObjPtr frame) { return frame->p->r; }
static size_t clength(ObjPtr p) {
size_t len = 0;
for (ObjPtr p0 = p; p0 != empty_ptr; p0 = p0->p->r) {
len++;
}
return len;
}
ObjPtr extend_environment(ObjPtr vars, ObjPtr vals, ObjPtr base_env) {
ObjPtr vars0 = empty_ptr;
ObjPtr vals0 = empty_ptr;
ObjPtr vals1 = vals;
for (ObjPtr vars1 = vars; vars1 != empty_ptr; vars1 = vars1->p->r) {
if (vars1->t == SYM || vars1->t == SYMV) {
vars0 = pnew(vars1, vars0);
vals0 = pnew(vals1, vals0);
return pnew(make_frame(vars0, vals0), base_env);
}
if (vals1 == empty_ptr) {
fprintf(eport->port->fh, "Too few arguments supplied\n");
cwrite(vars, eport);
fprintf(eport->port->fh, "\n");
cwrite(vals, eport);
fprintf(eport->port->fh, "\n");
exit(1);
}
if (vars1->p->l->t != SYM && vars1->p->l->t != SYMV) {
fprintf(eport->port->fh, "Error: parameters\n");
cwrite(vars1->p->l, eport);
fprintf(eport->port->fh, "\n");
cwrite(vars, eport);
fprintf(eport->port->fh, "\n");
exit(1);
}
vars0 = pnew(vars1->p->l, vars0);
vals0 = pnew(vals1->p->l, vals0);
vals1 = vals1->p->r;
}
if (vals1 != empty_ptr) {
fprintf(eport->port->fh, "Too many arguments supplied\n");
cwrite(vars, eport);
fprintf(eport->port->fh, "\n");
cwrite(vals, eport);
fprintf(eport->port->fh, "\n");
exit(1);
}
return pnew(make_frame(vars0, vals0), base_env);
}
static ObjPtr lookup_variable_value_scan(ObjPtr var, ObjPtr env, ObjPtr vars,
ObjPtr vals);
static ObjPtr lookup_variable_value_env_loop(ObjPtr var, ObjPtr env);
static ObjPtr lookup_variable_value_scan(ObjPtr var, ObjPtr env, ObjPtr vars,
ObjPtr vals) {
if (vars == empty_ptr) {
return lookup_variable_value_env_loop(var, enclosing_environment(env));
}
if (var == vars->p->l) {
return vals->p->l;
}
return lookup_variable_value_scan(var, env, vars->p->r, vals->p->r);
}
static ObjPtr the_empty_environment_ptr = NULL;
static ObjPtr lookup_variable_value_env_loop(ObjPtr var, ObjPtr env) {
if (env == the_empty_environment_ptr) {
fprintf(stderr, "unbound variable ");
cwrite(var, eport);
fprintf(stderr, "\n");
exit(1);
}
ObjPtr frame = first_frame(env);
return lookup_variable_value_scan(var, env, frame_variables(frame),
frame_values(frame));
}
ObjPtr lookup_variable_value(ObjPtr var, ObjPtr env) {
return lookup_variable_value_env_loop(var, env);
}
static ObjPtr set_variable_value_scan(ObjPtr var, ObjPtr val, ObjPtr env,
ObjPtr vars, ObjPtr vals);
static ObjPtr set_variable_value_env_loop(ObjPtr var, ObjPtr val, ObjPtr env);
static ObjPtr set_variable_value_scan(ObjPtr var, ObjPtr val, ObjPtr env,
ObjPtr vars, ObjPtr vals) {
if (vars == empty_ptr) {
return set_variable_value_env_loop(var, val, enclosing_environment(env));
}
if (var == vars->p->l) {
vals->p->l = val;
return undef_ptr;
}
return set_variable_value_scan(var, val, env, vars->p->r, vals->p->r);
}
static ObjPtr set_variable_value_env_loop(ObjPtr var, ObjPtr val, ObjPtr env) {
if (env == the_empty_environment_ptr) {
fprintf(stderr, "unbound variable -- set! ");
cwrite(var, eport);
fprintf(stderr, "\n");
exit(1);
}
ObjPtr frame = first_frame(env);
return set_variable_value_scan(var, val, env, frame_variables(frame),
frame_values(frame));
}
ObjPtr set_variable_value(ObjPtr var, ObjPtr val, ObjPtr env) {
return set_variable_value_env_loop(var, val, env);
}
static ObjPtr define_variable_scan(ObjPtr frame, ObjPtr var, ObjPtr val,
ObjPtr vars, ObjPtr vals) {
if (vars == empty_ptr) {
return add_binding_to_frame(var, val, frame);
}
if (var == vars->p->l) {
vals->p->l = val;
return undef_ptr;
}
return define_variable_scan(frame, var, val, vars->p->r, vals->p->r);
}
ObjPtr define_variable(ObjPtr var, ObjPtr val, ObjPtr env) {
ObjPtr frame = first_frame(env);
return define_variable_scan(frame, var, val, frame_variables(frame),
frame_values(frame));
}
ObjPtr num_err(char *name, ObjPtr argl) {
char *s = NULL;
asprintf(&s, "(%s) wrong number of arguments --", name);
ObjPtr p = enew(utf8_to_scmstr(s), pnew(argl, empty_ptr));
free(s);
return p;
}
ObjPtr domain_err(char *name, ObjPtr argl) {
char *s = NULL;
asprintf(&s, "(%s) argument out of domain --", name);
ObjPtr p = enew(utf8_to_scmstr(s), pnew(argl, empty_ptr));
free(s);
return p;
}
/* pair */
ObjPtr pnew(ObjPtr l, ObjPtr r) { return cpnew(PAIR, l, r); }
bool clist_p(ObjPtr p) {
for (ObjPtr p0 = p; p0 != empty_ptr; p0 = p0->p->r) {
if (p0->t != PAIR) {
return false;
}
}
return true;
}
ObjPtr creverse(ObjPtr p) {
ObjPtr out = empty_ptr;
for (ObjPtr p0 = p; p0 != empty_ptr; p0 = p0->p->r) {
out = pnew(p0->p->l, out);
}
return out;
}
ObjPtr scm_cons(ObjPtr argl) {
if (clength(argl) != 2) {
return num_err("cons", argl);
}
ObjPtr p1 = argl->p->l;
ObjPtr p2 = argl->p->r->p->l;
if (err_p(p1)) {
return p1;
}
if (err_p(p2)) {
return p2;
}
return pnew(p1, p2);
}
ObjPtr scm_car(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("car", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
if (p->t != PAIR) {
return domain_err("car", argl);
}
return p->p->l;
}
ObjPtr scm_cdr(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("cdr", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
if (p->t != PAIR) {
return domain_err("cdr", argl);
}
return p->p->r;
}
ObjPtr scm_set_car(ObjPtr argl) {
if (clength(argl) != 2) {
return num_err("set-car!", argl);
}
ObjPtr p1 = argl->p->l;
ObjPtr p2 = argl->p->r->p->l;
if (err_p(p1)) {
return p1;
}
if (p1->t != PAIR) {
return domain_err("set-car!", argl);
}
if (err_p(p2)) {
return p2;
}
p1->p->l = p2;
return undef_ptr;
}
ObjPtr scm_set_cdr(ObjPtr argl) {
if (clength(argl) != 2) {
return num_err("set-cdr!", argl);
}
ObjPtr p1 = argl->p->l;
if (err_p(p1)) {
return p1;
}
ObjPtr p2 = argl->p->r->p->l;
if (err_p(p2)) {
return p2;
}
if (p1->t != PAIR) {
return domain_err("set-cdr!", argl);
}
p1->p->r = p2;
return undef_ptr;
}
ObjPtr scm_null_p(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("null?", argl);
}
if (err_p(argl->p->l)) {
return argl->p->l;
}
return argl->p->l == empty_ptr ? true_ptr : false_ptr;
}
ObjPtr scm_pair_p(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("pair?", argl);
}
if (err_p(argl->p->l)) {
return argl->p->l;
}
return argl->p->l->t == PAIR ? true_ptr : false_ptr;
}
/* string */
ObjPtr strnew(ObjPtr l, ObjPtr r) { return cpnew(STR, l, r); }
ObjPtr scm_string_p(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("string?", argl);
}
if (err_p(argl->p->l)) {
return argl->p->l;
}
Type t = argl->p->l->t;
return t == STR || t == STREMPTY ? true_ptr : false_ptr;
}
ObjPtr scm_list_to_string(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("list->string", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
if (!clist_p(p)) {
return domain_err("list->string", argl);
}
p = creverse(p);
ObjPtr out = strempty_ptr;
for (ObjPtr p0 = p; p0 != empty_ptr; p0 = p0->p->r) {
ObjPtr p1 = p0->p->l;
if (p1->t != CHAR) {
return domain_err("list->string", argl);
}
out = strnew(p1, out);
}
return out;
}
size_t cslength(ObjPtr p) {
size_t len = 0;
for (ObjPtr p0 = p; p0 != strempty_ptr; p0 = p0->p->r) {
len++;
}
return len;
}
ObjPtr scm_string_to_list(ObjPtr argl) {
size_t len = clength(argl);
if (len == 1) {
ObjPtr p = argl->p->l;
if (p->t == STR || p->t == STREMPTY) {
ObjPtr out = empty_ptr;
for (ObjPtr p0 = p; p0 != strempty_ptr; p0 = p0->p->r) {
ObjPtr c = p0->p->l;
if (err_p(c)) {
return c;
}
if (c->t != CHAR) {
return domain_err("string->list", argl);
}
out = pnew(c, out);
}
return creverse(out);
}
if (err_p(argl)) {
return argl;
}
return domain_err("string->list", argl);
}
return num_err("string->list", argl);
}
ObjPtr scm_string_set(ObjPtr argl) {
if (clength(argl) != 3) {
return num_err("string-set!", argl);
}
ObjPtr p1 = argl->p->l;
ObjPtr p2 = argl->p->r->p->l;
ObjPtr p3 = argl->p->r->p->r->p->l;
if ((p1->t == STR || p1->t == STREMPTY) && p2->t == RATIONAL &&
p3->t == CHAR && mpz_cmp_ui(mpq_denref(p2->q), 1) == 0 &&
mpz_cmp_ui(mpq_numref(p2->q), 0) > 0) {
size_t k = mpz_get_ui(mpq_numref(p2->q));
if (k < cslength(p1)) {
ObjPtr p = p1;
for (size_t i = 0; i < k; i++) {
p = p->p->r;
}
p->p->l = p3;
return undef_ptr;
}
}
if (err_p(argl)) {
return argl;
}
return domain_err("string-set!", argl);
}
ObjPtr utf8_to_scmstr(const char *s) {
glong items_written;
gunichar *ucs = g_utf8_to_ucs4_fast(s, -1, &items_written);
ObjPtr out = strempty_ptr;
for (glong i = items_written - 1; i >= 0; i--) {
out = strnew(cnewuc(ucs[i]), out);
}
g_free(ucs);
return out;
}
char *cscmstr_to_utf8(ObjPtr p) {
size_t len = cslength(p);
gunichar ucs[len];
size_t i = 0;
for (ObjPtr p0 = p; p0 != strempty_ptr; p0 = p0->p->r) {
ucs[i] = p0->p->l->uc;
i++;
}
char *s = g_ucs4_to_utf8(ucs, len, NULL, NULL, NULL);
char *out = GC_STRDUP(s);
g_free(s);
return out;
}
/* symbol */
GHashTable *symtab = NULL;
GStringChunk *chunk = NULL;
ObjPtr symnew(char *s) {
gchar *sym = g_string_chunk_insert_const(chunk, s);
ObjPtr p = g_hash_table_lookup(symtab, sym);
if (p == NULL) {
/* p = onew(SYM); */
p = malloc(sizeof(Obj));
p->t = SYM;
p->s = sym;
g_hash_table_insert(symtab, sym, p);
}
return p;
}
ObjPtr symvnew(char *s) {
gchar *sym = g_string_chunk_insert_const(chunk, s);
ObjPtr p = g_hash_table_lookup(symtab, sym);
if (p == NULL) {
/* p = onew(SYMV); */
p = malloc(sizeof(Obj));
p->t = SYMV;
p->s = sym;
g_hash_table_insert(symtab, sym, p);
}
return p;
}
ObjPtr contnew(Ptr p) {
ObjPtr out = onew(CONT);
out->ptr = p;
return out;
}
ObjPtr scm_symbol_p(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("symbol?", argl);
}
Type t = argl->p->l->t;
return t == SYM || t == SYMV ? true_ptr : false_ptr;
}
ObjPtr scm_symbol_to_string(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("symbol->string", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
Type t = p->t;
if (t != SYM && t != SYMV) {
return domain_err("symbol->string", argl);
}
return utf8_to_scmstr(p->s);
}
ObjPtr scm_string_to_symbol(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("string->symbol", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
if (p->t != STR && p->t != STREMPTY) {
return domain_err("string->symbol", argl);
}
char *s = cscmstr_to_utf8(p);
return symvnew(s);
}
/* numbers */
ObjPtr qnew(char *s) {
ObjPtr p = onew(RATIONAL);
mpq_init(p->q);
mpq_set_str(p->q, s, 10);
mpq_canonicalize(p->q);
return p;
}
static mpfr_prec_t prec = 128;
static mpq_t opq1;
static mpf_t opf1;
static mpfr_t opfr1;
static mpc_t opc1;
static mpq_t qzero;
ObjPtr znewfr(char *s) {
ObjPtr p = onew(COMPLEX);
mpc_init2(p->z, prec);
mpfr_set_str(mpc_realref(p->z), s, 10, MPFR_RNDN);
mpfr_set_ui(mpc_imagref(p->z), 0, MPFR_RNDN);
return p;
}
void zreal(char *s) { mpfr_set_str(opfr1, s, 10, MPFR_RNDN); }
void zrealq(char *s) {
mpq_set_str(opq1, s, 10);
mpfr_set_q(opfr1, opq1, MPFR_RNDN);
}
ObjPtr znew_fr_fr(char sgn, char *s) {
ObjPtr p = onew(COMPLEX);
mpc_init2(p->z, prec);
mpfr_set(mpc_realref(p->z), opfr1, MPFR_RNDN);
mpfr_set_str(mpc_imagref(p->z), s, 10, MPFR_RNDN);
if (sgn == '-') {
mpfr_neg(mpc_imagref(p->z), mpc_imagref(p->z), MPFR_RNDN);
}
return p;
}
ObjPtr znew_fr_q(char sgn, char *s) {
ObjPtr p = onew(COMPLEX);
mpc_init2(p->z, prec);
mpfr_set(mpc_realref(p->z), opfr1, MPFR_RNDN);
mpq_set_str(opq1, s, 10);
if (sgn == '-') {
mpq_neg(opq1, opq1);
}
mpfr_set_q(mpc_imagref(p->z), opq1, MPFR_RNDN);
return p;
}
ObjPtr znew_fr(char *s) {
ObjPtr p = onew(COMPLEX);
mpc_init2(p->z, prec);
mpfr_set_ui(mpc_realref(p->z), 0, MPFR_RNDN);
mpfr_set_str(mpc_imagref(p->z), s, 10, MPFR_RNDN);
return p;
}
ObjPtr znew_q(char *s) {
ObjPtr p = onew(COMPLEX);
mpc_init2(p->z, prec);
mpfr_set_ui(mpc_realref(p->z), 0, MPFR_RNDN);
mpq_set_str(opq1, s, 10);
mpfr_set_q(mpc_imagref(p->z), opq1, MPFR_RNDN);
return p;
}
ObjPtr znew_s_s(char *s1, char *s2) {
ObjPtr p = onew(COMPLEX);
mpc_init2(p->z, prec);
mpfr_set_str(mpc_realref(p->z), s1, 10, MPFR_RNDN);
mpfr_set_str(mpc_imagref(p->z), s2, 10, MPFR_RNDN);
return p;
}
ObjPtr scm_ceiling(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("ceiling", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
switch (p->t) {
case COMPLEX: {
if (!mpfr_zero_p(mpc_imagref(p->z))) {
return domain_err("ceiling", argl);
}
ObjPtr out = onew(COMPLEX);
mpc_init2(out->z, prec);
mpfr_ceil(mpc_realref(out->z), mpc_realref(p->z));
mpfr_set_ui(mpc_imagref(out->z), 0, MPFR_RNDN);
return out;
}
case RATIONAL: {
ObjPtr out = onew(RATIONAL);
mpq_init(out->q);
mpz_cdiv_q(mpq_numref(out->q), mpq_numref(p->q), mpq_denref(p->q));
mpz_set_ui(mpq_denref(out->q), 1);
return out;
}
default:
return domain_err("ceiling", argl);
}
}
ObjPtr scm_denominator(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("denominator", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
switch (p->t) {
case RATIONAL: {
ObjPtr out = onew(RATIONAL);
mpq_init(out->q);
mpz_set(mpq_numref(out->q), mpq_denref(p->q));
mpz_set_ui(mpq_denref(out->q), 1);
return out;
}
default:
return domain_err("denominator", argl);
}
}
ObjPtr scm_numerator(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("numerator", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
switch (p->t) {
case RATIONAL: {
ObjPtr out = onew(RATIONAL);
mpq_init(out->q);
mpz_set(mpq_numref(out->q), mpq_denref(p->q));
mpz_set_ui(mpq_numref(out->q), 1);
return out;
}
default:
return domain_err("numerator", argl);
}
}
ObjPtr scm_exact(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("exact", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
switch (p->t) {
case COMPLEX: {
if (!mpfr_zero_p(mpc_imagref(p->z))) {
return domain_err("exact", argl);
}
mpfr_get_f(opf1, mpc_realref(p->z), MPFR_RNDN);
ObjPtr out = onew(RATIONAL);
mpq_init(out->q);
mpq_set_f(out->q, opf1);
return out;
}
case RATIONAL:
return p;
default:
return domain_err("exact", argl);
}
}
ObjPtr scm_truncate(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("truncate", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
switch (p->t) {
case COMPLEX: {
if (!mpfr_zero_p(mpc_imagref(p->z))) {
return domain_err("truncate", argl);
}
ObjPtr out = onew(COMPLEX);
mpc_init2(out->z, prec);
mpfr_trunc(mpc_realref(out->z), mpc_realref(p->z));
mpfr_set_ui(mpc_imagref(out->z), 0, MPFR_RNDN);
return out;
}
case RATIONAL: {
ObjPtr out = onew(RATIONAL);
mpq_init(out->q);
mpz_tdiv_q(mpq_numref(out->q), mpq_numref(p->q), mpq_denref(p->q));
mpz_set_ui(mpq_denref(out->q), 1);
return out;
}
default:
return domain_err("truncate", argl);
}
}
ObjPtr scm_real_part(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("real-part", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
switch (p->t) {
case COMPLEX: {
ObjPtr out = onew(COMPLEX);
mpc_init2(out->z, prec);
mpfr_set_fr(mpc_realref(out->z), mpc_realref(p->z), MPFR_RNDN);
mpfr_set_ui(mpc_imagref(out->z), 0, MPFR_RNDN);
return out;
}
case RATIONAL: {
ObjPtr out = onew(RATIONAL);
mpq_init(out->q);
mpq_set(out->q, p->q);
return out;
}
default:
return domain_err("real-part", argl);
}
}
ObjPtr scm_imag_part(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("imag-part", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
switch (p->t) {
case COMPLEX: {
ObjPtr out = onew(COMPLEX);
mpc_init2(out->z, prec);
mpfr_set_fr(mpc_realref(out->z), mpc_imagref(p->z), MPFR_RNDN);
mpfr_set_ui(mpc_imagref(out->z), 0, MPFR_RNDN);
return out;
}
case RATIONAL:
return qnew("0");
default:
return domain_err("imag-part", argl);
}
}
ObjPtr scm_angle(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("angle", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
switch (p->t) {
case COMPLEX: {
ObjPtr out = onew(COMPLEX);
mpc_init2(out->z, prec);
mpc_arg(mpc_realref(out->z), p->z, MPC_RNDNN);
mpfr_set_ui(mpc_imagref(out->z), 0, MPFR_RNDN);
return out;
}
case RATIONAL:
return qnew("0");
default:
return domain_err("angle", argl);
}
}
ObjPtr scm_infinite_p(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("infinite?", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
switch (p->t) {
case COMPLEX:
return mpfr_inf_p(mpc_realref(p->z)) || mpfr_inf_p(mpc_imagref(p->z))
? true_ptr
: false_ptr;
case RATIONAL:
return false_ptr;
default:
return domain_err("infinite?", argl);
}
}
ObjPtr scm_nan_p(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("nan?", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
switch (p->t) {
case COMPLEX:
return mpfr_nan_p(mpc_realref(p->z)) || mpfr_nan_p(mpc_imagref(p->z))
? true_ptr
: false_ptr;
case RATIONAL:
return false_ptr;
default:
return domain_err("nan?", argl);
}
}
ObjPtr scm_number_p(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("number?", argl);
}
if (err_p(argl->p->l)) {
return argl->p->l;
}
switch (argl->p->l->t) {
case COMPLEX:
case RATIONAL:
return true_ptr;
default:
return false_ptr;
}
}
ObjPtr scm_exact_p(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("number?", argl);
}
switch (argl->p->l->t) {
case RATIONAL:
return true_ptr;
default:
return false_ptr;
}
}
ObjPtr scm_floor(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("floor", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
switch (p->t) {
case COMPLEX: {
if (!mpfr_zero_p(mpc_imagref(p->z))) {
return domain_err("floor", argl);
}
ObjPtr out = onew(COMPLEX);
mpc_init2(out->z, prec);
mpfr_floor(mpc_realref(out->z), mpc_realref(p->z));
mpfr_set_ui(mpc_imagref(out->z), 0, MPFR_RNDN);
return out;
}
case RATIONAL: {
ObjPtr out = onew(RATIONAL);
mpq_init(out->q);
mpz_fdiv_q(mpq_numref(out->q), mpq_numref(p->q), mpq_denref(p->q));
mpz_set_ui(mpq_denref(out->q), 1);
return out;
}
default:
return domain_err("floor", argl);
}
}
ObjPtr scm_round(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("round", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
switch (p->t) {
case COMPLEX: {
if (!mpfr_zero_p(mpc_imagref(p->z))) {
return domain_err("round", argl);
}
ObjPtr out = onew(COMPLEX);
mpc_init2(out->z, prec);
mpfr_round(mpc_realref(out->z), mpc_realref(p->z));
mpfr_set_ui(mpc_imagref(out->z), 0, MPFR_RNDN);
return out;
}
case RATIONAL: {
ObjPtr out = onew(RATIONAL);
mpq_init(out->q);
mpf_set_q(opf1, p->q);
mpz_set_f(mpq_numref(out->q), opf1);
mpz_set_ui(mpq_denref(out->q), 1);
return out;
}
default:
return domain_err("round", argl);
}
}
ObjPtr scm_math_equal(ObjPtr argl) {
if (argl == empty_ptr || argl->p->r == empty_ptr) {
return num_err("=", argl);
}
bool flag = true;
ObjPtr p0 = argl->p->l;
if (err_p(p0)) {
return p0;
}
switch (p0->t) {
case RATIONAL:
break;
case COMPLEX:
flag = false;
break;
default:
return domain_err("=", argl);
}
for (ObjPtr p = argl->p->r; p != empty_ptr; p = p->p->r) {
ObjPtr p1 = p->p->l;
if (err_p(p1)) {
return p1;
}
if (flag) {
switch (p1->t) {
case RATIONAL: {
if (mpq_equal(p0->q, p1->q)) {
p0 = p1;
break;
}
return false_ptr;
}
case COMPLEX: {
mpc_set_q_q(opc1, p0->q, qzero, MPC_RNDNN);
if (mpc_cmp(opc1, p1->z) == 0) {
p0 = p1;
flag = false;
break;
}
return false_ptr;
}
default:
return domain_err("=", argl);
}
} else {
switch (p1->t) {
case RATIONAL: {
mpc_set_q_q(opc1, p1->q, qzero, MPC_RNDNN);
if (mpc_cmp(p0->z, opc1) == 0) {
p0 = p1;
flag = true;
break;
}
return false_ptr;
}
case COMPLEX: {
if (mpc_cmp(p0->z, p1->z) == 0) {
p0 = p1;
break;
}
return false_ptr;
}
default:
return domain_err("=", argl);
}
}
}
return true_ptr;
}
ObjPtr scm_add(ObjPtr argl) {
mpq_set_ui(opq1, 0, 1);
bool flag = true;
for (ObjPtr p = argl; p != empty_ptr; p = p->p->r) {
ObjPtr p0 = p->p->l;
if (err_p(p0)) {
return p0;
}
if (flag) {
switch (p0->t) {
case RATIONAL: {
mpq_add(opq1, opq1, p0->q);
break;
}
case COMPLEX: {
mpfr_set_q(opfr1, opq1, MPFR_RNDN);
mpc_add_fr(opc1, p0->z, opfr1, MPC_RNDNN);
flag = false;
break;
}
default:
return domain_err("+", argl);
}
} else {
switch (p0->t) {
case RATIONAL: {
mpfr_set_q(opfr1, p0->q, MPFR_RNDN);
mpc_add_fr(opc1, opc1, opfr1, MPC_RNDNN);
break;
}
case COMPLEX: {
mpc_add(opc1, opc1, p0->z, MPC_RNDNN);
break;
}
default:
return domain_err("+", argl);
}
}
}
if (flag) {
ObjPtr p = onew(RATIONAL);
mpq_init(p->q);
mpq_set(p->q, opq1);
return p;
}
ObjPtr p = onew(COMPLEX);
mpc_init2(p->z, prec);
mpc_set(p->z, opc1, MPC_RNDNN);
return p;
}
ObjPtr scm_mul(ObjPtr argl) {
mpq_set_ui(opq1, 1, 1);
bool flag = true;
for (ObjPtr p = argl; p != empty_ptr; p = p->p->r) {
ObjPtr p0 = p->p->l;
if (err_p(p0)) {
return p0;
}
if (flag) {
switch (p0->t) {
case RATIONAL: {
mpq_mul(opq1, opq1, p0->q);
break;
}
case COMPLEX: {
mpfr_set_q(opfr1, opq1, MPFR_RNDN);
mpc_mul_fr(opc1, p0->z, opfr1, MPC_RNDNN);
flag = false;
break;
}
default:
return domain_err("*", argl);
}
} else {
switch (p0->t) {
case RATIONAL: {
mpfr_set_q(opfr1, p0->q, MPFR_RNDN);
mpc_mul_fr(opc1, opc1, opfr1, MPC_RNDNN);
break;
}
case COMPLEX: {
mpc_mul(opc1, opc1, p0->z, MPC_RNDNN);
break;
}
default:
return domain_err("*", argl);
}
}
}
if (flag) {
ObjPtr p = onew(RATIONAL);
mpq_init(p->q);
mpq_set(p->q, opq1);
return p;
}
ObjPtr p = onew(COMPLEX);
mpc_init2(p->z, prec);
mpc_set(p->z, opc1, MPC_RNDNN);
return p;
}
ObjPtr scm_div(ObjPtr argl) {
if (argl == empty_ptr) {
return num_err("/", argl);
}
if (argl->p->r == empty_ptr) {
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
switch (p->t) {
case COMPLEX: {
ObjPtr out = onew(COMPLEX);
mpc_init2(out->z, prec);
mpc_pow_si(out->z, p->z, -1, MPC_RNDNN);
return out;
}
case RATIONAL: {
ObjPtr out = onew(RATIONAL);
mpq_init(out->q);
mpq_inv(out->q, p->q);
return out;
}
default:
return domain_err("/", argl);
}
}
ObjPtr p0 = argl->p->l;
if (err_p(p0)) {
return p0;
}
bool flag = true;
switch (p0->t) {
case RATIONAL:
mpq_set(opq1, p0->q);
break;
case COMPLEX:
mpc_set(opc1, p0->z, MPC_RNDNN);
flag = false;
break;
default:
return domain_err("/", argl);
}
for (ObjPtr p1 = argl->p->r; p1 != empty_ptr; p1 = p1->p->r) {
ObjPtr p2 = p1->p->l;
if (err_p(p2)) {
return p2;
}
if (flag) {
switch (p2->t) {
case RATIONAL:
mpq_div(opq1, opq1, p2->q);
break;
case COMPLEX:
mpfr_set_q(opfr1, opq1, MPFR_RNDN);
mpc_fr_div(opc1, opfr1, p2->z, MPC_RNDNN);
flag = false;
break;
default:
return domain_err("/", argl);
}
} else {
switch (p2->t) {
case RATIONAL:
mpfr_set_q(opfr1, p2->q, MPFR_RNDN);
mpc_div_fr(opc1, opc1, opfr1, MPC_RNDNN);
break;
case COMPLEX:
mpc_div(opc1, opc1, p2->z, MPC_RNDNN);
break;
default:
return domain_err("/", argl);
}
}
}
if (flag) {
ObjPtr out = onew(RATIONAL);
mpq_init(out->q);
mpq_set(out->q, opq1);
return out;
}
ObjPtr out = onew(COMPLEX);
mpc_init2(out->z, prec);
mpc_set(out->z, opc1, MPC_RNDNN);
return out;
}
ObjPtr scm_lt(ObjPtr argl) {
if (argl == empty_ptr || argl->p->r == empty_ptr) {
return num_err("<", argl);
}
bool flag = true;
ObjPtr p0 = argl->p->l;
if (err_p(p0)) {
return p0;
}
switch (p0->t) {
case RATIONAL:
break;
case COMPLEX:
if (!mpfr_zero_p(mpc_imagref(p0->z))) {
return domain_err("<", argl);
}
flag = false;
break;
default:
return domain_err("<", argl);
}
for (ObjPtr p = argl->p->r; p != empty_ptr; p = p->p->r) {
ObjPtr p1 = p->p->l;
if (err_p(p1)) {
return p1;
}
if (flag) {
switch (p1->t) {
case RATIONAL: {
if (mpq_cmp(p0->q, p1->q) < 0) {
p0 = p1;
break;
}
return false_ptr;
}
case COMPLEX: {
if (!mpfr_zero_p(mpc_imagref(p1->z))) {
return domain_err("<", argl);
}
if (mpfr_cmp_q(mpc_realref(p1->z), p0->q) > 0) {
p0 = p1;
flag = false;
break;
}
return false_ptr;
}
default:
return domain_err("=", argl);
}
} else {
switch (p1->t) {
case RATIONAL: {
if (mpfr_cmp_q(mpc_realref(p0->z), p1->q) < 0) {
p0 = p1;
flag = true;
break;
}
return false_ptr;
}
case COMPLEX: {
if (!mpfr_zero_p(mpc_imagref(p1->z))) {
return domain_err("<", argl);
}
if (mpfr_less_p(mpc_realref(p0->z), mpc_realref(p1->z))) {
p0 = p1;
break;
}
return false_ptr;
}
default:
return domain_err("=", argl);
}
}
}
return true_ptr;
}
ObjPtr scm_number_to_string(ObjPtr argl) {
size_t len = clength(argl);
if (len == 1) {
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
switch (p->t) {
case COMPLEX: {
char *s;
mpfr_asprintf(&s, "%Rf%+Rfi", mpc_realref(p->z), mpc_imagref(p->z));
ObjPtr out = utf8_to_scmstr(s);
return out;
}
case RATIONAL: {
char *s = NULL;
gmp_asprintf(&s, "%Qd", p->q);
ObjPtr out = utf8_to_scmstr(s);
return out;
}
default:
return domain_err("number->string", argl);
}
}
return num_err("number->string", argl);
}
/* chars */
ObjPtr cnewuc(gunichar uc) {
ObjPtr p = onew(CHAR);
p->uc = uc;
return p;
}
gunichar getuc(FILE *fh) {
char p[5];
for (gsize max_len = 1;; max_len++) {
char c = fgetc(fh);
if (c == EOF) {
return EOF;
}
p[max_len - 1] = c;
gunichar uc = g_utf8_get_char_validated(p, max_len);
if (uc != (gunichar)-2) {
return uc;
}
}
}
ObjPtr scm_char_p(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("char?", argl);
}
if (err_p(argl->p->l)) {
return argl->p->l;
}
return argl->p->l->t == CHAR ? true_ptr : false_ptr;
}
ObjPtr scm_char_to_integer(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("char->integer", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
if (p->t != CHAR) {
return domain_err("char->integer", argl);
}
ObjPtr out = onew(RATIONAL);
mpq_init(out->q);
mpq_set_ui(out->q, p->uc, 1);
return out;
}
ObjPtr scm_integer_to_char(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("integer->char", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
switch (p->t) {
case COMPLEX: {
if (!mpfr_zero_p(mpc_imagref(p->z))) {
return domain_err("integer->char", argl);
}
mpfr_floor(opfr1, mpc_realref(p->z));
if (mpfr_equal_p(mpc_realref(p->z), opfr1)) {
return cnewuc(mpfr_get_si(mpc_realref(p->z), MPFR_RNDN));
}
return domain_err("integer->char", argl);
}
case RATIONAL: {
if (mpz_cmp_ui(mpq_denref(p->q), 1) == 0) {
return cnewuc(mpz_get_si(mpq_numref(p->q)));
}
return domain_err("integer->char", argl);
}
default:
return domain_err("integer->char", argl);
}
}
ObjPtr scm_char_alphabetic_p(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("char-alphabetic?", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
if (p->t == CHAR) {
return g_unichar_isalpha(p->uc) ? true_ptr : false_ptr;
}
return domain_err("char-alphabetic?", argl);
}
ObjPtr scm_char_downcase(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("char-downcase", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
if (p->t == CHAR) {
return cnewuc(g_unichar_tolower(p->uc));
}
return domain_err("char-downcase", argl);
}
ObjPtr scm_char_foldcase(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("char-foldcase", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
if (p->t == CHAR) {
char outbuf[6];
int len = g_unichar_to_utf8(p->uc, outbuf);
char *s = g_utf8_casefold(outbuf, len);
ObjPtr out = onew(CHAR);
out->uc = g_utf8_get_char(s);
g_free(s);
return out;
}
return domain_err("char-foldcase", argl);
}
ObjPtr scm_char_lower_case_p(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("char-lower-case?", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
if (p->t == CHAR) {
return g_unichar_islower(p->uc) ? true_ptr : false_ptr;
}
return domain_err("char-lower-case?", argl);
}
ObjPtr scm_char_numeric_p(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("char-numeric?", argl);
}
ObjPtr p = argl->p->l;
if (p->t == CHAR) {
return g_unichar_isdigit(p->uc) ? true_ptr : false_ptr;
}
return domain_err("char-numeric?", argl);
}
ObjPtr scm_char_upcase(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("char-upcase", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
if (p->t == CHAR) {
return cnewuc(g_unichar_toupper(p->uc));
}
return domain_err("char-upcase", argl);
}
ObjPtr scm_char_upper_case_p(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("char-upper-case?", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
if (p->t == CHAR) {
return g_unichar_isupper(p->uc) ? true_ptr : false_ptr;
}
return domain_err("char-upper-case?", argl);
}
ObjPtr scm_char_whitespace_p(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("char-whitespace?", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
if (p->t == CHAR) {
return g_unichar_isspace(p->uc) ? true_ptr : false_ptr;
}
return domain_err("char-whitespace?", argl);
}
ObjPtr scm_digit_value(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("digit-value", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
if (p->t == CHAR) {
gint n = g_unichar_digit_value(p->uc);
if (n == -1) {
return false_ptr;
}
ObjPtr out = onew(RATIONAL);
mpq_init(out->q);
mpq_set_ui(out->q, n, 1);
return out;
}
return domain_err("digit-value", argl);
}
/* boolean */
ObjPtr scm_boolean_p(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("boolean?", argl);
}
if (err_p(argl->p->l)) {
return argl->p->l;
}
Type t = argl->p->l->t;
return t == BOOLEAN_TRUE || t == BOOLEAN_FALSE ? true_ptr : false_ptr;
}
/* procedure */
ObjPtr procnew(char *name, fn_type fn) {
ObjPtr p = onew(PROC);
ProcPtr proc = GC_MALLOC(sizeof(Proc));
proc->fn = fn;
proc->name = GC_STRDUP(name);
p->proc = proc;
return p;
}
ObjPtr scm_procedure_p(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("procedure?", argl);
}
if (err_p(argl->p->l)) {
return argl->p->l;
}
Type t = argl->p->l->t;
return t == PROC || t == CPROC || t == PROC_APPLY ? true_ptr : false_ptr;
}
/* exceptions */
ObjPtr enew(ObjPtr m, ObjPtr o) {
ObjPtr p = cpnew(ERR, m, o);
return p;
}
void ewrite(ObjPtr p) {
fprintf(cur_eport->port->fh, "ERROR: ");
if (p->p->l != strempty_ptr) {
cdisplay(p->p->l, cur_eport);
fprintf(cur_eport->port->fh, " ");
}
for (ObjPtr p0 = p->p->r; p0 != empty_ptr; p0 = p0->p->r) {
cwrite(p0->p->l, cur_eport);
fprintf(cur_eport->port->fh, " ");
}
}
bool err_p(ObjPtr p) {
Type t = p->t;
return t == ERR || t == FERR || t == RERR;
}
ObjPtr scm_raise(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("raise", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
return enew(strempty_ptr, pnew(p, empty_ptr));
}
ObjPtr scm_error(ObjPtr argl) {
if (argl == empty_ptr) {
return num_err("error", argl);
}
if (err_p(argl->p->l)) {
return argl->p->l;
}
for (ObjPtr p0 = argl->p->r; p0 != empty_ptr; p0 = p0->p->r) {
if (err_p(p0->p->l)) {
return p0->p->l;
}
}
return enew(argl->p->l, argl->p->r);
}
ObjPtr scm_error_object_p(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("error-object?", argl);
}
return err_p(argl->p->l) ? true_ptr : false_ptr;
}
ObjPtr scm_error_object_message(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("error-object-message", argl);
}
if (err_p(argl->p->l)) {
return argl->p->l->p->l;
}
return domain_err("error-object-message", argl);
}
ObjPtr scm_error_object_irritants(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("error-object-irritants", argl);
}
if (err_p(argl->p->l)) {
return argl->p->l->p->r;
}
return domain_err("error-object-irritants", argl);
}
ObjPtr scm_read_error_p(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("read-error?", argl);
}
return argl->p->l->t == RERR ? true_ptr : false_ptr;
}
ObjPtr scm_file_error_p(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("file-error?", argl);
}
return argl->p->l->t == FERR ? true_ptr : false_ptr;
}
/* io */
ObjPtr portnew(Type t, char *name, FILE *fh) {
ObjPtr p = onew(t);
PortPtr port = GC_MALLOC(sizeof(Port));
port->name = GC_STRDUP(name);
port->fh = fh;
p->port = port;
return p;
}
void cwrite(ObjPtr p, ObjPtr port) {
switch (p->t) {
case EMPTY:
fprintf(port->port->fh, "()");
break;
case PAIR: {
fprintf(port->port->fh, "(");
cwrite(p->p->l, port);
ObjPtr p0;
for (p0 = p; p0->p->r->t == PAIR; p0 = p0->p->r) {
fprintf(port->port->fh, " ");
cwrite(p0->p->r->p->l, port);
}
if (p0->p->r == empty_ptr) {
fprintf(port->port->fh, ")");
break;
}
fprintf(port->port->fh, " . ");
cwrite(p0->p->r, port);
fprintf(port->port->fh, ")");
break;
}
case SYM:
fprintf(port->port->fh, "%s", p->s);
break;
case SYMV: {
ObjPtr s = utf8_to_scmstr(p->s);
fprintf(port->port->fh, "|");
for (ObjPtr p0 = s; p0 != strempty_ptr; p0 = p0->p->r) {
ObjPtr c = p0->p->l;
gunichar uc = c->uc;
if (uc == '\a') {
fprintf(port->port->fh, "\\a");
} else if (uc == '\b') {
fprintf(port->port->fh, "\\b");
} else if (uc == '\t') {
fprintf(port->port->fh, "\\t");
} else if (uc == '\n') {
fprintf(port->port->fh, "\\n");
} else if (uc == '\r') {
fprintf(port->port->fh, "\\r");
} else if (uc == '|') {
fprintf(port->port->fh, "\\|");
} else if (uc == ' ') {
fprintf(port->port->fh, " ");
} else if (!g_unichar_isprint(uc) || uc == '\\') {
fprintf(port->port->fh, "\\x%x;", uc);
} else {
char outbuf[6];
int len = g_unichar_to_utf8(uc, outbuf);
outbuf[len] = '\0';
fprintf(port->port->fh, "%s", outbuf);
}
}
fprintf(port->port->fh, "|");
break;
}
case COMPLEX: {
if (mpfr_zero_p(mpc_imagref(p->z))) {
mpfr_fprintf(port->port->fh, "%.32Rf", mpc_realref(p->z));
} else {
mpfr_fprintf(port->port->fh, "%.16Rf%+.16Rfi", mpc_realref(p->z),
mpc_imagref(p->z));
}
break;
}
case RATIONAL:
gmp_fprintf(port->port->fh, "%Qd", p->q);
break;
case PROC: {
fprintf(port->port->fh, "#<primitive-procedure %s>", p->proc->name);
break;
}
case CPROC: {
fprintf(port->port->fh, "#<compiled-procedure %p>", p->p->l->ptr);
break;
}
case PROC_APPLY:
fprintf(port->port->fh, "#<primitive-procedure apply>");
break;
case CHAR: {
gchar outbuf[6];
gint len = g_unichar_to_utf8(p->uc, outbuf);
outbuf[len] = '\0';
fprintf(port->port->fh, "#\\%s", outbuf);
break;
}
case STR: {
fprintf(port->port->fh, "\"");
for (ObjPtr p0 = p; p0 != strempty_ptr; p0 = p0->p->r) {
gunichar uc = p0->p->l->uc;
if (uc == '\a') {
fprintf(port->port->fh, "\\a");
} else if (uc == '\b') {
fprintf(port->port->fh, "\\b");
} else if (uc == '\t') {
fprintf(port->port->fh, "\\t");
} else if (uc == '\n') {
fprintf(port->port->fh, "\\n");
} else if (uc == '\r') {
fprintf(port->port->fh, "\\r");
} else if (!g_unichar_isprint(uc) || uc == '"' || uc == '\\') {
fprintf(port->port->fh, "\\x%x;", uc);
} else {
gchar outbuf[6];
gint len = g_unichar_to_utf8(uc, outbuf);
outbuf[len] = '\0';
fprintf(port->port->fh, "%s", outbuf);
}
}
fprintf(port->port->fh, "\"");
break;
}
case IPORT: {
fprintf(port->port->fh, "#<input-port %s>", port->port->name);
break;
}
case OPORT: {
fprintf(port->port->fh, "#<output-port %s>", port->port->name);
break;
}
case IPORT_CLOSED: {
fprintf(port->port->fh, "#<input-port(closed) %s>", port->port->name);
break;
}
case OPORT_CLOSED: {
fprintf(port->port->fh, "#<output-port(closed) %s>", port->port->name);
break;
}
case UNDEF:
fprintf(port->port->fh, "#<unspecified>");
break;
case BOOLEAN_TRUE:
fprintf(port->port->fh, "#true");
break;
case BOOLEAN_FALSE:
fprintf(port->port->fh, "#false");
break;
case STREMPTY:
fprintf(port->port->fh, "\"\"");
break;
case OEOF:
fprintf(port->port->fh, "#<eof>");
case CONT:
break;
case ERR:
fprintf(port->port->fh, "#<error-object message: ");
cwrite(p->p->l, port);
fprintf(port->port->fh, " list: ");
cwrite(p->p->r, port);
fprintf(port->port->fh, ">");
break;
case RERR:
fprintf(port->port->fh, "#<error-object(read) message: ");
cwrite(p->p->l, port);
fprintf(port->port->fh, " list: ");
cwrite(p->p->r, port);
fprintf(port->port->fh, ">");
break;
case FERR:
fprintf(port->port->fh, "#<error-object(file) message: ");
cwrite(p->p->l, port);
fprintf(port->port->fh, " list: ");
cwrite(p->p->r, port);
fprintf(port->port->fh, ">");
break;
}
}
void cdisplay(ObjPtr p, ObjPtr port) {
switch (p->t) {
case EMPTY:
case COMPLEX:
case RATIONAL:
case PROC:
case CPROC:
case PROC_APPLY:
case IPORT:
case OPORT:
case IPORT_CLOSED:
case OPORT_CLOSED:
case UNDEF:
case BOOLEAN_TRUE:
case BOOLEAN_FALSE:
case CONT:
case SYM:
case OEOF:
case ERR:
case RERR:
case FERR:
cwrite(p, port);
break;
case CHAR: {
gchar outbuf[6];
gint len = g_unichar_to_utf8(p->uc, outbuf);
outbuf[len] = '\0';
fprintf(port->port->fh, "%s", outbuf);
break;
}
case STR: {
for (ObjPtr p0 = p; p0 != strempty_ptr; p0 = p0->p->r) {
cdisplay(p0->p->l, port);
}
break;
}
case STREMPTY:
fprintf(port->port->fh, "");
break;
case PAIR: {
fprintf(port->port->fh, "(");
cdisplay(p->p->l, port);
ObjPtr p0;
for (p0 = p; p0->p->r->t == PAIR; p0 = p0->p->r) {
fprintf(port->port->fh, " ");
cdisplay(p0->p->r->p->l, port);
}
if (p0->p->r == empty_ptr) {
fprintf(port->port->fh, ")");
break;
}
fprintf(port->port->fh, " . ");
cdisplay(p0->p->r, port);
fprintf(port->port->fh, ")");
break;
}
case SYMV:
fprintf(port->port->fh, "%s", p->s);
break;
}
}
static ObjPtr primitive_procedures = NULL;
ObjPtr primitive_procedure_names(ObjPtr p) {
if (p == empty_ptr) {
return empty_ptr;
}
return pnew(p->p->l->p->l, primitive_procedure_names(p->p->r));
}
ObjPtr primitive_procedure_objects(ObjPtr p) {
if (p == empty_ptr) {
return empty_ptr;
}
return pnew(p->p->l->p->r, primitive_procedure_objects(p->p->r));
}
ObjPtr setup_environment() {
ObjPtr initial_env =
extend_environment(primitive_procedure_names(primitive_procedures),
primitive_procedure_objects(primitive_procedures),
the_empty_environment_ptr);
define_variable(symnew("apply"), apply_ptr, initial_env);
return initial_env;
}
ObjPtr cprocnew(Ptr entry, ObjPtr env) {
ObjPtr p = onew(CONT);
p->ptr = entry;
return cpnew(CPROC, p, env);
}
ObjPtr compiled_procedure_env(ObjPtr p) { return p->p->r; }
ObjPtr compiled_procedure_entry(ObjPtr p) { return p->p->l; }
ObjPtr scm_current_error_port(ObjPtr argl) {
if (argl != empty_ptr) {
return num_err("current-error-port", argl);
}
return cur_eport;
}
ObjPtr scm_current_input_port(ObjPtr argl) {
if (argl != empty_ptr) {
return num_err("current-input-port", argl);
}
return cur_iport;
}
ObjPtr scm_current_output_port(ObjPtr argl) {
if (argl != empty_ptr) {
return num_err("current-output-port", argl);
}
return cur_oport;
}
ObjPtr scm_flush_output_port(ObjPtr argl) {
size_t len = clength(argl);
if (len == 0) {
fflush(cur_oport->port->fh);
} else if (len == 1) {
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
if (p->t == OPORT) {
fflush(p->port->fh);
} else {
return domain_err("flush-output-port", argl);
}
} else {
return num_err("flush-output-port", argl);
}
return undef_ptr;
}
ObjPtr scm_textual_port_p(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("textual-port?", argl);
}
switch (argl->p->l->t) {
case IPORT:
case OPORT:
case IPORT_CLOSED:
case OPORT_CLOSED:
return true_ptr;
default:
return false_ptr;
}
}
ObjPtr scm_write(ObjPtr argl) {
ObjPtr p = NULL;
ObjPtr port = NULL;
if (clength(argl) == 1) {
p = argl->p->l;
/* if (err_p(p)) { */
/* return p; */
/* } */
port = cur_oport;
} else if (clength(argl) == 2) {
p = argl->p->l;
ObjPtr p0 = argl->p->r->p->l;
if (err_p(p0)) {
return p0;
}
if (p0->t != OPORT) {
return domain_err("write", argl);
}
port = p0;
} else {
return num_err("write", argl);
}
cwrite(p, port);
return undef_ptr;
}
ObjPtr scm_display(ObjPtr argl) {
ObjPtr p = NULL;
ObjPtr port = NULL;
if (clength(argl) == 1) {
p = argl->p->l;
/* if (err_p(p)) { */
/* return p; */
/* } */
port = cur_oport;
} else if (clength(argl) == 2) {
p = argl->p->l;
ObjPtr p0 = argl->p->r->p->l;
if (err_p(p0)) {
return p0;
}
if (p0->t != OPORT) {
return domain_err("display", argl);
}
port = p0;
} else {
return num_err("display", argl);
}
cdisplay(p, port);
return undef_ptr;
}
ObjPtr scm_read_char(ObjPtr argl) {
size_t len = clength(argl);
if (len == 0) {
gunichar c = getuc(cur_iport->port->fh);
return c == EOF ? eof_ptr : cnewuc(c);
}
if (len == 1) {
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
if (p->t == IPORT) {
gunichar c = getuc(cur_iport->port->fh);
return c == EOF ? eof_ptr : cnewuc(c);
}
return domain_err("read-char", argl);
}
return num_err("read-char", argl);
}
#include <errno.h>
#include <string.h>
ObjPtr scm_open_input_file(ObjPtr argl) {
size_t len = clength(argl);
if (len != 1) {
return num_err("open-input-file", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
if (p->t != STR && p->t != STREMPTY) {
return domain_err("open-input-file", argl);
}
char *filename = cscmstr_to_utf8(p);
FILE *fh = fopen(filename, "r");
if (fh == NULL) {
fprintf(stderr, "%s: %s\n", filename, strerror(errno));
exit(1);
}
ObjPtr out = portnew(IPORT, filename, fh);
return out;
}
ObjPtr scm_open_output_file(ObjPtr argl) {
size_t len = clength(argl);
if (len != 1) {
return num_err("open-input-file", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
if (p->t != STR && p->t != STREMPTY) {
return domain_err("open-input-file", argl);
}
char *filename = cscmstr_to_utf8(p);
FILE *fh = fopen(filename, "w");
if (fh == NULL) {
fprintf(stderr, "%s: %s\n", filename, strerror(errno));
exit(1);
}
ObjPtr out = portnew(OPORT, filename, fh);
return out;
}
ObjPtr scm_input_port_open_p(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("input-port-open?", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
switch (p->t) {
case IPORT:
return true_ptr;
case OPORT:
case IPORT_CLOSED:
case OPORT_CLOSED:
return false_ptr;
default:
return domain_err("input-port-open?", argl);
}
}
ObjPtr scm_input_port_p(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("input-port?", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
switch (p->t) {
case IPORT:
case IPORT_CLOSED:
return true_ptr;
default:
return false_ptr;
}
}
ObjPtr scm_output_port_p(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("output-port?", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
switch (p->t) {
case OPORT:
case OPORT_CLOSED:
return true_ptr;
default:
return false_ptr;
}
}
ObjPtr scm_output_port_open_p(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("output-port-open?", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
switch (p->t) {
case OPORT:
return true_ptr;
case IPORT:
case IPORT_CLOSED:
case OPORT_CLOSED:
return false_ptr;
default:
return domain_err("output-port-open?", argl);
}
}
ObjPtr scm_close_port(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("close-port", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
switch (p->t) {
case IPORT:
fclose(p->port->fh);
p->t = IPORT_CLOSED;
return undef_ptr;
case OPORT:
fclose(p->port->fh);
p->t = OPORT_CLOSED;
return undef_ptr;
default:
return domain_err("close-port", argl);
}
}
extern FILE *yyin;
extern void yyrestart(FILE *fh);
ObjPtr scm_read(ObjPtr argl) {
size_t len = clength(argl);
if (len == 0) {
return cread();
}
if (len == 1) {
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
if (p->t == IPORT) {
yyrestart(p->port->fh);
ObjPtr out = cread();
yyrestart(cur_iport->port->fh);
return out;
}
return domain_err("read", argl);
}
return num_err("read", argl);
}
ObjPtr scm_eof_object(ObjPtr argl) {
if (argl != empty_ptr) {
return num_err("eof-object", argl);
}
return eof_ptr;
}
ObjPtr scm_eof_object_p(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("eof-object?", argl);
}
return argl->p->l == eof_ptr ? true_ptr : false_ptr;
}
/* system */
ObjPtr scm_argv = NULL;
ObjPtr scm_command_line(ObjPtr argl) {
if (argl != empty_ptr) {
return num_err("command-line", argl);
}
return scm_argv;
}
ObjPtr scm_exit(ObjPtr argl) {
size_t len = clength(argl);
if (len == 0) {
exit(0);
}
if (len == 1) {
exit(1);
}
return num_err("exit", argl);
}
ObjPtr scm_system(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("system", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
if (p->t != STR && p->t != STREMPTY) {
return domain_err("system", argl);
}
char *s = cscmstr_to_utf8(p);
int n = system(s);
ObjPtr out = onew(RATIONAL);
mpq_init(out->q);
mpq_set_si(out->q, n, 1);
return out;
}
/* inexact library */
ObjPtr scm_exp(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("exp", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
switch (p->t) {
case COMPLEX: {
ObjPtr out = onew(COMPLEX);
mpc_init2(out->z, prec);
mpc_exp(out->z, p->z, MPC_RNDNN);
return out;
}
case RATIONAL: {
mpfr_set_q(opfr1, p->q, MPFR_RNDN);
mpc_set_fr(opc1, opfr1, MPC_RNDNN);
ObjPtr out = onew(COMPLEX);
mpc_init2(out->z, prec);
mpc_exp(out->z, opc1, MPC_RNDNN);
return out;
}
default:
return domain_err("exp", argl);
}
}
ObjPtr scm_log(ObjPtr argl) {
size_t len = clength(argl);
if (len == 1) {
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
switch (p->t) {
case COMPLEX: {
ObjPtr out = onew(COMPLEX);
mpc_init2(out->z, prec);
mpc_log(out->z, p->z, MPC_RNDNN);
return out;
}
case RATIONAL: {
mpfr_set_q(opfr1, p->q, MPFR_RNDN);
mpc_set_fr(opc1, opfr1, MPC_RNDNN);
ObjPtr out = onew(COMPLEX);
mpc_init2(out->z, prec);
mpc_log(out->z, opc1, MPC_RNDNN);
return out;
}
default:
return domain_err("log", argl);
}
}
if (len == 2) {
}
return num_err("log", argl);
}
static void *allocate_function(size_t alloc_size) {
return GC_MALLOC(alloc_size);
}
static void *realloc_func(void *ptr, size_t old_size, size_t new_size) {
return GC_REALLOC(ptr, new_size);
}
static void free_function(void *ptr, size_t size) { GC_FREE(ptr); }
void init() {
GC_INIT();
mp_set_memory_functions(allocate_function, realloc_func, free_function);
mpq_init(opq1);
mpf_init(opf1);
mpfr_init(opfr1);
mpc_init2(opc1, prec);
mpq_init(qzero);
mpq_set_ui(qzero, 0, 1);
symtab = g_hash_table_new(NULL, NULL);
chunk = g_string_chunk_new(1024);
quote_ptr = symnew("quote");
stack = empty_ptr;
Proc procs[] = {{"*", scm_mul},
{"+", scm_add},
{"=", scm_math_equal},
{"/", scm_div},
{"<", scm_lt},
{"boolean?", scm_boolean_p},
{"car", scm_car},
{"cdr", scm_cdr},
{"ceiling", scm_ceiling},
{"char?", scm_char_p},
{"char->integer", scm_char_to_integer},
{"close-port", scm_close_port},
{"command-line", scm_command_line},
{"cons", scm_cons},
{"current-error-port", scm_current_error_port},
{"current-input-port", scm_current_input_port},
{"current-output-port", scm_current_output_port},
{"denominator", scm_denominator},
{"display", scm_display},
{"eof-object", scm_eof_object},
{"eof-object?", scm_eof_object_p},
{"eq?", scm_eq_p},
{"eqv?", scm_eqv_p},
{"error", scm_error},
{"error-object-irritants", scm_error_object_irritants},
{"error-object-message", scm_error_object_message},
{"error-object?", scm_error_object_p},
{"exact", scm_exact},
{"exact?", scm_exact_p},
{"file-error?", scm_file_error_p},
{"floor", scm_floor},
{"flush-output-port", scm_flush_output_port},
{"input-port-open?", scm_input_port_open_p},
{"input-port?", scm_input_port_p},
{"integer->char", scm_integer_to_char},
{"list->string", scm_list_to_string},
{"null?", scm_null_p},
{"number?", scm_number_p},
{"number->string", scm_number_to_string},
{"numerator", scm_numerator},
{"output-port-open?", scm_output_port_open_p},
{"output-port?", scm_output_port_p},
{"pair?", scm_pair_p},
{"procedure?", scm_procedure_p},
{"raise", scm_raise},
{"read-char", scm_read_char},
{"read-error?", scm_read_error_p},
{"round", scm_round},
{"set-car!", scm_set_car},
{"set-cdr!", scm_set_cdr},
{"string->list", scm_string_to_list},
{"string->symbol", scm_string_to_symbol},
{"string-set!", scm_string_set},
{"string?", scm_string_p},
{"symbol->string", scm_symbol_to_string},
{"symbol?", scm_symbol_p},
{"textual-port?", scm_textual_port_p},
{"truncate", scm_truncate},
/* case-lambda */
/* char library */
{"char-alphabetic?", scm_char_alphabetic_p},
{"char-downcase", scm_char_downcase},
{"char-foldcase", scm_char_foldcase},
{"char-lower-case?", scm_char_lower_case_p},
{"char-numeric?", scm_char_numeric_p},
{"char-upcase", scm_char_upcase},
{"char-upper-case?", scm_char_upper_case_p},
{"char-whitespace?", scm_char_whitespace_p},
{"digit-value", scm_digit_value},
/* complex library */
{"angle", scm_angle},
{"imag-part", scm_imag_part},
{"real-part", scm_real_part},
/* inexact library */
{"exp", scm_exp},
{"infinite?", scm_infinite_p},
{"log", scm_log},
{"nan?", scm_nan_p},
{"open-input-file", scm_open_input_file},
{"open-output-file", scm_open_output_file},
{"read", scm_read},
{"system", scm_system},
{"write", scm_write},
{"exit", scm_exit},
{NULL, NULL}};
primitive_procedures = empty_ptr;
for (size_t i = 0; procs[i].name != NULL; i++) {
ObjPtr p = pnew(symnew(procs[i].name), procnew(procs[i].name, procs[i].fn));
primitive_procedures = pnew(p, primitive_procedures);
}
the_empty_environment_ptr = empty_ptr;
iport = portnew(IPORT, "stdin", stdin);
oport = portnew(OPORT, "stdout", stdout);
eport = portnew(OPORT, "stderr", stderr);
cur_iport = portnew(IPORT, "stdin", stdin);
cur_oport = portnew(OPORT, "stdout", stdout);
cur_eport = portnew(OPORT, "stderr", stderr);
}
0 コメント:
コメントを投稿