mescc: trace M1 dumping.
[mes.git] / module / mes / M1.mes
index 14e1c48b8b7736990699b1f9aa5c9fae11bd1613..aa37be56b9711755b38ccac8c4d70e48efd7e508 100644 (file)
@@ -1,7 +1,7 @@
 ;;; -*-scheme-*-
 
 ;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2017,2018 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This file is part of Mes.
 ;;;
 (define (hex2:offset1 o)
   (string-append "!" o))
 
-(define hex? #f) ; We need unreleased messc-tools 0.2 wih 0xXX support for this
+(define hex? #t)
 
 (define (hex2:immediate o)
   (if hex? (string-append "%0x" (dec->hex o))
-      (format #f "%~a" o)))
+      (string-append "%" (number->string o))))
 
 (define (hex2:immediate1 o)
   (if hex? (string-append "!0x" (dec->hex o))
-      (format #f "!~a" o)))
+      (string-append "!" (number->string o))))
 
 (define (object->M1 o)
+  (stderr "dumping M1: object\n")
   (let* ((functions (assoc-ref o 'functions))
          (function-names (map car functions))
+         (file-name (car (or (assoc-ref o 'file-names) function-names)))
          (globals (assoc-ref o 'globals))
          (global-names (map car globals))
          (strings (filter (lambda (g) (and (pair? g) (eq? (car g) #:string))) global-names)))
     (define (string->label o)
       (let ((index (list-index (lambda (s) (equal? s o)) strings)))
-       (format #f "string_~a" index)))
+        (if index
+            (string-append "_string_" file-name "_" (number->string index))
+            "")))
     (define (text->M1 o)
-      (pmatch o
-        ;; FIXME
-        ((#:address (#:string ,string)) (hex2:address (string->label `(#:string ,string))))
-        ((#:string (#:address ,address)) (hex2:address address))
-        ((#:address (#:address ,address)) (hex2:address address))
-
-        ((#:string ,string) (hex2:address (string->label o)))
-        ((#:address ,address) (hex2:address address))
-        ((#:offset ,offset) (hex2:offset offset))
-        ((#:offset1 ,offset1) (hex2:offset1 offset1))
-        ((#:immediate ,immediate) (hex2:immediate immediate))
-        ((#:immediate1 ,immediate1) (hex2:immediate1 immediate1))
-        (_ (cond ((char? o) (text->M1 (char->integer o)))
-                 ((string? o) (format #f "~a" o))
-                 ((number? o) (let ((o (if (< o #x80) o (- o #x100))))
-                                (if hex? (string-append "!0x"
-                                                        (if (and (>= o 0) (< o 16)) "0" "")
-                                                        (number->string o 16))
-                                    (string-append "!" (number->string o)))))
-                 (else (format #f "~a" o))))))
+      (cond
+       ((char? o) (text->M1 (char->integer o)))
+       ((string? o) o)
+       ((symbol? o) (symbol->string o))
+       ((number? o) (let ((o (if (< o #x80) o (- o #x100))))
+                      (if hex? (string-append "!0x"
+                                              (if (and (>= o 0) (< o 16)) "0" "")
+                                              (number->string o 16))
+                          (string-append "!" (number->string o)))))
+       ((and (pair? o) (keyword? (car o)))
+        (pmatch o
+         ;; FIXME
+         ((#:address (#:string ,string)) (hex2:address (string->label `(#:string ,string))))
+         ((#:string (#:address ,address)) (hex2:address address))
+         ((#:address (#:address ,address)) (hex2:address address))
+         ((#:string ,string) (hex2:address (string->label o)))
+         ((#:address ,address) (hex2:address address))
+         ((#:offset ,offset) (hex2:offset offset))
+         ((#:offset1 ,offset1) (hex2:offset1 offset1))
+         ((#:immediate ,immediate) (hex2:immediate immediate))
+         ((#:immediate1 ,immediate1) (hex2:immediate1 immediate1))))
+       ((pair? o) (string-join (map text->M1 o)))))
     (define (write-function o)
       (let ((name (car o))
             (text (cdr o)))
         (define (line->M1 o)
           (cond ((eq? (car o) #:label)
-                 (format #t ":~a" (cadr o)))
+                 (core:display (string-append ":" (cadr o))))
                 ((eq? (car o) #:comment)
-                 (format #t "\t\t\t\t\t# ~a" (cadr o)))
+                 (core:display (string-append "\t\t\t\t\t# " (text->M1 (cadr o)))))
                 ((or (string? (car o)) (symbol? (car o)))
-                 (format #t "\t~a" (string-join (map text->M1 o) " ")))
+                 (core:display (string-append "\t" (string-join (map text->M1 o) " "))))
                 (else (error "line->M1 invalid line:" o)))
           (newline))
-        (format #t "\n\n:~a\n" name)
+        (core:display-error (string-append "    :" name "\n"))
+        (core:display (string-append "\n\n:" name "\n"))
         (for-each line->M1 (apply append text))))
     (define (write-global o)
       (define (labelize o)
             (let* ((label o)
                    (function? (member label function-names))
                    (string-label (string->label label))
-                   (string? (not (equal? string-label "string_#f")))
+                   (string? (not (equal? string-label "_string_#f")))
                    (global? (member label global-names)))
-              (if (or global? string?) (format #f "&~a" label)
+              (if (or global? string?) (string-append "&" label)
                   (begin (if (not function?) (stderr "warning: unresolved label: ~s\n" label))
-                         (format #f "&~a" label))))))
+                         (string-append "&" label))))))
       (let* ((label (if (not (and (pair? (car o)) (eq? (caar o) #:string))) (car o)
-                       (string->label (car o))))
+                        (string->label (car o))))
              (data (cdr o))
-             (data (filter-map labelize data)))
-        (format #t "\n:~a\n" label)
-        (cond ((and (char? (car data))
-                    ;; FIXME: 0 in M1 strings
-                    (not (find (cut eq? #\nul <>) (list-head data (1- (length data)))))
-                    ;; FIXME: " in M1 strings
-                    (not (find (cut member <> '(#\" #\' #\backspace)) data))
-                    (eq? (last data)= #\nul))
-               (format #t "\"~a\"" (list->string (list-head data (1- (length data))))))
-              (else (format #t "~a" (string-join (map text->M1 data) " "))))
+             (data (filter-map labelize data))
+             (len (length data))
+             (string-max (or (and=> (getenv "M1_STRING_MAX") string->number) 80)))
+        (if (not (eq? (car (string->list label)) #\_))
+            (core:display-error (string-append "    :" label "\n")))
+        (core:display (string-append "\n:" label "\n"))
+        (cond ((and (< len string-max)
+                    (char? (car data))
+                    (eq? (last data) #\nul)
+                    (not (find (cut memq <> '(#\nul #\backspace #\return #\" #\')) (list-head data (1- (length data)))))
+                    (not (any (lambda (ch) (>= (char->integer ch) #x80)) data)))
+               (core:display (string-append "\"" (list->string (list-head data (1- (length data)))) "\"")))
+              (else (core:display (string-join (map text->M1 data) " "))))
         (newline)))
-    (display "\n:HEX2_text")
+    (core:display-error "M1: functions\n")
     (for-each write-function (filter cdr functions))
-    (display "\n\n:ELF_data\n") ;; FIXME
-    (display "\n\n:HEX2_data\n")
+    (when (assoc-ref functions "main")
+      (core:display "\n\n:ELF_data\n") ;; FIXME
+      (core:display "\n\n:HEX2_data\n"))
+    (core:display-error "M1: globals\n")
     (for-each write-global globals)))