From ef2a288ad13ee7a0c5725f9a4d4e8d42f0b6f557 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Wed, 20 Jul 2022 16:16:57 +0200
Subject: Actually implement parse-c-number.

---
 module/c/lex2.scm | 96 ++++++++++++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 95 insertions(+), 1 deletion(-)

(limited to 'module')

diff --git a/module/c/lex2.scm b/module/c/lex2.scm
index 85c9be19..af90dcce 100644
--- a/module/c/lex2.scm
+++ b/module/c/lex2.scm
@@ -4,6 +4,7 @@
   :use-module ((hnh util) :select (->))
   :use-module (hnh util object)
   :use-module (hnh util type)
+  :use-module ((srfi srfi-1) :select (fold))
   :use-module (srfi srfi-88)
   :use-module ((c trigraph) :select (replace-trigraphs))
   :use-module ((c line-fold) :select (fold-lines))
@@ -423,9 +424,102 @@
              (cdr (peg:tree result))))))
 
 
+
 
+
+;; (parse-decimals "555" 10)
+;; ⇒ 0.5549999999999999
+;; (parse-decimals "8" 16)
+;; ⇒ 0.5
+(define (parse-decimals str base)
+  (/ (fold (lambda (digit done)
+             (let ((v (string->number digit base)))
+               (+ v (/ done base))))
+           0.0
+           (map string (string->list str)))
+     base))
+
+;; parse a number on form <digits>.<digits>
+(define (parse-fractional str base)
+  (let* ((pair (string-split str #\.))
+         (integer (list-ref pair 0))
+         (decimals (list-ref pair 1)))
+    (+ (if (string-null? integer)
+           0 (string->number integer 16))
+       (if (string-null? decimals)
+           0 (parse-decimals decimals 16)))))
+
+
+(define (parse-float body)
+  (define (fractional-constant x)
+    (case x
+      ((decimal-floating-constant)                 'fractional-constant)
+      ((hexadecimal-floating-constant) 'hexadecimal-fractional-constant)))
+
+  (define (exponent-part x)
+    (case x
+      ((decimal-floating-constant)            'exponent-part)
+      ((hexadecimal-floating-constant) 'binary-exponent-part)))
+
+  (define (expt-base x)
+    (case x
+      ((decimal-floating-constant)     10)
+      ((hexadecimal-floating-constant)  2)))
+
+  (define (base x)
+    (case x
+      ((decimal-floating-constant)     10)
+      ((hexadecimal-floating-constant) 16)))
+
+  (let ((type (car body))
+        (body (cdr body)))
+    (* 1.0
+       (cond ((assoc-ref body (fractional-constant type))
+              => (lambda (fc) (parse-fractional (car fc) (base type))))
+             (else (string->number (car body) (base type))))
+       (cond ((assoc-ref body (exponent-part type))
+              => (lambda (x) (expt (expt-base type)
+                              (string->number (car x) (base type)))))
+             (else 1)))
+    ;; TODO do something with (possible) suffix
+    ;; (assoc-ref body 'floating-suffix)
+    ))
+
+(define (parse-integer body)
+  (let* (;; (suffix (assoc-ref body 'integer-suffix))
+         (value (cadr (car body)))
+         (value-type (car (car body))))
+    ;; TODO do something with suffix
+    (string->number
+     value
+     (case value-type
+       ((octal-constant)        8)
+       ((decimal-constant)     10)
+       ((hexadecimal-constant) 16)))))
+
+;; (parse-c-number "0x1.8p0")
+;; ⇒ 1.5
+
+;; TODO is "5ul" equivalent to "((unsigned long) 5)"
 (define (parse-c-number string)
-  (match-pattern constant string))
+  (cond ((match-pattern constant string)
+         => (lambda (m)
+              (let ((m (cadr (peg:tree m))))       ; Strip 'constant wrapper
+                (case (car m)
+                  ((floating-constant)
+                   (parse-float (cadr m)))
+
+                  ((integer-constant)
+                   (parse-integer (cdr m)))
+
+                  ((enumeration-constant character-constant)
+                   (scm-error 'misc-error "parse-c-number"
+                              "Couldn't parse [~a] as a /number/ (~s)"
+                              (list string m) #f))))))
+
+        (else (scm-error 'misc-error "parse-c-number"
+                         "Couldn't parse [~a] as a number"
+                         (list string) #f))))
 
 
 
-- 
cgit v1.2.3