artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

mescc: Output performance hacks: use core:display.

Browse source 
* 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.
This commit is contained in:
Jan Nieuwenhuizen 2017-12-09 20:10:57 +01:00
parent 572b45f4cd
commit ccddde9a84
4 changed files with 60 additions and 44 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

52
module/mes/M1.mes
View file

@ -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
;; 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))
(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)))))
(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))

27
module/mes/guile.mes
View file

@ -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)
(list->string
(let loop ((c (read-char)))
(define (read-string)
(define (read-string c)
(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)))))

9
module/mes/guile.scm
View file

@ -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)

2
src/lib.c
View file

@ -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