mescc: Output performance hacks: use core:display.

* src/lib.c (display_): Write to g_stdout (WAS: STDOUT).
* module/mes/guile.scm (guile): Declare and export core:display core:display-error.
* module/mes/M1.mes (object->M1): Use core:display and string-append
  instead of format.
* module/mes/guile.mes (with-input-from-string): Add debugging.
  (open-input-string): Likewise.
  (read-string): Likewise.  Re-implement.
  (drain-input): Use read-string.

module/mes/M1.mes

@@ -78,11 +78,11 @@
 
 (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)
   (let* ((functions (assoc-ref o 'functions))
@@ -93,41 +93,45 @@
          (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_~a" file-name index)))
+        (if index
+            (string-append "_string_" file-name "_" (number->string index))
+            "")))
     (define (text->M1 o)
-      (pmatch o
+      (cond
-        ;; FIXME
+       ((char? o) (text->M1 (char->integer o)))
-        ((#:address (#:string ,string)) (hex2:address (string->label `(#:string ,string))))
+       ((string? o) o)
-        ((#:string (#:address ,address)) (hex2:address address))
+       ((symbol? o) (symbol->string o))
-        ((#: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))))))
+       ((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 (string-append "\n\n:" name "\n"))
         (for-each line->M1 (apply append text))))
     (define (write-global o)
       (define (labelize o)
@@ -137,9 +141,9 @@
                    (string-label (string->label label))
                    (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))))
              (data (cdr o))

module/mes/guile.mes

@@ -28,7 +28,9 @@
 
 (define-macro (include-from-path file)
   (let loop ((path (cons %moduledir (string-split (or (getenv "GUILE_LOAD_PATH") "") #\:))))
-    (if (getenv "MES_DEBUG") (format (current-error-port) "include-from-path: ~s [PATH:~s]\n" file path))
+    (if (getenv "MES_DEBUG") 
+        ;;(format (current-error-port) "include-from-path: ~s [PATH:~s]\n" file path)
+        (core:display-error (string-append "include-from-path: " file " [PATH:" (string-join path ":") "]\n")))
     (if (null? path) (error "include-from-path: not found: " file)
         (let ((file (string-append (car path) "/" file)))
           (if (access? file R_OK) `(load ,file)
@@ -36,11 +38,16 @@
 
 (mes-use-module (srfi srfi-16))
 
-(define (drain-input port)
+(define (read-string)
-  (list->string
+  (define (read-string c)
-   (let loop ((c (read-char)))
     (if (eq? c #\*eof*) '()
-         (cons c (loop (read-char)))))))
+        (cons c (read-string (read-char)))))
+  (let ((string (list->string (read-string (read-char)))))
+    (if (getenv "MES_DEBUG")
+        (core:display-error (string-append "drained: `" string "'\n")))
+    string))
+
+(define (drain-input port) (read-string))
 
 (define (make-string n . fill)
   (list->string (apply make-list n fill)))
@@ -57,6 +64,8 @@
   (define save-peek-char peek-char)
   (define save-read-char read-char)
   (define save-unread-char unread-char)
+  (if (getenv "MES_DEBUG")
+      (core:display-error (string-append "with-input-from-string: `" string "'\n")))
   (let ((tell 0)
         (end (string-length string)))
     (set! peek-char
@@ -106,6 +115,8 @@
   (let ((save-set-current-input-port #f)
         (string-port #f))
     (lambda (string)
+      (if (getenv "MES_DEBUG")
+          (core:display-error (string-append "open-input-string: `" string "'\n")))
       (set! save-set-current-input-port set-current-input-port)
       (set! string-port (cons '*string-port* (gensym)))
       (set! set-current-input-port
@@ -136,9 +147,3 @@
                               (set! set-current-input-port save-set-current-input-port)
                               string-port)))))))
       string-port)))
-
-(define (read-string)
-  (define (read-string c p s)
-    (if (eq? c #\*eof*) s
-        (read-string (read-char) (peek-char) (cons c s))))
-  (list->string (reverse (read-string (read-char) (peek-char) (list)))))

module/mes/guile.scm

@@ -22,7 +22,14 @@
 
 ;;; Code:
 
-(define-module (mes guile))
+(define-module (mes guile)
+  #:export (core:display core:display-error))
+
+(cond-expand
+ (guile
+  (define core:display display)
+  (define (core:display-error o) (display o (current-error-port))))
+ (mes))
 
 (cond-expand
  (guile-2.2)

src/lib.c

@@ -108,7 +108,7 @@ SCM
 display_ (SCM x)
 {
   g_depth = 5;
-  return display_helper (x, 0, "", STDOUT);
+  return display_helper (x, 0, "", g_stdout);
 }
 
 SCM