skint/pre/ksf2c.ssc

;---------------------------------------------------------------------------------------------
; Skint k.sf precursor compiler (k.sf => k.c)
;---------------------------------------------------------------------------------------------

(import (only (skint hidden) 
  list2? list3? path-relative? path-directory path-strip-directory
  path-strip-extension file-resolve-relative-to-base-path %system))

(define (list4? x) (and (pair? x) (list3? (cdr x))))

(define *prelude* "
#include \"n.h\"
#include \"i.h\"

#define MODULE module_k
#define LOAD()

")

(define (convert iport oport ifbase ifname)
  (let loop ([l (read-line iport)] [in-header? #t])
    (cond [(eof-object? l)]
          [(and in-header? (string=? l "/* cx globals */"))
           (display "/* " oport) (display ifbase oport) 
           (display ".c -- generated via skint ksf2c.ssc " oport) 
           (display ifname oport) 
           (display " */" oport) (newline oport) 
           (display *prelude* oport)
           (display l oport) (newline oport)
           (loop (read-line iport) #f)]
          [in-header?
           (loop (read-line iport) #t)]
          [(string=? l "static size_t cxg_hsize = 0; ") ; sfc puts 1 trailing space!
           (display "size_t cxg_hsize = 0;" oport) (newline oport)
           (loop (read-line iport) #f)]
          [(string=? l "static int cxg_gccount = 0, cxg_bumpcount = 0;")
           (display "int cxg_gccount = 0, cxg_bumpcount = 0;" oport) (newline oport)
           (loop (read-line iport) #f)]
          [(string=? l "  /* fprintf(stderr, \"%d collections, %d reallocs\\n\", cxg_gccount, cxg_bumpcount); */")
           (loop (read-line iport) #f)]
          [else
           (display l oport) (newline oport)
           (loop (read-line iport) #f)])))

(define (process-file sfcpath ifpath . ?ofpath)
  (define cwd (current-directory))
  (define sfcp (file-resolve-relative-to-base-path sfcpath cwd))
  (define ifdir (path-directory ifpath))
  (define ifname (path-strip-directory ifpath))
  (define ifbase (path-strip-extension ifname))
  (define tfpath (string-append ifdir ifbase ".c"))
  (define sfccmd (format #f "~a -v ~a" sfcp ifname))
  (when (file-exists? tfpath) (error "itermediate file already exists" tfpath))
  (format #t "; running ~a~%" sfccmd)
  (parameterize ([current-directory ifdir])
    (define res (begin (format #t "; cd is '~a'~%" (current-directory)) (%system sfccmd)))
    (unless (eqv? res 0) (error "sfc failed!")))
  (unless (file-exists? tfpath) (error "itermediate file is not found" tfpath))
  (format #t "; converting intermediate file ~a~%" tfpath)
  (let ([iport (open-input-file tfpath)] 
        [oport (if (null? ?ofpath) (current-output-port) (open-output-file (car ?ofpath)))])
    (convert iport oport ifbase ifname)
    (close-input-port iport)
    (unless (null? ?ofpath) (close-output-port oport)))
  (format #t "; deleting intermediate file ~a~%" tfpath)
  (delete-file tfpath))

(define (main args)
  (cond [(list3? args) (process-file (cadr args) (caddr args))]
        [(list4? args) (process-file (cadr args) (caddr args) (cadddr args))]
        [else (error "usage: scint ksf2c.ssc SFCPATH INFILE [OUTFILE]" args)]))

; this is not a real #! script, so call main manually
(main (command-line))