mescc: Tinycc support: Minimal float support.

* lib/libc+tcc.c (ldexp, strtod, strtof, strtold): New stub.
* include/math.h (ldexp): Declare.
* include/stdlib.h (strtod, strtof, strtold): Declare.
* module/mes/scm.mes (string->number): Minimal float support.
  (inexact->exact): New function.
* tests/math.test ("string->number"): Test it.
* module/language/c99/compiler.mes (ast->type): Handle float type.
  (type->info): Likewise.
  (cstring->int): Rename from cstring->number.  Update callers.
  (cstring->float): New function.
  (expr->accu): Use it.

diff --git a/include/math.h b/include/math.h
index ca9ae3a58d1b2f6e25788c3fed0cd98b8ece4a35..df0006c453318f0511d7092927bdcd0b7867e1b1 100644 (file)
--- a/include/math.h
+++ b/include/math.h
@@ -23,7 +23,9 @@
 #if __GNUC__ && POSIX
 #undef __MES_MATH_H
 #include_next <math.h>
-#endif // (__GNUC__ && POSIX)
+#else  // !(__GNUC__ && POSIX)
+double ldexp (double x, int exp);
+#endif  // !(__GNUC__ && POSIX)
 
 #endif // __MES_MATH_H
 

diff --git a/include/stdlib.h b/include/stdlib.h
index e529f0869f3bb25f62da31e142f2de376ce8f6e1..83686cc14f2d3465273fd6943fcd5f8901820988 100644 (file)
--- a/include/stdlib.h
+++ b/include/stdlib.h
@@ -43,6 +43,9 @@ int setenv (char const* s, char const* v, int overwrite_p);
 void *malloc (size_t);
 void qsort (void *base, size_t nmemb, size_t size, int (*compar)(void const *, void const *));
 void *realloc (void *p, size_t size);
+double strtod (char const *nptr, char **endptr);
+float strtof (char const *nptr, char **endptr);
+long double strtold (char const *nptr, char **endptr);
 long strtol (char const *nptr, char **endptr, int base);
 long long strtoll (char const *nptr, char **endptr, int base);
 unsigned long strtoul (char const *nptr, char **endptr, int base);

diff --git a/lib/libc+tcc.c b/lib/libc+tcc.c
index 1ce620789395ca55efc8e72aa0afa2dce165feb3..73824a9a8f23e47b569eed99c1035a8853099e54 100644 (file)
--- a/lib/libc+tcc.c
+++ b/lib/libc+tcc.c
@@ -127,6 +127,13 @@ gettimeofday (struct timeval *tv, struct timezone *tz)
   return 0;
 }
 
+double
+ldexp (double x, int exp)
+{
+  eputs ("ldexp stub\n");
+  return 0;
+}
+
 struct tm *
 localtime (time_t const *timep)
 {
@@ -285,6 +292,24 @@ strstr (char const *haystack, char const *needle)
   return 0;
 }
 
