core: Remove last_pair, list_ref, string_ref.

* lib.c (last_pair, list_ref): Remove.
* string.c (string_ref): Remove.
* module/mes/type-0.mes (string->list): New function.
* module/mes/scm.mes (string-ref): New function.
This commit is contained in:
Jan Nieuwenhuizen 2016-12-23 20:09:57 +01:00
parent 20b7a7851a
commit e13587f57f
5 changed files with 161 additions and 180 deletions

30
lib.c
View file

@ -43,42 +43,12 @@ length (SCM x)
return MAKE_NUMBER (n);
}
SCM
last_pair (SCM x)
{
while (x != cell_nil && cdr (x) != cell_nil)
x = cdr (x);
return x;
}
SCM
list (SCM x) ///((arity . n))
{
return x;
}
SCM
list_ref (SCM x, SCM k)
{
assert (TYPE (x) == PAIR);
assert (TYPE (k) == NUMBER);
int n = VALUE (k);
while (n-- && CDR (x) != cell_nil) x = CDR (x);
return x != cell_nil ? car (x) : cell_undefined;
}
SCM
vector_to_list (SCM v)
{
SCM x = cell_nil;
for (int i = 0; i < LENGTH (v); i++) {
SCM e = VECTOR (v)+i;
if (TYPE (e) == REF) e = g_cells[e].ref;
x = append2 (x, cons (e, cell_nil));
}
return x;
}
SCM
builtin_exit (SCM x)
{

12
mes.c
View file

@ -807,6 +807,18 @@ list_to_vector (SCM x)
return v;
}
SCM
vector_to_list (SCM v)
{
SCM x = cell_nil;
for (int i = 0; i < LENGTH (v); i++) {
SCM e = VECTOR (v)+i;
if (TYPE (e) == REF) e = g_cells[e].ref;
x = append2 (x, cons (e, cell_nil));
}
return x;
}
FILE *g_stdin;
int
getchar ()

View file

