Author: kzk
Date: Mon Aug 15 02:29:30 2005
New Revision: 1201
Modified:
branches/r5rs/scm/uim-db.scm
branches/r5rs/scm/util.scm
Log:
* first change to be compliance to R5RS
* scm/uim-db.scm
- (uim-db-puts): use number->string instead of integer->string
* scm/util.scm
- (boolean?, integer?, char?, list?, zero?,
positive?, negative?, number->string,
string->number, string->symbol,
map, for-each, quotient, list-tail,
char-upper-case?, char-lower-case?,
char-alphabetic?, char-numeric?,
char-downcase, char-upcase): removed because sscm has these proc
- (unfold, define-record): use list-ref instead of nth
- (bitwise-not, bitwise-and, bitwise-or, bitwise-xor): commented out
- (last-pair, nconc, symbolconc): new func
Modified: branches/r5rs/scm/uim-db.scm
==============================================================================
--- branches/r5rs/scm/uim-db.scm (original)
+++ branches/r5rs/scm/uim-db.scm Mon Aug 15 02:29:30 2005
@@ -324,7 +324,7 @@
(lambda (x)
(case (typeof x)
((tc_string tc_symbol) (puts x))
- ((tc_intnum) (puts (integer->string x)))
+ ((tc_intnum) (puts (number->string x)))
(else (print x))))
args)))
Modified: branches/r5rs/scm/util.scm
==============================================================================
--- branches/r5rs/scm/util.scm (original)
+++ branches/r5rs/scm/util.scm Mon Aug 15 02:29:30 2005
@@ -186,81 +186,6 @@
(min x ceiling))))
;;
-;; R5RS procedures (don't expect 100% compatibility)
-;;
-
-;; definition of 'else' has been moved into slib.c
-;(define else #t)
-
-(define boolean?
- (lambda (x)
- (or (eq? x #t)
- (eq? x #f))))
-
-(define integer?
- (lambda (x)
- (number? x)))
-
-;; Siod doesn't support char
-(define char?
- (lambda (x)
- #f))
-
-(define list?
- (lambda (x)
- (or (null? x)
- (and (pair? x)
- (list? (cdr x))))))
-
-(define zero?
- (lambda (x)
- (if (integer? x)
- (= x 0)
- (error "non-numeric value for zero?"))))
-
-(define positive?
- (lambda (x)
- (> x 0)))
-
-(define negative?
- (lambda (x)
- (< x 0)))
-
-(define number->string integer->string)
-(define string->number string->integer)
-(define string->symbol intern)
-
-(define map
- (lambda args
- (let ((f (car args))
- (lists (cdr args)))
- (if (<= (length lists) 3) ;; uim's siod accepts up to 3 lists
- (apply mapcar args) ;; faster native processing
- (iterate-lists (lambda (state elms)
- (if (null? elms)
- (cons #t (reverse state))
- (let ((mapped (apply f elms)))
- (cons #f (cons mapped state)))))
- () lists)))))
-
-(define for-each map)
-
-(define quotient /) ;; / in siod is quotient actually
-
-;;(define list-tail
-;; (lambda (lst n)
-;; (if (= n 0)
-;; lst
-;; (list-tail (cdr lst) (- n 1)))))
-(define list-tail
- (lambda (lst n)
- (if (or (< (length lst)
- n)
- (< n 0))
- (error "out of range in list-tail")
- (nthcdr n lst))))
-
-;;
;; R5RS-like character procedures
;;
@@ -270,29 +195,6 @@
(or (<= c 31)
(= c 127)))))
-(define char-upper-case?
- (lambda (c)
- (and (integer? c)
- (>= c 65)
- (<= c 90))))
-
-(define char-lower-case?
- (lambda (c)
- (and (integer? c)
- (>= c 97)
- (<= c 122))))
-
-(define char-alphabetic?
- (lambda (c)
- (or (char-upper-case? c)
- (char-lower-case? c))))
-
-(define char-numeric?
- (lambda (c)
- (and (integer? c)
- (>= c 48)
- (<= c 57))))
-
(define char-printable?
(lambda (c)
(and (integer? c)
@@ -325,18 +227,6 @@
(- c 48)
c)))
-(define char-downcase
- (lambda (c)
- (if (char-upper-case? c)
- (+ c 32)
- c)))
-
-(define char-upcase
- (lambda (c)
- (if (char-lower-case? c)
- (- c 32)
- c)))
-
;; backward compatibility
(define control-char? char-control?)
(define alphabet-char? char-alphabetic?)
@@ -385,6 +275,18 @@
(lambda (i)
(+ start i))))))
+(define last-pair
+ (lambda (lst)
+ (if (pair? (cdr lst))
+ (last-pair (cdr lst))
+ lst)))
+
+(define nconc
+ (lambda (lst obj)
+ (if (null? lst)
+ obj
+ (set-cdr! (last-pair lst) obj))))
+
;; TODO: write test
(define last
(lambda (lst)
@@ -477,13 +379,13 @@
(define unfold
(lambda args
- (let ((term? (nth 0 args))
- (kar (nth 1 args))
- (kdr (nth 2 args))
- (seed (nth 3 args))
+ (let ((term? (list-ref args 0))
+ (kar (list-ref args 1))
+ (kdr (list-ref args 2))
+ (seed (list-ref args 3))
(tail-gen (if (= (length args)
5)
- (nth 4 args)
+ (list-ref args 4)
(lambda (x) ()))))
(if (term? seed)
(tail-gen seed)
@@ -549,19 +451,16 @@
;; SRFI-60 procedures
;; Siod's bit operation procedures take only two arguments
;; TODO: write tests
-(define bitwise-not bit-not)
-
-(define bitwise-and
- (lambda xs
- (fold bit-and (bitwise-not 0) xs)))
-
-(define bitwise-or
- (lambda xs
- (fold bit-or 0 xs)))
-
-(define bitwise-xor
- (lambda xs
- (fold bit-xor 0 xs)))
+;(define bitwise-not bit-not)
+;(define bitwise-and
+; (lambda xs
+; (fold bit-and (bitwise-not 0) xs)))
+;(define bitwise-or
+; (lambda xs
+; (fold bit-or 0 xs)))
+;(define bitwise-xor
+; (lambda xs
+; (fold bit-xor 0 xs)))
;;
;; uim-specific utilities
@@ -585,6 +484,16 @@
(not (*catch 'errobj (begin (load file)
#f))))))
+(define (symbolconc . args)
+ (let* ((ret-sym "")
+ (append-to-ret (lambda (str)
+ (set! ret-sym
+ (string-append ret-sym str)))))
+ (for-each append-to-ret
+ (map symbol->string
+ args))
+ (string->symbol ret-sym)))
+
;; TODO: write test
;; returns succeeded or not
(define try-require
@@ -611,11 +520,11 @@
(define define-record
(lambda (rec-sym rec-spec)
(for-each (lambda (spec index)
- (let* ((elem-sym (nth 0 spec))
- (default (nth 1 spec))
+ (let* ((elem-sym (list-ref spec 0))
+ (default (list-ref spec 1))
(getter-sym (symbolconc rec-sym '- elem-sym))
(getter (lambda (rec)
- (nth index rec)))
+ (list-ref rec index)))
(setter-sym (symbolconc rec-sym '-set- elem-sym '!))
(setter (lambda (rec val)
(set-car! (nthcdr index rec)
