more fixes

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

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?
+          odd?
-          ;; even?
+          even?
           min
           max
           +
@@ -232,19 +274,22 @@
           *
           /
           abs
-          ;; floor-quotient
+          floor-quotient
-          ;; floor-remainder
+          floor-remainder
           floor/
-          ;; truncate-quotient
+          truncate-quotient
-          ;; truncate-remainder
+          truncate-remainder
           truncate/
-          ;; gcd
+          (rename truncate-quotient quotient)
-          ;; lcm
+          (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)
+  (define (string->list string . opts)
-  ;;   (let ((start (if (pair? opts) (car opts) 0))
+    (let ((start (if (pair? opts) (car opts) 0))
-  ;;         (end (if (>= (length opts) 2)
+          (end (if (>= (length opts) 2)
-  ;;                  (cadr opts)
+                   (cadr opts)
-  ;;                  (string-length string))))
+                   (string-length string))))
-  ;;     (do ((i start (+ i 1))
+      (do ((i start (+ i 1))
-  ;;          (res '()))
+           (res '()))
-  ;;         ((= i end)
+          ((= i end)
-  ;;          (reverse res))
+           (reverse res))
-  ;;       (set! res (cons (string-ref string i) 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
+  (export ;string
-  ;;         string->list
+          string->list
-  ;;         list->string
+          ;list->string
-  ;;         (rename string-copy substring))
+          (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)
+  (define (string->vector . args)
-  ;;   (list->vector (apply string->list 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)
+  (define (string->utf8 s . opts)
-  ;;   (let ((start (if (pair? opts) (car opts) 0))
+    (let ((start (if (pair? opts) (car opts) 0))
-  ;;         (end (if (>= (length opts) 2)
+          (end (if (>= (length opts) 2)
-  ;;                  (cadr opts)
+                   (cadr opts)
-  ;;                  (string-length s))))
+                   (string-length s))))
-  ;;     (list->bytevector (map char->integer (string->list s start end)))))
+      (list->bytevector (map char->integer (string->list s start end)))))
 
-  ;; (export bytevector
+  (export bytevector
-  ;;         bytevector->list
+          bytevector->list
-  ;;         list->bytevector
+          list->bytevector
-  ;;         utf8->string
+          ;; utf8->string
-  ;;         string->utf8)
+          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)
+  (define (string-for-each f . strings)
-  ;;   (apply for-each f (map string->list strings)))
+    (apply for-each f (map string->list strings)))
 
-  ;; (define (vector-map f . vectors)
+  (define (vector-map f . vectors)
-  ;;   (list->vector (apply map f (map vector->list vectors))))
+    (list->vector (apply map f (map vector->list vectors))))
 
-  ;; (define (vector-for-each f . vectors)
+  (define (vector-for-each f . vectors)
-  ;;   (apply for-each f (map vector->list vectors)))
+    (apply for-each f (map vector->list vectors)))
 
-  ;; (export string-map string-for-each
+  (export ;string-map
-  ;;         vector-map vector-for-each)
+          string-for-each
+          vector-map
+          vector-for-each)
 
   (export procedure?
           apply

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))

piclib/scheme/load.scm

@@ -0,0 +1,4 @@
+(define-library (scheme load)
+  (import (picrin base))
+
+  (export load))

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))

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

piclib/scheme/time.scm

@@ -0,0 +1,6 @@
+(define-library (scheme time)
+  (import (picrin base))
+
+  (export current-jiffy
+          current-second
+          jiffies-per-second))

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))