From 0ad4daa338452c9e2170235336ab3847f4944bf5 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 8 Sep 2014 20:37:44 +0900 Subject: [PATCH] more fixes --- piclib/CMakeLists.txt | 2 +- piclib/scheme/base.scm | 139 ++++++++++++++++++++---------- piclib/scheme/inexact.scm | 15 ++++ piclib/scheme/load.scm | 4 + piclib/scheme/process-context.scm | 8 ++ piclib/scheme/r5rs.scm | 10 +++ piclib/scheme/time.scm | 6 ++ piclib/srfi/17.scm | 2 +- 8 files changed, 139 insertions(+), 47 deletions(-) create mode 100644 piclib/scheme/inexact.scm create mode 100644 piclib/scheme/load.scm create mode 100644 piclib/scheme/process-context.scm create mode 100644 piclib/scheme/time.scm diff --git a/piclib/CMakeLists.txt b/piclib/CMakeLists.txt index 008e5ad5..25e77b3a 100644 --- a/piclib/CMakeLists.txt +++ b/piclib/CMakeLists.txt @@ -21,7 +21,7 @@ list(APPEND PICLIB_SCHEME_LIBS ${PROJECT_SOURCE_DIR}/piclib/scheme/load.scm ${PROJECT_SOURCE_DIR}/piclib/scheme/process-context.scm ${PROJECT_SOURCE_DIR}/piclib/scheme/time.scm - ${PROJECT_SOURCE_DIR}/piclib/scheme/r5rs.scm + # ${PROJECT_SOURCE_DIR}/piclib/scheme/r5rs.scm ${PROJECT_SOURCE_DIR}/piclib/scheme/null.scm ${PROJECT_SOURCE_DIR}/piclib/srfi/1.scm diff --git a/piclib/scheme/base.scm b/piclib/scheme/base.scm index 5303bf84..5c918d99 100644 --- a/piclib/scheme/base.scm +++ b/piclib/scheme/base.scm @@ -188,6 +188,12 @@ (define (negative? x) (< x 0)) + (define (even? x) + (= x (* (/ x 2) 2))) + + (define (odd? x) + (not (even? x))) + (define (min . args) (let loop ((args args) (min +inf.0)) (if (null? args) @@ -204,9 +210,43 @@ (car args) max))))) + (define (floor-quotient i j) + (call-with-values (lambda () (floor/ i j)) + (lambda (q r) + q))) + + (define (floor-remainder i j) + (call-with-values (lambda () (floor/ i j)) + (lambda (q r) + r))) + + (define (truncate-quotient i j) + (call-with-values (lambda () (truncate/ i j)) + (lambda (q r) + q))) + + (define (truncate-remainder i j) + (call-with-values (lambda () (truncate/ i j)) + (lambda (q r) + r))) + + (define (gcd i j) + (if (> i j) + (gcd j i) + (if (zero? i) + j + (gcd (truncate-remainder j i) i)))) + + (define (lcm i j) + (/ (* i j) (gcd i j))) + (define (square x) (* x x)) + (define (exact-integer-sqrt k) + (let ((s (exact (sqrt k)))) + (values s (- k (square s))))) + (export number? complex? real? @@ -215,6 +255,8 @@ exact? inexact? exact-integer? + exact + inexact = < > @@ -223,8 +265,8 @@ zero? positive? negative? - ;; odd? - ;; even? + odd? + even? min max + @@ -232,19 +274,22 @@ * / abs - ;; floor-quotient - ;; floor-remainder + floor-quotient + floor-remainder floor/ - ;; truncate-quotient - ;; truncate-remainder + truncate-quotient + truncate-remainder truncate/ - ;; gcd - ;; lcm + (rename truncate-quotient quotient) + (rename truncate-remainder remainder) + (rename floor-remainder modulo) + gcd + lcm floor ceiling truncate round - ;; exact-integer-sqrt + exact-integer-sqrt square expt number->string @@ -316,16 +361,16 @@ ;; 6.7. Strings - ;; (define (string->list string . opts) - ;; (let ((start (if (pair? opts) (car opts) 0)) - ;; (end (if (>= (length opts) 2) - ;; (cadr opts) - ;; (string-length string)))) - ;; (do ((i start (+ i 1)) - ;; (res '())) - ;; ((= i end) - ;; (reverse res)) - ;; (set! res (cons (string-ref string i) res))))) + (define (string->list string . opts) + (let ((start (if (pair? opts) (car opts) 0)) + (end (if (>= (length opts) 2) + (cadr opts) + (string-length string)))) + (do ((i start (+ i 1)) + (res '())) + ((= i end) + (reverse res)) + (set! res (cons (string-ref string i) res))))) ;; (define (list->string list) ;; (let ((len (length list))) @@ -339,10 +384,10 @@ ;; (define (string . objs) ;; (list->string objs)) - ;; (export string - ;; string->list - ;; list->string - ;; (rename string-copy substring)) + (export ;string + string->list + ;list->string + (rename string-copy substring)) (export string? string-length @@ -363,10 +408,12 @@ ;; (define (vector->string . args) ;; (list->string (apply vector->list args))) - ;; (define (string->vector . args) - ;; (list->vector (apply string->list args))) + (define (string->vector . args) + (list->vector (apply string->list args))) - ;; (export vector vector->string string->vector) + (export vector + ;vector->string + string->vector) (export vector? make-vector @@ -408,18 +455,18 @@ ;; (bytevector-length v)))) ;; (list->string (map integer->char (bytevector->list v start end))))) - ;; (define (string->utf8 s . opts) - ;; (let ((start (if (pair? opts) (car opts) 0)) - ;; (end (if (>= (length opts) 2) - ;; (cadr opts) - ;; (string-length s)))) - ;; (list->bytevector (map char->integer (string->list s start end))))) + (define (string->utf8 s . opts) + (let ((start (if (pair? opts) (car opts) 0)) + (end (if (>= (length opts) 2) + (cadr opts) + (string-length s)))) + (list->bytevector (map char->integer (string->list s start end))))) - ;; (export bytevector - ;; bytevector->list - ;; list->bytevector - ;; utf8->string - ;; string->utf8) + (export bytevector + bytevector->list + list->bytevector + ;; utf8->string + string->utf8) (export bytevector? make-bytevector @@ -434,17 +481,19 @@ ;; (define (string-map f . strings) ;; (list->string (apply map f (map string->list strings)))) - ;; (define (string-for-each f . strings) - ;; (apply for-each f (map string->list strings))) + (define (string-for-each f . strings) + (apply for-each f (map string->list strings))) - ;; (define (vector-map f . vectors) - ;; (list->vector (apply map f (map vector->list vectors)))) + (define (vector-map f . vectors) + (list->vector (apply map f (map vector->list vectors)))) - ;; (define (vector-for-each f . vectors) - ;; (apply for-each f (map vector->list vectors))) + (define (vector-for-each f . vectors) + (apply for-each f (map vector->list vectors))) - ;; (export string-map string-for-each - ;; vector-map vector-for-each) + (export ;string-map + string-for-each + vector-map + vector-for-each) (export procedure? apply diff --git a/piclib/scheme/inexact.scm b/piclib/scheme/inexact.scm new file mode 100644 index 00000000..28c162dc --- /dev/null +++ b/piclib/scheme/inexact.scm @@ -0,0 +1,15 @@ +(define-library (scheme inexact) + (import (picrin base)) + + (export acos + asin + atan + cos + exp + finite? + infinite? + log + nan? + sin + sqrt + tan)) diff --git a/piclib/scheme/load.scm b/piclib/scheme/load.scm new file mode 100644 index 00000000..5813a75d --- /dev/null +++ b/piclib/scheme/load.scm @@ -0,0 +1,4 @@ +(define-library (scheme load) + (import (picrin base)) + + (export load)) diff --git a/piclib/scheme/process-context.scm b/piclib/scheme/process-context.scm new file mode 100644 index 00000000..b19d9fb7 --- /dev/null +++ b/piclib/scheme/process-context.scm @@ -0,0 +1,8 @@ +(define-library (scheme process-context) + (import (picrin base)) + + (export command-line + emergency-exit + exit + get-environment-variable + get-environment-variables)) diff --git a/piclib/scheme/r5rs.scm b/piclib/scheme/r5rs.scm index e26a999d..f3b1c563 100644 --- a/piclib/scheme/r5rs.scm +++ b/piclib/scheme/r5rs.scm @@ -9,6 +9,16 @@ (scheme eval) (scheme load)) + (define (null-environment n) + (if (not (= n 5)) + (error "unsupported environment version" n) + '(scheme null))) + + (define (scheme-report-environment n) + (if (not (= n 5)) + (error "unsupported environment version" n) + '(scheme r5rs))) + (export * + - / < <= = > >= abs acos and ;; angle diff --git a/piclib/scheme/time.scm b/piclib/scheme/time.scm new file mode 100644 index 00000000..4df7f090 --- /dev/null +++ b/piclib/scheme/time.scm @@ -0,0 +1,6 @@ +(define-library (scheme time) + (import (picrin base)) + + (export current-jiffy + current-second + jiffies-per-second)) diff --git a/piclib/srfi/17.scm b/piclib/srfi/17.scm index eb02e66e..a6c5bd95 100644 --- a/piclib/srfi/17.scm +++ b/piclib/srfi/17.scm @@ -3,7 +3,7 @@ (import (except (scheme base) set!) (prefix (only (scheme base) set!) %) (picrin dictionary) - (picrin attribute) + (picrin base) (srfi 1) (srfi 8))