From 46eca44fb43798cf1427c0d557cd88da3250ef42 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Fri, 21 Oct 2016 10:51:09 +0200 Subject: [PATCH] boot: vector support. * mes.c (make_vector): Change to scm interface. (temp_number): New global. (list_to_vector): Use it. * module/mes/scm.mes (c:make-vector): New function. * tests/scm.test: Remove vector tests. * tests/vector.test: New file. * GNUmakefile (TESTS): Add it. --- GNUmakefile | 1 + mes.c | 13 ++++++----- module/mes/scm.mes | 4 +++- tests/scm.test | 16 ++++--------- tests/vector.test | 56 ++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 72 insertions(+), 18 deletions(-) create mode 100755 tests/vector.test diff --git a/GNUmakefile b/GNUmakefile index e08f6841..6cd71811 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -64,6 +64,7 @@ TESTS:=\ tests/closure.test\ tests/quasiquote.test\ tests/let.test\ + tests/vector.test\ tests/scm.test\ tests/record.test\ tests/let-syntax.test\ diff --git a/mes.c b/mes.c index ca0bb435..f8567bf6 100644 --- a/mes.c +++ b/mes.c @@ -61,6 +61,8 @@ typedef struct scm_t { }; } scm; +scm temp_number = {NUMBER, .name="nul", .value=0}; + #define MES_C 1 #include "mes.h" @@ -734,12 +736,13 @@ make_symbol (char const *s) } scm * -make_vector (int n) +make_vector (scm *n) { scm *p = (scm*)malloc (sizeof (scm)); p->type = VECTOR; - p->length = n; - p->vector = (scm**)malloc (n * sizeof (scm*)); + p->length = n->value; + p->vector = (scm**)malloc (n->value * sizeof (scm*)); + for (int i=0; ivalue; i++) p->vector[i] = &scm_unspecified; return p; } @@ -948,8 +951,8 @@ list2str (scm *l) // char* scm* list_to_vector (scm *x) { - int n = length (x)->value; - scm *v = make_vector (n); + temp_number.value = length (x)->value; + scm *v = make_vector (&temp_number); scm **p = v->vector; while (x != &scm_nil) { diff --git a/module/mes/scm.mes b/module/mes/scm.mes index bf6cbc9a..042104fe 100644 --- a/module/mes/scm.mes +++ b/module/mes/scm.mes @@ -67,8 +67,10 @@ (cons (string-ref s i) (loop (+ i 1))))))) (define (vector . rest) (list->vector rest)) +(define c:make-vector make-vector) (define (make-vector n . x) - (list->vector (apply make-list (cons n x)))) + (if (null? x) (c:make-vector n) + (list->vector (apply make-list (cons n x))))) (define (acons key value alist) (cons (cons key value) alist)) diff --git a/tests/scm.test b/tests/scm.test index 79515720..351094a4 100755 --- a/tests/scm.test +++ b/tests/scm.test @@ -85,17 +85,8 @@ exit $? (pass-if "string " (sequal? (string #\a #\space #\s #\t #\r #\i #\n #\g) "a string")) (pass-if "length" (seq? (length '()) 0)) (pass-if "length 2" (seq? (length '(a b c)) 3)) -(pass-if "vector?" (vector? #(1 2 c))) -(pass-if "vector-length" (seq? (vector-length #(1)) 1)) -(pass-if "list->vector" (sequal? (list->vector '(a b c)) #(a b c))) -(pass-if "make-list" (sequal? (make-list 3 1) '(1 1 1))) -(pass-if "vector" (sequal? #(vector 0 1 2) #(vector 0 1 2))) -(when (not guile?) - (pass-if "make-vector" (sequal? (make-vector 3) #(*unspecified* *unspecified* *unspecified*)))) -(pass-if "make-vector 2" (sequal? (make-vector 3 0) #(0 0 0))) -(pass-if "vector-ref" (seq? (vector-ref #(0 1) 1) 1)) -(pass-if "vector-set" (equal? (let ((v #(0 1))) (vector-set! v 1 'q) v) #(0 q))) -(pass-if "vector-set 2" (not (equal? (let ((v #(0 1))) (vector-set! v 1 'q) v) #()))) +(pass-if "make-list" (seq? (make-list 0) '())) +(pass-if "make-list 1" (sequal? (make-list 1 0) '(0))) (pass-if "equal?" (sequal? #(1) #(1))) (pass-if "equal?" (not (equal? #() #(1)))) (pass-if "memq" (sequal? (memq 'a '(a b c)) '(a b c))) @@ -127,7 +118,8 @@ exit $? ;; (display ((lambda (x) x) (values 1 2 3))) ;; (newline))) -(pass-if "builtin?" (builtin? eval)) +(pass-if "builtin?" (builtin? car)) +(pass-if "builtin?" (not (builtin? not))) ;;(pass-if "builtin?" (builtin? cond)) (pass-if "procedure?" (procedure? builtin?)) (pass-if "procedure?" (procedure? procedure?)) diff --git a/tests/vector.test b/tests/vector.test new file mode 100755 index 00000000..c122223d --- /dev/null +++ b/tests/vector.test @@ -0,0 +1,56 @@ +#! /bin/sh +# -*-scheme-*- +echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/../scripts/mes "$@" +#paredit:|| +exit $? +!# + +;;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2016 Jan Nieuwenhuizen +;;; +;;; vector.test: This file is part of Mes. +;;; +;;; Mes is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Mes is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Mes. If not, see . + +(mes-use-module (mes base-0)) +(mes-use-module (mes base)) +(mes-use-module (mes quasiquote)) +(mes-use-module (mes let)) +(mes-use-module (srfi srfi-0)) +(mes-use-module (mes scm)) +(mes-use-module (mes test)) + +(when guile? + (use-modules (srfi srfi-1))) + +(pass-if "first dummy" #t) +(pass-if-not "second dummy" #f) + +(pass-if "vector" (sequal? #(vector 0 1 2) #(vector 0 1 2))) +(pass-if "vector?" (vector? #(1 2 c))) +(pass-if "vector-length" (seq? (vector-length #(1)) 1)) + +(when (not guile?) + (pass-if "c:make-vector" (sequal? (c:make-vector 3) #(*unspecified* *unspecified* *unspecified*))) + (pass-if "make-vector" (sequal? (make-vector 3) #(*unspecified* *unspecified* *unspecified*)))) + +(pass-if "make-vector 2" (sequal? (make-vector 3 1) #(1 1 1))) +(pass-if "vector-ref" (seq? (vector-ref #(0 1) 1) 1)) +(pass-if "vector-set" (equal? (let ((v #(0 1))) (vector-set! v 1 'q) v) #(0 q))) +(pass-if "vector-set 2" (not (equal? (let ((v #(0 1))) (vector-set! v 1 'q) v) #()))) +(pass-if "list->vector" (sequal? (list->vector '(a b c)) #(a b c))) + +(result 'report)