@ -30,27 +30,6 @@
(define (cadddr x) (car (cdddr x)))
(define (list . rest) rest)
(define (list-head x n)
(if (= 0 n) '()
(cons (car x) (list-head (cdr x) (- n 1)))))
(define (list-tail x n)
(if (= 0 n) x
(list-tail (cdr x) (- n 1))))
(define (string-prefix? prefix string)
(and
(>= (string-length string) (string-length prefix))
(equal? (substring string 0 (string-length prefix)) prefix)))
(define (symbol-prefix? prefix symbol)
(string-prefix? (symbol->string prefix) (symbol->string symbol)))
(define (symbol-append . rest)
(string->symbol (apply string-append (map symbol->string rest))))
(define-macro (case val . args)
(if (null? args) #f
(let ((clause (car args)))
@ -77,28 +56,32 @@
,@body
(loop ,@(cddar init)))))
(define (for-each f l . r)
(if (pair? l) (if (null? r) (begin (f (car l)) (for-each f (cdr l)))
(if (null? (cdr r)) (begin (f (car l) (caar r)) (for-each f (cdr l) (cdar r)))))))
(define (error who . rest)
(display "error:" (current-error-port))
(display who (current-error-port))
(display ":" (current-error-port))
(display rest (current-error-port))
(newline (current-error-port))
(display "exiting...\n" (current-error-port))
(exit 1))
(define (syntax-error message . rest)
(display "syntax-error:" (current-error-port))
(display message (current-error-port))
(display ":" (current-error-port))
(display rest (current-error-port))
(newline (current-error-port)))
(define integer? number?)
(define (make-list n . x)
(let ((fill (if (pair? x) (car x) *unspecified*)))
(let loop ((n n))
(if (= 0 n) '()
(cons fill (loop (- n 1)))))))
(define (string->list s)
(let ((n (string-length s)))
(let loop ((i 0))
(if (= i n) '()
(cons (string-ref s i) (loop (+ i 1)))))))
(define (string->number s . radix)
(if (and (pair? radix) (not (= (car radix) 10))) '*STRING->NUMBER:RADIX-NOT-SUPPORTED
(let* ((lst (string->list s))
(sign (if (char=? (car lst) #\-) -1 1))
(lst (if (= sign -1) (cdr lst) lst)))
(let loop ((lst lst) (n 0))
(if (null? lst) (* sign n)
(loop (cdr lst) (+ (* n 10) (- (char->integer (car lst)) (char->integer #\0)))))))))
(define (eof-object? x)
(or (and (number? x) (= x -1))
(and (char? x) (eof-object? (char->integer x)))))
(define (peek-char)
(integer->char (peek-byte)))
@ -110,19 +93,6 @@
(unread-byte (char->integer c))
c)
(define (char<? a b) (< (char->integer a) (char->integer b)))
(define (char>? a b) (> (char->integer a) (char->integer b)))
(define (char<=? a b) (<= (char->integer a) (char->integer b)))
(define (char>=? a b) (>= (char->integer a) (char->integer b)))
;; Vector
(define (vector . rest) (list->vector rest))
(define c:make-vector make-vector)
(define (make-vector n . x)
(if (null? x) (c:make-vector n)
(list->vector (apply make-list (cons n x)))))
(define (assq-set! alist key val)
(let ((entry (assq key alist)))
(cond (entry (set-cdr! entry val)
@ -158,10 +128,124 @@
(if (equal? x (car lst)) lst
(member x (cdr lst)))))
(define (for-each f l . r)
(if (pair? l) (if (null? r) (begin (f (car l)) (for-each f (cdr l)))
(if (null? (cdr r)) (begin (f (car l) (caar r)) (for-each f (cdr l) (cdar r)))))))
;;; Lists
(define (list . rest) rest)
(define (make-list n . x)
(let ((fill (if (pair? x) (car x) *unspecified*)))
(let loop ((n n))
(if (= 0 n) '()
(cons fill (loop (- n 1)))))))
(define (list-ref lst k)
(let loop ((lst lst) (k k))
(if (= 0 k) (car lst)
(loop (cdr lst) (- k 1)))))
(define (list-head x n)
(if (= 0 n) '()
(cons (car x) (list-head (cdr x) (- n 1)))))
(define (list-tail x n)
(if (= 0 n) x
(list-tail (cdr x) (- n 1))))
(define (last-pair lst)
(let loop ((lst lst))
(if (or (null? lst) (null? (cdr lst))) lst
(loop (cdr lst)))))
(define (iota n)
(if (<= n 0) '()
(append2 (iota (- n 1)) (list (- n 1)))))
(define (reverse lst)
(if (null? lst) '()
(append (reverse (cdr lst)) (cons (car lst) '()))))
(define (filter pred lst)
(let loop ((lst lst))
(if (null? lst) '()
(if (pred (car lst))
(cons (car lst) (loop (cdr lst)))
(loop (cdr lst))))))
(define (delete x lst)
(filter (lambda (e) (not (equal? e x))) lst))
(define (delq x lst)
(filter (lambda (e) (not (eq? e x))) lst))
;; Vector
(define (vector . rest) (list->vector rest))
(define c:make-vector make-vector)
(define (make-vector n . x)
(if (null? x) (c:make-vector n)
(list->vector (apply make-list (cons n x)))))
(define (vector-copy x)
(list->vector (vector->list x)))
;;; Strings/srfi-13
(define (string-ref s k)
(list-ref (string->list s) k))
(define (string-prefix? prefix string)
(and
(>= (string-length string) (string-length prefix))
(equal? (substring string 0 (string-length prefix)) prefix)))
(define (string->number s . radix)
(if (and (pair? radix) (not (= (car radix) 10))) '*STRING->NUMBER:RADIX-NOT-SUPPORTED
(let* ((lst (string->list s))
(sign (if (char=? (car lst) #\-) -1 1))
(lst (if (= sign -1) (cdr lst) lst)))
(let loop ((lst lst) (n 0))
(if (null? lst) (* sign n)
(loop (cdr lst) (+ (* n 10) (- (char->integer (car lst)) (char->integer #\0)))))))))
;;; Symbols
(define (symbol-prefix? prefix symbol)
(string-prefix? (symbol->string prefix) (symbol->string symbol)))
(define (symbol-append . rest)
(string->symbol (apply string-append (map symbol->string rest))))
(define gensym
(let ((counter 0))
(lambda (. rest)
(let ((value (number->string counter)))
(set! counter (+ counter 1))
(string->symbol (string-append "g" value))))))
;;; Characters
(define (char=? x y)
(and (char? x) (char? y)
(eq? x y)))
(define (char<? a b) (< (char->integer a) (char->integer b)))
(define (char>? a b) (> (char->integer a) (char->integer b)))
(define (char<=? a b) (<= (char->integer a) (char->integer b)))
(define (char>=? a b) (>= (char->integer a) (char->integer b)))
(define (char-alphabetic? x)
(and (char? x)
(let ((i (char->integer x)))
(or (and (>= i (char->integer #\A)) (<= i (char->integer #\Z)))
(and (>= i (char->integer #\a)) (<= i (char->integer #\z)))))))
(define (char-numeric? x)
(and (char? x)
(let ((i (char->integer x)))
(and (>= i (char->integer #\0)) (<= i (char->integer #\9))))))
;;; Math
(define (<= . rest)
(or (apply < rest)
(apply = rest)))
@ -170,11 +254,6 @@
(or (apply > rest)
(apply = rest)))
;; (define (>= . rest)
;; (if (apply > rest) #t
;; (if (apply = rest) #t
;; #f)))
(define (remainder x y)
(- x (* (quotient x y) y)))
@ -218,82 +297,3 @@
(let ((y (car rest)))
(let ((z (if (< x y) x y)))
(apply min (cons z (cdr rest)))))))
(define gensym
(let ((counter 0))
(lambda (. rest)
(let ((value (number->string counter)))
(set! counter (+ counter 1))
(string->symbol (string-append "g" value))))))
(define else #t)
(define (error who . rest)
(display "error:" (current-error-port))
(display who (current-error-port))
(display ":" (current-error-port))
(display rest (current-error-port))
(newline (current-error-port))
(display "exiting...\n" (current-error-port))
(exit 1))
(define (syntax-error message . rest)
(display "syntax-error:" (current-error-port))
(display message (current-error-port))
(display ":" (current-error-port))
(display rest (current-error-port))
(newline (current-error-port)))
(define (list-ref lst k)
(let loop ((lst lst) (k k))
(if (= 0 k) (car lst)
(loop (cdr lst) (- k 1)))))
(define (iota n)
(if (<= n 0) '()
(append2 (iota (- n 1)) (list (- n 1)))))
;; srfi-1
(define (last-pair lst)
(let loop ((lst lst))
(if (or (null? lst) (null? (cdr lst))) lst
(loop (cdr lst)))))
(define (reverse lst)
(if (null? lst) '()
(append (reverse (cdr lst)) (cons (car lst) '()))))
(define (filter pred lst)
(let loop ((lst lst))
(if (null? lst) '()
(if (pred (car lst))
(cons (car lst) (loop (cdr lst)))
(loop (cdr lst))))))
(define (delete x lst)
(filter (lambda (e) (not (equal? e x))) lst))
(define (delq x lst)
(filter (lambda (e) (not (eq? e x))) lst))
(define (vector-copy x)
(list->vector (vector->list x)))
(define (eof-object? x)
(or (and (number? x) (= x -1))
(and (char? x) (eof-object? (char->integer x)))))
(define (char=? x y)
(and (char? x) (char? y)
(eq? x y)))
(define (char-alphabetic? x)
(and (char? x)
(let ((i (char->integer x)))
(or (and (>= i (char->integer #\A)) (<= i (char->integer #\Z)))
(and (>= i (char->integer #\a)) (<= i (char->integer #\z)))))))
(define (char-numeric? x)
(and (char? x)
(let ((i (char->integer x)))
(and (>= i (char->integer #\0)) (<= i (char->integer #\9))))))

View file

@ -20,6 +20,9 @@
;;; Commentary:
;;; Implement core functionality that depends on implementation
;;; specifics of Mes cell types.
;;; Code:
(define <cell:char> 0)
@ -108,3 +111,8 @@
(define (boolean? x)
(or (eq? x #f) (eq? x #t)))
;;; core: accessors
(define (string->list s)
(core:car s))

View file

@ -51,15 +51,6 @@ string_length (SCM x)
return MAKE_NUMBER (VALUE (length (STRING (x))));
}
SCM
string_ref (SCM x, SCM k)
{
assert (TYPE (x) == STRING);
assert (TYPE (k) == NUMBER);
VALUE (tmp_num) = VALUE (k);
return MAKE_CHAR (VALUE (list_ref (STRING (x), tmp_num)));
}
SCM
substring (SCM x) ///((arity . n))
{