mirror of
https://github.com/false-schemers/skint.git
synced 2024-12-26 21:58:51 +01:00
68 lines
2.8 KiB
Text
68 lines
2.8 KiB
Text
|
;---------------------------------------------------------------------------------------------
|
||
|
|
; Skint k.sf precursor compiler (k.sf => k.c)
|
||
|
|
;---------------------------------------------------------------------------------------------
|
||
|
|
|
||
|
|
(import (only (skint hidden)
|
||
|
|
list2? list3?))
|
||
|
|
|
||
|
|
(define (list4? x) (and (pair? x) (list3? (cdr x))))
|
||
|
|
|
||
|
|
(define (path-strip-directory filename)
|
||
|
|
(let loop ([l (reverse (string->list filename))] [r '()])
|
||
|
|
(cond [(null? l) (list->string r)]
|
||
|
|
[(memv (car l) '(#\\ #\/ #\:)) (list->string r)]
|
||
|
|
[else (loop (cdr l) (cons (car l) r))])))
|
||
|
|
|
||
|
|
(define (path-strip-extension filename)
|
||
|
|
(let ([l (reverse (string->list filename))])
|
||
|
|
(let ([r (memv #\. l)])
|
||
|
|
(if r (list->string (reverse (cdr r))) filename))))
|
||
|
|
|
||
|
|
(define (module-name filename)
|
||
|
|
(path-strip-extension (path-strip-directory filename)))
|
||
|
|
|
||
|
|
(define *local-definitions*
|
||
|
|
'("#ifdef NAN_BOXING" "#ifndef FLONUMS_BOXED" "#else" "#endif"))
|
||
|
|
|
||
|
|
(define (process-top-form x oport)
|
||
|
|
(when (and (list2? x) (symbol? (car x)) (string? (cadr x)))
|
||
|
|
(case (car x)
|
||
|
|
[(%definition)
|
||
|
|
; make an exception for some conditional definitions!
|
||
|
|
(when (member (cadr x) *local-definitions*)
|
||
|
|
(display (cadr x) oport) (newline oport) (newline oport))]
|
||
|
|
[(%localdef) (display (cadr x) oport) (newline oport) (newline oport)] ; does not go into n.h
|
||
|
|
[(%include)]))) ; went into n.h
|
||
|
|
|
||
|
|
(define (process-file sfcpath ifname . ?ofname)
|
||
|
|
(define iport (open-input-file ifname)) ; relative to wd, not this script!
|
||
|
|
(define oport (if (pair? ?ofname) (open-output-file (car ?ofname)) (current-output-port)))
|
||
|
|
(define mname (module-name ifname))
|
||
|
|
(display "/* " oport) (display mname oport)
|
||
|
|
(display ".c -- generated via skint nsf2c.ssc " oport)
|
||
|
|
(display (path-strip-directory ifname) oport)
|
||
|
|
(display " */" oport) (newline oport) (newline oport)
|
||
|
|
(let loop ([x (read iport)] [end-of-includes? #f])
|
||
|
|
(unless (eof-object? x)
|
||
|
|
(cond [end-of-includes?
|
||
|
|
(process-top-form x oport)
|
||
|
|
(loop (read iport) #t)]
|
||
|
|
[(and (list2? x) (eq? (car x) '%include) (string? (cadr x)))
|
||
|
|
(display "#include " oport) (write (cadr x) oport) (newline oport)
|
||
|
|
(loop (read iport) #f)]
|
||
|
|
[else ; switching to body forms
|
||
|
|
(display "#include \"" oport) (display mname oport)
|
||
|
|
(display ".h\"" oport) (newline oport) (newline oport)
|
||
|
|
(process-top-form x oport)
|
||
|
|
(loop (read iport) #t)])))
|
||
|
|
(close-input-port iport)
|
||
|
|
(if (pair? ?ofname) (close-output-port oport)))
|
||
|
|
|
||
|
|
(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))
|