mescc: Create less garbage when dumping M1.
authorJan Nieuwenhuizen <janneke@gnu.org>
Tue, 24 Apr 2018 05:26:27 +0000 (07:26 +0200)
committerJan Nieuwenhuizen <janneke@gnu.org>
Tue, 24 Apr 2018 05:26:27 +0000 (07:26 +0200)
* module/mes/M1.mes (display-join): New function.
* (object->M1): Use it.

module/mes/M1.mes

index 54091156b2c03d368cc6b644d63bcc61236c52b6..0f56ddefc3aa863e9566adce12700b19c011b865 100644 (file)
   (if hex? (string-append "!0x" (dec->hex o))
       (string-append "!" (number->string o))))
 
   (if hex? (string-append "!0x" (dec->hex o))
       (string-append "!" (number->string o))))
 
+(define* (display-join o #:optional (sep ""))
+  (let loop ((o o))
+    (when (pair? o)
+      (display (car o))
+      (if (pair? (cdr o))
+          (display sep))
+      (loop (cdr o)))))
+
 (define (object->M1 o)
   (stderr "dumping M1: object\n")
   (let* ((functions (assoc-ref o 'functions))
 (define (object->M1 o)
   (stderr "dumping M1: object\n")
   (let* ((functions (assoc-ref o 'functions))
           (cond ((eq? (car o) #:label)
                  (display (string-append ":" (cadr o))))
                 ((eq? (car o) #:comment)
           (cond ((eq? (car o) #:label)
                  (display (string-append ":" (cadr o))))
                 ((eq? (car o) #:comment)
-                 (display (string-append "\t\t\t\t\t# " (text->M1 (cadr o)))))
+                 (display "\t\t\t\t\t# ")
+                 (display (text->M1 (cadr o))))
                 ((or (string? (car o)) (symbol? (car o)))
                 ((or (string? (car o)) (symbol? (car o)))
-                 (display (string-append "\t" (string-join (map text->M1 o) " "))))
+                 (display "\t" )
+                 (display-join (map text->M1 o) " "))
                 (else (error "line->M1 invalid line:" o)))
           (newline))
         (display (string-append "    :" name "\n") (current-error-port))
                 (else (error "line->M1 invalid line:" o)))
           (newline))
         (display (string-append "    :" name "\n") (current-error-port))
                     (not (find (cut memq <> '(#\nul #\backspace #\return #\" #\')) (list-head data (1- (length data)))))
                     (not (any (lambda (ch) (>= (char->integer ch) #x80)) data)))
                (display (string-append "\"" (list->string (list-head data (1- (length data)))) "\"")))
                     (not (find (cut memq <> '(#\nul #\backspace #\return #\" #\')) (list-head data (1- (length data)))))
                     (not (any (lambda (ch) (>= (char->integer ch) #x80)) data)))
                (display (string-append "\"" (list->string (list-head data (1- (length data)))) "\"")))
-              (else (display (string-join (map text->M1 data) " "))))
+              (else (display-join (map text->M1 data) " ")))
         (newline)))
     (display "M1: functions\n" (current-error-port))
     (for-each write-function (filter cdr functions))
         (newline)))
     (display "M1: functions\n" (current-error-port))
     (for-each write-function (filter cdr functions))