+double
+strtod (char const *nptr, char **endptr)
+{
+  eputs ("strtoul stub\n");
+}
+
+float
+strtof (char const *nptr, char **endptr)
+{
+  return strtod (nptr, endptr);
+}
+
+long double
+strtold (char const *nptr, char **endptr)
+{
+  return strtod (nptr, endptr);
+}
+
 long
 strtol (char const *nptr, char **endptr, int base)
 {

diff --git a/module/language/c99/compiler.mes b/module/language/c99/compiler.mes
index aea544b946813d087d0110976460243f47988685..c14df62e4c606b1963d295fbd9f44d2b0e115d30 100644 (file)
--- a/module/language/c99/compiler.mes
+++ b/module/language/c99/compiler.mes
@@ -189,6 +189,7 @@
       ((char ,value) (get-type "char" info))
       ((enum-ref . _) (get-type "int" info))
       ((fixed ,value) (get-type "int" info))
+      ((float ,float) (get-type "float" info))
       ((void) (get-type "void" info))
 
       ((ident ,name) (ident->type info name))
@@ -949,11 +950,15 @@
            (append-text info (list (i386:label->accu `(#:string ,string))))))
 
         ((p-expr (fixed ,value))
-         (let ((value (cstring->number value)))
+         (let ((value (cstring->int value)))
+           (append-text info (wrap-as (i386:value->accu value)))))
+
+        ((p-expr (float ,value))
+         (let ((value (cstring->float value)))
            (append-text info (wrap-as (i386:value->accu value)))))
 
         ((neg (p-expr (fixed ,value)))
-         (let ((value (- (cstring->number value))))
+         (let ((value (- (cstring->int value))))
            (append-text info (wrap-as (i386:value->accu value)))))
 
         ((p-expr (char ,char))
@@ -975,7 +980,7 @@
         ((ref-to (i-sel (ident ,field) (cast (type-name (decl-spec-list ,struct) (abs-declr (pointer))) (p-expr (fixed ,base)))))
          (let* ((type (ast->basic-type struct info))
                 (offset (field-offset info type field))
-                (base (cstring->number base)))
+                (base (cstring->int base)))
            (append-text info (wrap-as (i386:value->accu (+ base offset))))))
 
         ;; &foo
@@ -1124,7 +1129,7 @@
                             ((and struct? (= rank 2)) 4)
                             (else 1)))
                 (info (expr->accu a info))
-                (value (cstring->number value))
+                (value (cstring->int value))
                 (value (* size value)))
            (append-text info (wrap-as (i386:accu+value value)))))
 
@@ -1155,7 +1160,7 @@
                             ((and struct? (= rank 2)) 4)
                             (else 1)))
                 (info (expr->accu a info))
-                (value (cstring->number value))
+                (value (cstring->int value))
                 (value (* size value)))
            (append-text info (wrap-as (i386:accu+value (- value))))))
 
@@ -1439,20 +1444,25 @@
 
       (_ ((jump i386:jump-z (wrap-as (i386:accu-zero?))) o)))))
 
-(define (cstring->number s)
-  (let ((s (cond ((string-suffix? "ULL" s) (string-drop-right s 3))
-                 ((string-suffix? "UL" s) (string-drop-right s 2))
-                 ((string-suffix? "LL" s) (string-drop-right s 2))
-                 ((string-suffix? "L" s) (string-drop-right s 1))
-                 (else s))))
-    (cond ((string-prefix? "0x" s) (string->number (string-drop s 2) 16))
-          ((string-prefix? "0b" s) (string->number (string-drop s 2) 2))
-          ((string-prefix? "0" s) (string->number s 8))
-          (else (string->number s)))))
+(define (cstring->int o)
+  (let ((o (cond ((string-suffix? "ULL" o) (string-drop-right o 3))
+                 ((string-suffix? "UL" o) (string-drop-right o 2))
+                 ((string-suffix? "LL" o) (string-drop-right o 2))
+                 ((string-suffix? "L" o) (string-drop-right o 1))
+                 (else o))))
+    (or (cond ((string-prefix? "0x" o) (string->number (string-drop o 2) 16))
+              ((string-prefix? "0b" o) (string->number (string-drop o 2) 2))
+              ((string-prefix? "0" o) (string->number o 8))
+              (else (string->number o)))
+        (error "cstring->int: not supported:" o))))
+
+(define (cstring->float o)
+  (or (string->number o)
+      (error "cstring->float: not supported:" o)))
 
 (define (try-expr->number info o)
   (pmatch o
-    ((fixed ,a) (cstring->number a))
+    ((fixed ,a) (cstring->int a))
     ((p-expr ,expr) (expr->number info expr))
     ((neg ,a)
      (- (expr->number info a)))
@@ -1485,7 +1495,7 @@
     ((cast ,type ,expr) (expr->number info expr))
     ((cond-expr ,test ,then ,else)
      (if (p-expr->bool info test) (expr->number info then) (expr->number info else)))
-    (,string (guard (string? string)) (cstring->number string))
+    (,string (guard (string? string)) (cstring->int string))
     ((ident ,name) (assoc-ref (.constants info) name))
     (_  #f)))
 
@@ -1528,7 +1538,7 @@
                                  (let ((field (car o)))
                                    (pmatch field
                                      ((comp-declr (bit-field (ident ,name) (p-expr (fixed ,bits))))
-                                      (let ((bits (cstring->number bits)))
+                                      (let ((bits (cstring->int bits)))
                                         (cons (cons name (make-bit-field type bit bits))
                                               (loop (cdr o) (+ bit bits)))))
                                      (_ (error "struct-field: not supported:" field o))))))))))
@@ -1814,8 +1824,8 @@
                         (0 0)
                         ((p-expr (char ,value)) (char->integer (car (string->list value))))
                         ((p-expr (ident ,constant)) (assoc-ref (.constants info) constant))
-                        ((p-expr (fixed ,value)) (cstring->number value))
-                        ((neg (p-expr (fixed ,value))) (- (cstring->number value)))
+                        ((p-expr (fixed ,value)) (cstring->int value))
+                        ((neg (p-expr (fixed ,value))) (- (cstring->int value)))
                         (_ (error "case test: not supported: " test)))))
            (append (wrap-as (i386:accu-cmp-value value))
                    (jump-z body-label))))
@@ -2106,7 +2116,7 @@
      (list->string (map (lambda (i) (pmatch i
                                       ((initzer (p-expr (char ,c))) ((compose car string->list) c))
                                       ((initzer (p-expr (fixed ,fixed)))
-                                       (let ((value (cstring->number fixed)))
+                                       (let ((value (cstring->int fixed)))
                                          (if (and (>= value 0) (<= value 255))
                                              (integer->char value)
                                              (error "array-init->string: not supported:" i o))))
@@ -2208,7 +2218,7 @@
     ((ref-to (i-sel (ident ,field) (cast (type-name (decl-spec-list ,struct) (abs-declr (pointer))) (p-expr (fixed ,base)))))
      (let* ((type (ast->type struct info))
             (offset (field-offset info type field))
-            (base (cstring->number base)))
+            (base (cstring->int base)))
        (int->bv32 (+ base offset))))
     ((,char . _) (guard (char? char)) o)
     ((,number . _) (guard (number? number))
@@ -2286,6 +2296,7 @@
     ((typename ,name) info)
     ((union-ref . _) info)
     ((fixed-type . _) info)
+    ((float-type . _) info)
     ((void) info)
 
     (_ ;;(error "type->info: not supported:" o)

diff --git a/module/mes/scm.mes b/module/mes/scm.mes
index 9bd53581850a814a1770c78def6357137c1c44be..eba58c1674f2a9556e08bdd72517117f84b2338a 100644 (file)
--- a/module/mes/scm.mes
+++ b/module/mes/scm.mes
@@ -229,15 +229,31 @@
      (equal? (substring string (- length suffix-length)) suffix))))
 
 (define (string->number s . rest)
-  (let* ((radix (if (null? rest) 10 (car rest)))
-         (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)
-          (let ((i (char->integer (car lst))))
-            (loop (cdr lst) (+ (* n radix) (- i (if (<= i (char->integer #\9)) (char->integer #\0)
-                                                    (- (char->integer #\a) 10))))))))))
+  (let ((lst (string->list s)))
+    (and (pair? lst)
+         (let* ((radix (if (null? rest) 10 (car rest)))
+                (sign (if (and (pair? lst) (char=? (car lst) #\-)) -1 1))
+                (lst (if (= sign -1) (cdr lst) lst)))
+           (let loop ((lst lst) (n 0))
+             (if (null? lst) (* sign n)
+                 (let ((i (char->integer (car lst))))
+                   (cond ((and (>= i (char->integer #\0))
+                               (<= i (char->integer #\9)))
+                          (let ((d (char->integer #\0)))
+                            (loop (cdr lst) (+ (* n radix) (- i d)))))
+                         ((and (= radix 16)
+                               (>= i (char->integer #\a))
+                               (<= i (char->integer #\f)))
+                          (let ((d (char->integer #\a)))
+                            (loop (cdr lst) (+ (* n radix) (- i (- d 10))))))
+                         ((= i (char->integer #\.)) ; minimal FLOAT support
+                          (let ((fraction (cdr lst)))
+                            (if (null? fraction) n
+                                (let ((fraction ((compose string->number list->string) fraction)))
+                                  (and fraction n))))) ; FLOAT as integer
+                         (else #f)))))))))
+
+(define inexact->exact identity)
 
 (define (number->string n . rest)
   (let* ((radix (if (null? rest) 10 (car rest)))

diff --git a/tests/math.test b/tests/math.test
index 54e38dd7d673c639b95950ce2e36e276417396c7..2be1e4482ce7a327d3849d03858d1d2899eb7426 100755 (executable)
--- a/tests/math.test
+++ b/tests/math.test
@@ -8,7 +8,7 @@ exit $?
 ;;; -*-scheme-*-
 
 ;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2016,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This file is part of Mes.
 ;;;
@@ -25,9 +25,12 @@ exit $?
 ;;; You should have received a copy of the GNU General Public License
 ;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
 
-(mes-use-module (mes scm))
-(mes-use-module (srfi srfi-0))
 (mes-use-module (mes test))
+(pass-if-equal "string->number" 42 (string->number "42"))
+(pass-if-equal "string->number neg" -42 (string->number "-42"))
+(pass-if-not "string->number hex" (string->number "aa"))
+(pass-if-equal "string->number hex" 170 (string->number "aa" 16))
+(pass-if-equal "string->number float" 1 (inexact->exact (string->number "1.0")))
 
 (pass-if-equal "+" 6 (+ 1 2 3))
 (pass-if-equal "*" 27 (* 3 3 3))