aboutsummaryrefslogtreecommitdiff
path: root/module/c/preprocessor.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/c/preprocessor.scm')
-rw-r--r--module/c/preprocessor.scm370
1 files changed, 0 insertions, 370 deletions
diff --git a/module/c/preprocessor.scm b/module/c/preprocessor.scm
deleted file mode 100644
index 71712b17..00000000
--- a/module/c/preprocessor.scm
+++ /dev/null
@@ -1,370 +0,0 @@
-(define-module (c preprocessor)
- :use-module (srfi srfi-1)
- :use-module (srfi srfi-9 gnu)
- :use-module (ice-9 rdelim)
- :use-module (ice-9 regex)
- :use-module (hnh util object)
-
- :use-module (hnh util)
- :use-module (hnh util object)
- )
-
-(define (read-lines port)
- (let loop ((done '()))
- (let ((line (read-line port)))
- (if (eof-object? line)
- (reverse done)
- (loop (cons line done))))))
-
-;; The source line of a give readen line
-(define line-number (make-object-property))
-;; The source file of a given readen line
-(define line-file (make-object-property))
-
-
-(define (mark-with-property! items property property-value)
- (for-each (lambda (item) (set! (property item) property-value))
- items))
-
-(define trigraph-rx (make-regexp "??([=()/'<>!-])"))
-(define (expand-trigraphs line)
- (regexp-substitute/global
- #f trigraph-rx
- line
- 'pre (lambda (m) (case (string-ref (match:substring m 1) 1)
- ((#\=) "#")
- ((#\() "[")
- ((#\)) "]")
- ((#\/) "\\")
- ((#\') "^")
- ((#\<) "{")
- ((#\>) "}")
- ((#\!) "|")
- ((#\-) "~")))
- 'post))
-
-(define (number-lines lines)
- (for-each (lambda (line number)
- (set! (line-number line) number))
- lines
- (iota (length lines) 1))
- lines)
-
-;; Should this line be merged with the next
-(define (line-continued? line)
- (case (string-length line)
- ((0) #f)
- ((1) (string=? "\\" line))
- (else
- (let ((len (string-length line)))
- ;; TODO can extra backslashes change this?
- (and (char=? #\\ (string-ref line (- len 1)))
- (not (char=? #\\ (string-ref line (- len 2)))))))))
-
-(define (transfer-line-number to from)
- (set! (line-number to) (line-number from))
- to)
-
-;; Merge two lines, assuming that upper ends with a backslash
-(define (merge-lines upper lower)
- (let ((new-string (string-append (string-drop-right upper 1) lower)))
- (transfer-line-number new-string upper)
- new-string))
-
-(define (fold-lines lines)
- (fold-right (lambda (line done)
- (if (line-continued? line)
- (cons (merge-lines line (car done)) (cdr done))
- (cons line done)))
- '()
- lines))
-
-
-(define comment-rx (make-regexp "(//|/[*]|[*]/)"))
-
-(define (strip-comments lines)
- (let loop ((in-comment #f) (lines lines) (done '()))
- (if (null? lines)
- (reverse done)
- (let ((line (car lines)))
- (cond ((regexp-exec comment-rx line)
- => (lambda (m)
- (format (current-output-port) "~s ~s substr = ~s~%" in-comment (line-number line) (match:substring m))
- (cond ((and in-comment (string=? "*/" (match:substring m)))
- (loop #f (cons (transfer-line-number (match:suffix m) line)
- (cdr lines))
- done))
- (in-comment (loop #t (cdr lines) done))
- ((string=? "//" (match:substring m))
- (loop #f (cdr lines) (cons (transfer-line-number (match:prefix m) line)
- done)))
- ((string=? "/*" (match:substring m))
- (loop #t (cons (transfer-line-number (match:suffix m) line) (cdr lines)) done))
- (else
- (scm-error 'cpp-error "strip-comments"
- "Unexpected */ in file ~a on line ~a"
- (list (line-file line) (line-number line))
- #f)))))
- (else (loop in-comment (cdr lines) (cons line done))))))))
-
-
-(define-immutable-record-type <preprocessor-directive>
- (make-preprocessor-directive type body)
- proprocessor-directive?
- (type directive-type)
- (body directive-body))
-
-(define cpp-directive-rx (make-regexp "\\s*#\\s*((\\w+)(.*))?"))
-(define (preprocessor-directive? line)
- (cond ((regexp-exec cpp-directive-rx line)
- => (lambda (m)
- (if (match:substring m 2)
- (make-preprocessor-directive
- (string->symbol (match:substring m 2))
- (string-trim-both (match:substring m 3) char-set:whitespace))
- 'sort-of)))
- (else #f)))
-
-;; defined
-
-;; TODO _Pragma
-
-
-(define (expand-function-line-macro environment macro . params)
- (expand-macro environment (apply-macro macro (map (lambda (param) (expand-macro environment param)) params))))
-
-;; (define (environment-ref ))
-
-(define (list-of? lst predicate)
- (every predicate lst))
-
-
-;; Parantheses when defining macro
-(define (parse-parameter-string string)
- (map string-trim-both
- (string-split (string-trim-both string (char-set #\( #\)))
- #\,)))
-
-
-(define-type (object-macro)
- (body type: string?))
-
-(define-type (function-macro)
- (formals type: (list-of? string?))
- (body type: string?))
-
-
-;; The interesting part
-;; environment, (list string) -> (values (list string) (list strings))
-;; multiple lines since since a function-like macro can extend over multiple lines
-;; (define (expand-macros environment strings)
-;; )
-
-
-(define (crash-if-not-if body guilty)
- (scm-error 'cpp-error guilty
- "else, elif, and endif invalid outside if scope: ~s~%file: ~s line: ~s"
- (list body (line-file body) (line-number body))))
-
-;; (environment, lines) -> environment x lines
-(define (parse-directives environment lines)
- (let loop ((environment environment) (lines lines) (done '()))
- (let* ((line (car line))
- (directive? (preprocessor-directive? line)))
- (case directive?
- ((#f) ; regular line
- (loop environment (cdr lines)
- ;; TODO this doesn't work, since parse-macros works on multiple lines
- (cons (parse-macros environment (car lines)) done)))
- ((sort-of) ; a no-op directive
- (loop environment (cdr lines) done))
- (else ; an actual directive
- (case (car (cpp-if-status environment))
- ((outside)
- (case (directive-type m)
- ((ifndef endif else)
- (scm-error 'cpp-error "parse-directives"
- "Unexpected directive: ~s"
- (list line) #f))
- (else ; inside if, ifelse or else
- ;; outside active-if inactive-if
- (case (directive-type m)
- ;; stack ending directives
- ((endif)
- (case (car (cpp-if-status environment))
- ((outside) (crash-if-not-if (directive-body m) "endif"))
- (else (loop (modify environment cpp-if-status cdr)
- (cdr lines)
- done))))
-
- ;; stack nudging directives
- ((else)
- (case (car (cpp-if-status environment))
- ((outside) (crash-if-not-if (directive-body m) "else"))
- (else (loop (modify environment (lens-compose cpp-if-status car*)
- (lambda (old)
- (case old
- ((active-if) 'inactive-if)
- ((inactive-if) 'active-if))))
- (cdr lines)
- done))))
- ((elif)
- (case (car (cpp-if-status environment))
- ((outside) (crash-if-not-if (directive-body m) "elif"))
- (else 'TODO ;; TODO
- )
- ))
-
- ;; stack creating directives
- ;; on inactive-if each creates a new frame, which also is inactive
- ((ifndef)
- (case (car (cpp-if-status environment))
- ((inactive-if) (loop (modify environment cpp-if-status
- xcons 'inactive-if)
- (cdr lines)
- done))
- (else (loop (modify environment cpp-if-status
- xcons (if (in-environment? environment (directive-body directive?))
- 'inactive-if 'active-if))
- (cdr lines)
- done))))
-
- ((ifdef)
- (case (car (cpp-if-status environment))
- ((inactive-if) (loop (modify environment cpp-if-status
- xcons 'inactive-if)
- (cdr lines)
- done))
- (else
- (loop (modify environment cpp-if-status
- xcons (if (in-environment? environment (directive-body directive?))
- 'active-if 'inactive-if))
- (cdr lines)
- done))))
-
- ((if)
- (case (car (cpp-if-status environment))
- ((inactive-if) (loop (modify environment cpp-if-status
- xcons 'inactive-if)
- (cdr lines)
- done))
- (else 'TODO ;; TODO
- )))
-
-
- ;; other directives
- ((include) (cond ((string-match "[<\"](.*)"
- => (lambda (m)
- (let ((fileneme (string-drop-right (directive-body m) 1)))
- (case (string-ref (match:substring m 1) 0)
- ;; TODO include-path
- ((#\<) (handle-file environment filename))
- ((#\") (handle-file environment filename))))))
- (else (scm-error 'cpp-error "parse-directives"
- "Invalid include"
- '() #f)))))
- ((define)
- ;; TODO what are valid names?
- (cond ((string-match "^(\\w+)([(][^)]*[)])?\\s+(.*)" (directive-body directive?))
- => (lambda (m)
- (loop (let ((macro-body (string-trim-both (match:substring m 3))))
- (add-identifier!
- environment
- (match:substring m 1)
- (cond ((match:substring m 2)
- => (lambda (parameter-string)
- (function-macro
- formals: (parse-parameter-string parameter-string)
- body: macro-body)))
- (else (object-macro body: macro-body)))))
- (cdr lines)
- done)))
- (else (scm-error 'cpp-error "parse-directives"
- "Invalid #define line, ~s"
- (list (directive-body directive?))
- #f))))
-
- ((undef)
- (case (car (cpp-if-status environment))
- ((inactive-if) (loop environment (cdr lines) done))
- (else (loop (remove-identifier environment (directive-body directive?))
- (cdr lines)
- done))))
-
- ((line)
- (case (car (cpp-if-status environment))
- ((inactive-if) (loop environment (cdr lines) done))
- ;; TODO add first-run parameter to loop, in case expand-macros still return something invalid
- (else (let parse-line-directive ((tokens (string-tokenize (directive-body directive?))))
- (cond ((= 1 (length tokens))
- ;; TODO parse token
- (if (integer? (car tokens))
- ;; TODO update current line
- (loop environment (cdr lines) done)
- (parse-line-directive (expand-macros environment (directive-body directive?)))))
- ((= 2 (length tokens))
- ;; TODO parse tokens
- (if (and (integer? (car tokens))
- (string-literal? (cadr tokens)))
- ;; TODO update current line and file
- (loop environment (cdr lines) done)
- (parse-line-directive (expand-macros environment (directive-body directive?)))))
- (else (parse-line-directive (expand-macros environment (directive-body directive?)))))))))
-
- ((error)
- (throw 'cpp-error-directive
- (directive-body directive?)))
-
- ((warning)
- (format (current-error-port) "#warning ~a~%"
- (directive-body directive?))
- (loop environment (cdr lines) done))
-
- ((pragma)
- (format (current-error-port)
- "PRAGMA: ~s~%" (directive-body directive?))
- (loop environment (cdr lines) done))
-
- ((ident sccs)
- (format (current-error-port)
- "IDENT: ~s~%" (directive-body directive?))
- (loop environment (cdr lines) done))
-
- (else
- (scm-error 'cpp-error "parse-directives"
- "Unknown pre-processor directive: ~s"
- (list line) #f)
- )))))))))
- ))
-
-
-(define* (writeln expr optional: (port (current-output-port)))
- (write expr port)
- (newline port))
-
-(define (handle-lines environment lines)
- (parse-directive environment
- (compose strip-comments fold-lines number-lines)))
-
- ;; parse-directives environment
-
-;; Return a number of lines
-(define (read-file file-path)
- (define raw-lines (call-with-input-file file-path read-lines))
- (mark-with-property! line line-file file-path)
- (handle-lines raw-lines))
-
-
-;; pre defined macros
-;; see info manual for cpp 3.7.1 Standard Predefined Macros
-;; __FILE__
-;; __LINE__
-;; __DATE__ "Feb 12 1996"
-;; __TIME__ "23:59:01"
-;; __STDC__ 1
-;; __STDC_VERSION__ 201112L
-;; __STDC_HOSTED__ 1
-
-;; __cplusplus
-;; __OBJC__
-;; __ASSEMBLER__
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-17 09:35:33 +0200