開発環境
- macOS Sierra - Apple (OS)
- Emacs (Text Editor)
- C, Scheme (プログラミング言語)
- Clang/LLVM (コンパイラ, Xcode - Apple)
- 参考書籍等
Cを高級アセンブラーとした、Scheme の コンパイラー(ksc)、インタプリター(ksi)の作成で、ベクター型とそれに関連する手続き(主に標準ライブラリーの base library と primitive(C言語))を実装。
リストとベクターで100番目(位置、インデックスは0からなので99の位置)の要素へのアクセス速度の違いを実験、測定。
temp1.scm
(list-ref '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100) 99)
temp2.scm
(vector-ref #(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100) 99)
入出力結果(Terminal)
$ time ./ksi < temp1.scm > => 100 > real 0m4.096s user 0m4.699s sys 0m0.209s $ time ./ksi < temp2.scm > => 100 > real 0m0.351s user 0m0.404s sys 0m0.028s $
理論から予想した通り、要素へのアクセスはベクター(vector-ref手続き)の方がリスト(list-ref手続き)より速い。(ベクターはリストをベクターに変換することにより実装してるが、その影響は少ないと仮定。)
(vector-ref手続きは primitive(C言語により実装)、list-ref は合成手続き(car 手続きと car 手続き等、base library 内)として実装してる影響も大きいのかも。)
コード
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)
(vector? 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 'binary-port? binary-port?)
(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 'list->vector list->vector)
(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 'peek-char peek-char)
(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)
(cons 'vector vector)
(cons 'vector->list vector->list)
(cons 'vector-for-each vector-for-each)
(cons 'vector-length vector-length)
(cons 'vector-map vector-map)
(cons 'vector-ref vector-ref)
(cons 'vector-set! vector-set!)
(cons 'vector? vector?)
;; 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)
;; cxr library
;; eval library
;; file library
(cons 'delete-file delete-file)
(cons 'file-exists? file-exists?)
(cons 'open-binary-input-file open-binary-input-file)
(cons 'open-binary-output-file open-binary-output-file)
(cons 'open-input-file open-input-file)
(cons 'open-output-file open-output-file)
;; 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)
)
base.scm
(begin
;; * primitive
;; + primitive
(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)))))
;; / primitive
;; < primitive
(define (<= x1 x2 . xs)
(define (cmp x1 x2) (or (= x1 x2) (< x1 x2)))
(define (iter x xs)
(if (null? xs)
#t
(if (cmp x (car xs))
(iter (car xs) (cdr xs))
#f)))
(and (cmp x1 x2) (iter x2 xs)))
;; = primitive
(define (> x1 x2 . xs)
(define (iter x xs)
(cond ((null? xs) #t)
((< (car xs) x) (iter (car xs) (cdr xs)))
(#t #f)))
(if (< x2 x1) (iter xs xs) #f))
(define (>= x1 x2 . xs)
(define (cmp x1 x2) (or (= x1 x2) (> x1 x2)))
(define (iter x xs)
(if (null? xs)
#t
(if (cmp x (car xs))
(iter (car xs) (cdr xs))
#f)))
(and (cmp x1 x2) (iter x2 xs)))
(define (abs x) (if (< x 0) (- x) x))
;; and syntax
(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))))
;; apply primitive
(define (assoc obj alist . compare)
(define cmp (if (null? compare) equal? (car compare)))
(define (iter alist)
(cond ((null? alist) #f)
((cmp obj (caar alist)) (car alist))
(#t (iter (cdr alist)))))
(iter alist))
(define (assq obj alist) (assoc obj alist eq?))
(define (assv obj alist) (assoc obj alist eqv?))
;; begin syntax
;; binary-port? primitive
(define (boolean=? boolean1 boolean2 . booleans)
(define (iter-true blns)
(cond ((null? blns) #t)
((car blns) (iter-true (cdr blns)))
(#t #f)))
(define (iter-false blns)
(cond ((null? blns) #t)
((not (car blns)) (iter-false (cdr blns)))
(#t #f)))
(cond ((and boolean1 boolean2) (iter-true booleans))
((and (not boolean1) (not boolean2)) (iter-false booleans))
(#t #f)))
;; boolean? primitive
;; bytevector
;; bytevector-append
;; bytevector-copy
;; bytevector-copy!
;; bytevector-length
;; bytevector-u8-ref
;; bytevector-u8-set!
;; bytevector?
(define (caar pair) (car (car pair)))
(define (cadr pair) (car (cdr pair)))
;; call-with-current-continuation
(define (call-with-port port proc)
((lambda (obj) (close-port port) obj)
(proc port)))
;; call-with-values
;; call/cc
;; car primitive
;; case
(define (cdar pair) (cdr (car pair)))
(define (cddr pair) (cdr (cdr pair)))
;; cdr primitive
;; ceiling primitive
;; char->integer primitive
;; char-ready?
(define (char<=? char1 char2 . chars)
(define (iter char chars)
(cond ((null? chars) #t)
((<= (char->integer char) (char->integer (car chars)))
(iter (car chars) (cdr chars)))
(#t #f)))
(iter char1 (cons char2 chars)))
(define (char<? char1 char2 . chars)
(define (iter char chars)
(cond ((null? chars) #t)
((< (char->integer char) (char->integer (car chars)))
(iter (car chars) (cdr chars)))
(#t #f)))
(iter char1 (cons char2 chars)))
(define (char=? char1 char2 . chars)
(define (iter char chars)
(cond ((null? chars) #t)
((= (char->integer char) (char->integer (car chars)))
(iter (car chars) (cdr chars)))
(#t #f)))
(iter char1 (cons char2 chars)))
(define (char>=? char1 char2 . chars)
(define (iter char chars)
(cond ((null? chars) #t)
((>= (char->integer char) (char->integer (car chars)))
(iter (car chars) (cdr chars)))
(#t #f)))
(iter char1 (cons char2 chars)))
(define (char>? char1 char2 . chars)
(define (iter char chars)
(cond ((null? chars) #t)
((> (char->integer char) (char->integer (car chars)))
(iter (car chars) (cdr chars)))
(#t #f)))
(iter char1 (cons char2 chars)))
;; char? primitive
(define (close-input-port port) (close-port port))
(define (close-output-port port) (close-port port))
;; close-port primitive
(define complex? number?)
;; cond syntax
;; cond-expand
;; cons primitive
;; current-error-port primitive
;; current-input-port primitive
;; define syntax
;; define-record-type
;; define-syntax
;; define-values
(define (denominator q) (numerator (/ q)))
;; do
;; dynamic-wind
;; else
;; eof-object primitive
;; eof-object? primitive
;; eq? primitive
(define (equal? obj1 obj2)
(cond ((and (pair? obj1) (pair? obj1))
(if (equal? (car obj1) (car obj2))
(equal? (cdr obj1) (cdr obj2))
#f))
((and (vector? obj1) (vector? obj2))
(equal? (vector->list obj1) (vector->list obj2)))
((and (string? obj1) (string? obj2))
(equal? (string->list obj1) (string->list obj2)))
((and (bytevector? obj1) (bytevector? obj2))
(equal? (utf8->string obj1) (uf8->string obj2)))
((or (and (boolean? obj1) (boolean? obj2))
(and (symbol? obj1) (symbol? obj2))
(and (number? obj1) (number? obj2))
(and (char? obj1) (char? obj2))
(and (port? obj1) (port? obj2))
(and (null? obj1) (null? obj2)))
(eqv? obj1 obj2))
(#t #f)))
;; eqv? primitive
;; error primitive
;; error-object-irritants primitive
;; error-object-message primitive
;; error-object? primitive
(define (even? n) (not (odd? n)))
;; exact primitive
;; exact-integer-sqrt
(define (exact-integer? z) (and (exact? z) (integer? z)))
;; exact? primitive
(define (expt z1 z2)
(if (and (exact-integer? z2))
(if (>= z2 0)
((lambda ()
(define (iter k result)
(if (= k 0)
result
(iter (- k 1) (* z1 result))))
(iter z2 1)))
((lambda ()
(define (iter k result)
(if (= k 0)
result
(iter (+ k 1) (* (/ 1 z1) result)))))))
(exp (* z2 (log z1)))))
;; features
;; file-error? primitive
;; floor primitive
(define (floor-quotient n1 n2) (floor (/ n1 n2)))
(define (floor-remainder n1 n2) (- n1 (* n2 (floor-quotient n1 n2))))
;; floor/
;; flush-output-port primitive
(define (for-each proc list)
(if (not (null? list))
((lambda ()
(proc (car list))
(for-each proc (cdr list))))))
(define (gcd . ns)
(define (inner m n)
(if (= n 0)
m
(inner n (floor-remainder m n))))
(define (iter n ns)
(if (null? ns)
n
(iter (inner (abs n)
(abs (car ns)))
(cdr ns))))
(iter 0 ns))
;; get-output-bytevector
;; get-output-string
;; guard
;; if syntax
;; include
;; include-ci
(define (inexact z) (* 1.0 z))
;; input-port-open? primitive
;; input-port? primitive
;; integer->char primitive
(define (integer? obj) (and (number? obj) (= obj (round obj))))
;; lambda syntax
(define (lcm . ns)
(define (inner m n) (/ (* m n) (gcd m n)))
(define (iter n ns)
(if (null? ns)
n
(iter (inner (abs n) (abs (car ns)))
(cdr ns))))
(iter 1 ns))
(define (length list)
(define (iter list n)
(if (null? list)
n
(iter (cdr list) (+ n 1))))
(iter list 0))
;; let
;; let*
;; let*-values
;; let-syntax
;; let-values
;; let-rec
;; letrec*
;; letrec->syntax
(define (list . objs) objs)
;; list->string primitive
;; list->vector primitive
(define (list-copy obj)
(if (pair? obj)
(cons (car obj) (list-copy (cdr obj)))
obj))
(define (list-ref list k)
(if (= k 0)
(car list)
(list-ref (cdr list) (- k 1))))
(define (list-set! list k obj)
(if (= k 0)
(set-car! list obj)
(list-set! (cdr list) (- k 1) obj)))
(define (list-tail list k)
(if (= k 0)
list
(list-tail (cdr list) (- k 1))))
(define (list? obj)
(cond ((null? obj) #t)
((pair? obj) (list? (cdr obj)))
(#t #f)))
;; make-bytevector
(define (make-list k . fill)
(define f (if (null? fill) '() (car fill)))
(define (iter k result)
(if (= k 0)
result
(iter (- k 1) (cons f result))))
(iter k '()))
;; make-parameter
(define (make-string k . char)
(define c (if (null? char) #\k (car char)))
(list->string (make-list k c)))
(define (make-vector k . fill)
(list->vector (make-list k fill)))
(define (map proc list)
(if (null? list)
'()
(cons (proc (car list))
(map proc (cdr list)))))
(define (max x . xs)
(define (iter x xs)
(if (> x (car xs))
(iter (car xs) (cdr xs))
#f))
(iter x xs))
(define (member obj list . compare)
(define cmp (if (null? compare) equal? (car compare)))
(define (iter list)
(cond ((null? list) #f)
((cmp (car list) obj) list)
(#t (iter (cdr list)))))
(iter list))
(define (memq obj list) (member obj list eq?))
(define (memv obj list) (member obj list eqv?))
(define (min x . xs)
(define (iter x xs)
(if (< x (car xs))
(iter (car xs) (cdr xs))
#f))
(iter x xs))
;; modulo
(define (negative? x) (< x 0))
(define (newline . port)
(if (null? port)
(display #\newline)
(display #\newline (car port))))
(define (not obj) (if obj #f #t))
(define (null? obj) (eq? obj '()))
;; number->string primitive
;; number? primitive
;; numerator primitive
(define (odd? n) (= (floor-remainder n 2) 1))
;; open-input-bytevector
;; open-input-string
;; open-output-bytevector
;; open-output-string
;; or syntax
;; output-port-open? primitive
;; output-port? primitive
;; pair? primitive
;; parameterize
;; peek-char primitive
;; peek-u8
(define (port? obj)
(or (input-port? obj)
(output-port? obj)
(textual-port? obj)
(binary-port? obj)))
(define (positive? x) (< 0 x))
;; procedure? primitive
;; quasiquote
;; quote syntax
;; quotient
;; raise primitive
;; raise-continuable
(define (rational? obj)
(and (real? obj)
(or (exact? obj)
(= obj (exact obj)))))
(define (rationalize x y)
(define diff (abs y))
(define low (- x diff))
(define high (+ x diff))
(define proc (if (and (exact? x) (exact? y)) exact inexact))
(if (<= (* low high) 0)
(proc 0)
(if (= low high)
(proc low)
((lambda ()
(define sign (if (positive? x) 1 -1))
(define low0 (if (positive? sign) low (abs high)))
(define high0 (if (positive? sign) high (abs low)))
(define (between? x) (and (<= low0 x) (<= x high0)))
(define (stern-brocot-tree pnum pden qnum qden)
(define a (/ (+ pnum qnum)
(+ pden qden)))
(if (between? a)
a
((lambda ()
(define num (numerator a))
(define den (denominator a))
(if (< high0 a)
(stern-brocot-tree pnum pden
num den)
(stern-brocot-tree num den
qnum qden))))))
(proc (* sign (stern-brocot-tree 0 1 1 0))))))))
;; read-bytevector
;; read-bytevector!
;; read-char primitive
;; read-error? primitive
(define (read-line . port)
(define p (if (null? port) (current-input-port) (car port)))
(define (iter result)
((lambda (c)
(if (or (eqv? c #\newline)
(eqv? c #\return)
(eof-object? c))
(list->string (reverse result))
(iter (cons c result))))
(read-char p)))
(iter '()))
(define (read-string k . port)
(define p (if (null? port) (current-input-port) (car port)))
(define (iter i result)
(if (= i k)
(list->string (reverse result))
(begin
(define c (read-char p))
(if (eof-object? c)
(if (null? result)
(eof-object)
(list->string (reverse result)))
(iter (+ i 1) (cons c result))))))
(iter 0 '()))
;; read-u8
(define (real? obj) (and (number? obj) (zero? (imag-part obj))))
;; remainder
(define (reverse list)
(define (iter list result)
(if (null? list)
result
(iter (cdr list) (cons (car list) result))))
(iter list '()))
;; round primitive
;; set! syntax
;; set-car! primitive
;; set-cdr! primitive
(define (square z) (* z z))
(define (string . chars)
(define (iter chars result)
(if (null? chars)
(list->string (reverse result))
(iter (cdr chars) (cons (car chars) result))))
(iter chars '()))
;; string->list primitive
;; (define (string->number
;; string->symbol primitive
;; string->utf8
(define (string->vector string . args)
(define start (if (null? args) 0 (car args)))
(define end (if (or (null? args) (null? (cdr args)))
(string-length string)
(cadr args)))
(list->vector (string->list (string-copy string start end))))
(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 (string-copy string . args)
(define start (if (null? args) 0 (car args)))
(define end (if (or (null? args)
(null? (cdr args)))
(string-length string)
(cadr args)))
(define len (- end start))
(define list-of-char (list-tail (string->list string) start))
(define (iter k list result)
(if (= k 0)
(reverse result)
(iter (- k 1) (cdr list) (cons (car list) result))))
(list->string (iter len list-of-char '())))
(define (string-copy! to at from . args)
(define start (if (null? args) 0 (car args)))
(define end (if (or (null? args) (null? (cdr args)))
(string-length from)
(cadr args)))
(define (iter i j)
(if (< j end)
((lambda ()
(string-set! to i (string-ref from j))
(iter (+ i 1) (+ j 1))))))
(iter at start))
(define (string-fill! string fill . args)
(define start (if (null? args) 0 (car args)))
(define end (if (or (null? args) (null? (cdr args)))
(string-length string)
(cadr args)))
(define (iter i)
(if (< i end)
((lambda ()
(string-set! string i fill)
(iter (+ i 1))))))
(iter start))
(define (string-for-each proc string)
(for-each (lambda (c) (proc c))
(string->list string)))
(define (string-length string) (length (string->list string)))
(define (string-map proc string)
(list->string (map proc (string->list string))))
(define (string-ref string k) (list-ref (string->list string) k))
;; string-set! primitive
(define (string<=? string1 string2 . strings)
(define (iter string strings)
(cond ((null? strings) #t)
((or (string<? string (car strings))
(string=? string (car strings)))
(iter (car string) (cdr strings)))
(#t #f)))
(iter string1 (cons string2 strings)))
(define (string<? string1 string2 . srrings)
(define (cmp string1 string2)
(define (iter list1 list2)
(cond ((null? list1) #t)
((null? list2) #f)
((char<? (car list1) (car list2))
(iter (cdr list1) (cdr list2)))
(#t #f)))
(iter string1 string2))
(define (iter string strings)
(cond ((null? strings) #t)
((cmp string (car strings))
(iter (car strings) (cdr strings)))
(#t #f)))
(iter string1 (cons string2 strings)))
(define (string=? string1 string2 . strings)
(define (cmp string1 string2)
(define (iter list1 list2)
(cond ((null? list1) #t)
((null? list2) #f)
((char=? (car list1) (car list2))
(iter (cdr list1) (cdr list2)))
(#t #f)))
(iter string1 string2))
(define (iter string strings)
(cond ((null? strings) #t)
((cmp string (car strings))
(iter (car strings) (cdr strings)))
(#t #f)))
(iter string1 (cons string2 strings)))
(define (string>=? string1 string2 . strings)
(define (iter string strings)
(cond ((null? strings) #t)
((or (string>? string (car strings))
(string=? string (car strings)))
(iter (car string) (cdr strings)))
(#t #f)))
(iter string1 (cons string2 strings)))
(define (string>=? string1 string2 . strings)
(define (iter string strings)
(cond ((null? strings) #t)
((string<=? (car strings) string))
(iter (car string) (cdr strings)))
(#t #f))
(iter string1 (cons string2 strings)))
(define (string>=? string1 string2 . strings)
(define (iter string strings)
(cond ((null? strings) #t)
((string<? (car strings) string))
(iter (car string) (cdr strings)))
(#t #f))
(iter string1 (cons string2 strings)))
;; string? primitive
;; substring
;; symbol->string primitive
(define (symbol=? symbol1 symbol2 . symbols)
(define (iter symbol symbols)
(cond ((null? symbols) #t)
((eq? symbol (car symbols))
(iter (car symbols) (cdr symbols)))
(#t #f)))
(iter symbol1 (cons symbol2 symbols)))
;; symbol? primitive
;; syntax-error
;; syntax-rules
;; textual-port? primitive
;; truncate primitive
(define (truncate-quotient n1 n2) (truncate (/ n1 n2)))
(define (truncate-remainder n1 n2) (- n1 (* n2 (truncate (/ n1 n2)))))
;; truncate/
;; u8-ready?
;; unless
;; unquote
;; unquote-splicing
;; utf8->string
;; values
(define (vector . objs) (list->vector objs))
;; vector->list primitive
(define (vector->string vector . args)
(define start (if (null? args) 0 (car args)))
(define end (if (or (null? args) (null? (cdr args)))
(vector-length vector)
(cadr args)))
(list->string (vector->list vector start end)))
(define (vector-append . vectors)
(list->vector (apply append (map (lambda (vector) (vector->list vector))
vectors))))
(define (vector-copy vector . args)
(define start (if (null? args) 0 (car args)))
(define end (if (or (null? args) (null? (cdr args)))
(vector-length vector)
(cadr args)))
(define vec (make-vector (- end start)))
(define (iter i j)
(if (= j end)
vec
(begin
(vector-set! vec i (vector-ref vector j))
(iter (+ i 1) (+ j 1)))))
(iter 0 start))
(define (vector-copy! to at from . args)
(define start (if (null? args) 0 (car args)))
(define end (if (or (null? args) (null? (cdr args)))
(vector-length from)
(cadr args)))
(define (iter i j)
(if (< j end)
(begin
(vector-set! to i (vector-ref from j))
(iter (+ i 1) (+ j 1)))))
(iter at start))
(define (vector-fill! vector fill . args)
(define start (if (null? args) 0 (car args)))
(define end (if (or (null? args) (null? (cdr args)))
(vector-length vector)
(cadr args)))
(define (iter i)
(if (< i end)
((lambda ()
(vector-set! vector i fill)
(iter (+ i 1))))))
(iter start))
(define (vector-for-each proc vector)
(for-each proc (vector->list)))
;; vector-length primitive
(define (vector-map proc vector)
(list->vector (map proc (vector->list vector))))
;; vector-ref primitive
;; vector-set! primitive
;; vector? primitive
;; when
;; with-exception-handler
;; write-bytevector
(define (write-char char . port)
(define p (if (null? port) (current-output-port) (car port)))
(display char port))
(define (write-string string . args)
(define port (if (null? args)
(current-output-port)
(car args)))
(define start (if (or (null? args) (null? (cdr args)))
0
(cadr args)))
(define end (if (or (null? args) (null? (cdr args)) (null? (cddr args)))
(string-length string)
(caddr args)))
(display (string-copy string start end) port))
;; wirte-u8
(define (zero? z) (= z 0))
'base-library
)
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 IBPORT:
case OBPORT:
case IBPORT_CLOSED:
case OBPORT_CLOSED:
case OEOF:
case VEC:
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 = 53;
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_numref(p->q));
mpz_set_ui(mpq_denref(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: {
ObjPtr out = onew(COMPLEX);
mpc_init2(out->z, prec);
mpc_set_q_q(opc1, p->q, qzero, MPC_RNDNN);
mpc_arg(mpc_realref(out->z), opc1, MPC_RNDNN);
mpfr_set_ui(mpc_imagref(out->z), 0, MPFR_RNDN);
return out;
}
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;
}
/* vector */
ObjPtr vecnew(ObjPtr l, size_t len) {
ObjPtr o = onew(VEC);
o->v = GC_MALLOC(sizeof(Vect));
o->v->len = len;
ObjPtr p = l;
ObjPtr *v = GC_MALLOC(sizeof(ObjPtr) * len);
for (size_t i = 0; i < len; i++) {
v[i] = p->p->l;
p = p->p->r;
}
o->v->v = v;
return o;
}
ObjPtr clist_to_vector(ObjPtr p) { return vecnew(p, clength(p)); }
ObjPtr scm_vector_p(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("vector?", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
return p->t == VEC ? true_ptr : false_ptr;
}
ObjPtr scm_vector_length(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("vector-length", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
if (p->t == VEC) {
ObjPtr out = onew(RATIONAL);
mpq_init(out->q);
mpq_set_ui(out->q, p->v->len, 1);
return out;
}
return domain_err("vector-length", argl);
}
ObjPtr scm_list_to_vector(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("list->vector", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
if (clist_p(p)) {
return clist_to_vector(p);
}
return domain_err("list->vector", argl);
}
ObjPtr scm_vector_ref(ObjPtr argl) {
if (clength(argl) != 2) {
return num_err("vector-ref", 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;
}
if (p1->t == VEC && p2->t == RATIONAL &&
mpz_cmp_ui(mpq_denref(p2->q), 1) == 0 &&
mpz_cmp_ui(mpq_numref(p2->q), 0) >= 0) {
size_t i = mpz_get_ui(mpq_numref(p2->q));
if (i < p1->v->len) {
return p1->v->v[i];
}
}
return domain_err("vector-ref", argl);
}
ObjPtr scm_vector_set(ObjPtr argl) {
if (clength(argl) != 3) {
return num_err("vector-set!", argl);
}
ObjPtr p1 = argl->p->l;
ObjPtr p2 = argl->p->r->p->l;
ObjPtr p3 = argl->p->r->p->r->p->l;
if (err_p(p1)) {
return p1;
}
if (err_p(p2)) {
return p2;
}
if (err_p(p3)) {
return p3;
}
if (p1->t == VEC && p2->t == RATIONAL &&
mpz_cmp_ui(mpq_denref(p2->q), 1) == 0 &&
mpz_cmp_ui(mpq_numref(p2->q), 0) >= 0) {
size_t i = mpz_get_ui(mpq_numref(p2->q));
if (i < p1->v->len) {
return p1->v->v[i] = p3;
}
}
return domain_err("vector-set!", argl);
}
ObjPtr scm_vector_to_list(ObjPtr argl) {
size_t len = clength(argl);
if (len == 1) {
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
if (p->t != VEC) {
return domain_err("vector->list", argl);
}
size_t len = p->v->len;
ObjPtr *v = p->v->v;
ObjPtr out = empty_ptr;
for (size_t i = len; i > 0; i--) {
out = pnew(v[i - 1], out);
}
return out;
}
if (len == 2) {
}
if (len == 3) {
}
return num_err("vector->list", argl);
}
/* vector end */
/* 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;
}
ObjPtr fenew(ObjPtr m, ObjPtr o) {
ObjPtr p = cpnew(FERR, 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>", p->port->name);
break;
}
case OPORT: {
fprintf(port->port->fh, "#<output-port %s>", p->port->name);
break;
}
case IPORT_CLOSED: {
fprintf(port->port->fh, "#<input-port(closed) %s>", p->port->name);
break;
}
case OPORT_CLOSED: {
fprintf(port->port->fh, "#<output-port(closed) %s>", p->port->name);
break;
}
case IBPORT: {
fprintf(port->port->fh, "#<binary-input-port %s>", p->port->name);
break;
}
case OBPORT: {
fprintf(port->port->fh, "#<binary-output-port %s>", p->port->name);
break;
}
case IBPORT_CLOSED: {
fprintf(port->port->fh, "#<binary-input-port(closed) %s>", p->port->name);
break;
}
case OBPORT_CLOSED: {
fprintf(port->port->fh, "#<binary-output-port(closed) %s>", p->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;
case VEC: {
size_t len = p->v->len;
ObjPtr *v = p->v->v;
fprintf(port->port->fh, "#(");
if (len != 0) {
cdisplay(v[0], port);
for (size_t i = 1; i < len; i++) {
fprintf(port->port->fh, " ");
cwrite(v[i], 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 IBPORT:
case OBPORT:
case IBPORT_CLOSED:
case OBPORT_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;
case VEC: {
size_t len = p->v->len;
ObjPtr *v = p->v->v;
fprintf(port->port->fh, "#(");
if (len != 0) {
cdisplay(v[0], port);
for (size_t i = 1; i < len; i++) {
fprintf(port->port->fh, " ");
cdisplay(v[i], port);
}
}
fprintf(port->port->fh, ")");
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_binary_port_p(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("binary-port?", argl);
}
switch (argl->p->l->t) {
case IBPORT:
case OBPORT:
case IBPORT_CLOSED:
case OBPORT_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(p->port->fh);
return cnewuc(c);
}
return domain_err("read-char", argl);
}
return num_err("read-char", argl);
}
ObjPtr scm_peek_char(ObjPtr argl) {
size_t len = clength(argl);
if (len == 0) {
gunichar c = getuc(cur_iport->port->fh);
if (c == EOF) {
return eof_ptr;
}
char outbuf[6];
gint len = g_unichar_to_utf8(c, outbuf);
for (size_t i = len; i > 0; i--) {
ungetc(outbuf[i - 1], cur_iport->port->fh);
}
return cnewuc(c);
}
if (len == 1) {
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
if (p->t == IPORT) {
gunichar c = getuc(p->port->fh);
if (c == EOF) {
return eof_ptr;
}
char outbuf[6];
gint len = g_unichar_to_utf8(c, outbuf);
for (gint i = len; i > 0; i--) {
ungetc(outbuf[i - 1], p->port->fh);
}
return cnewuc(c);
}
return domain_err("peek-char", argl);
}
return num_err("peek-char", argl);
}
#include <errno.h>
#include <string.h>
ObjPtr scm_open_binary_input_file(ObjPtr argl) {
size_t len = clength(argl);
if (len != 1) {
return num_err("open-binary-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-binary-input-file", argl);
}
char *filename = cscmstr_to_utf8(p);
FILE *fh = fopen(filename, "rb");
if (fh == NULL) {
return fenew(utf8_to_scmstr(strerror(errno)), p);
}
return portnew(IBPORT, filename, fh);
}
ObjPtr scm_open_binary_output_file(ObjPtr argl) {
size_t len = clength(argl);
if (len != 1) {
return num_err("open-binary-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-binary-input-file", argl);
}
char *filename = cscmstr_to_utf8(p);
FILE *fh = fopen(filename, "wb");
if (fh == NULL) {
return fenew(utf8_to_scmstr(strerror(errno)), p);
}
return portnew(OBPORT, filename, fh);
}
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) {
return fenew(utf8_to_scmstr(strerror(errno)), p);
}
return portnew(IPORT, filename, fh);
}
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) {
return fenew(utf8_to_scmstr(strerror(errno)), p);
}
return portnew(OPORT, filename, fh);
}
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_delete_file(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("delete-file", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
if (p->t != STR || p->t != STREMPTY) {
return domain_err("delete-file", argl);
}
char *s = cscmstr_to_utf8(p);
int n = remove(s);
if (n == 0) {
return undef_ptr;
}
ObjPtr out = utf8_to_scmstr(strerror(errno));
return fenew(out, p);
}
ObjPtr scm_file_exists_p(ObjPtr argl) {
if (clength(argl) != 1) {
return num_err("file-exists?", argl);
}
ObjPtr p = argl->p->l;
if (err_p(p)) {
return p;
}
if (p->t != STR || p->t != STREMPTY) {
return domain_err("file-exists?", argl);
}
char *s = cscmstr_to_utf8(p);
return g_file_test(s, G_FILE_TEST_EXISTS) ? true_ptr : false_ptr;
}
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},
{"binary-port?", scm_binary_port_p},
{"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},
{"list->vector", scm_list_to_vector},
{"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},
{"peek-char", scm_peek_char},
{"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},
{"vector->list", scm_vector_to_list},
{"vector-length", scm_vector_length},
{"vector-ref", scm_vector_ref},
{"vector-set!", scm_vector_set},
{"vector?", scm_vector_p},
/* 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},
/* file library */
{"delete-file", scm_delete_file},
{"file-exists?", scm_file_exists_p},
{"open-binary-input-file", scm_open_binary_input_file},
{"open-binary-output-file", scm_open_binary_output_file},
{"open-input-file", scm_open_input_file},
{"open-output-file", scm_open_output_file},
/* inexact library */
{"exp", scm_exp},
{"infinite?", scm_infinite_p},
{"log", scm_log},
{"nan?", scm_nan_p},
{"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 コメント:
コメントを投稿