diff options
Diffstat (limited to '')
-rw-r--r-- | module/c/eval.scm | 265 | ||||
-rw-r--r-- | module/c/eval/environment.scm | 34 | ||||
-rw-r--r-- | module/c/old/cpp.scm (renamed from module/c/cpp.scm) | 8 | ||||
-rw-r--r-- | module/c/old/lex.scm (renamed from module/c/lex.scm) | 4 | ||||
-rw-r--r-- | module/c/old/operators.scm (renamed from module/c/operators.scm) | 2 | ||||
-rw-r--r-- | module/c/old/parse.scm (renamed from module/c/parse.scm) | 2 | ||||
-rw-r--r-- | module/c/preprocessor.scm | 370 | ||||
-rw-r--r-- | module/c/util.scm | 20 | ||||
-rw-r--r-- | module/c/zipper.scm | 60 | ||||
-rw-r--r-- | module/glob.scm | 2 | ||||
-rw-r--r-- | module/vulgar/termios.scm | 2 | ||||
-rw-r--r-- | tests/test/c-parse.scm | 8 | ||||
-rw-r--r-- | tests/test/cpp.scm | 604 |
13 files changed, 14 insertions, 1367 deletions
diff --git a/module/c/eval.scm b/module/c/eval.scm deleted file mode 100644 index 67d0075d..00000000 --- a/module/c/eval.scm +++ /dev/null @@ -1,265 +0,0 @@ -(define-module (c eval) - :use-module (hnh util) - :use-module (srfi srfi-1) - :use-module (srfi srfi-71) - :use-module (srfi srfi-88) - :use-module (ice-9 match) - :use-module (ice-9 curried-definitions) - :use-module ((rnrs bytevectors) - :select (bytevector?)) - :use-module ((rnrs arithmetic bitwise) - :select (bitwise-not - bitwise-and - bitwise-ior - bitwise-xor - bitwise-arithmetic-shift-left - bitwise-arithmetic-shift-right)) - :use-module (c eval environment) - :export (c-procedure? - procedure-formals - procedure-body - procedure-arity - - c-eval - )) - -(define C-TRUE 1) -(define C-FALSE 0) - -(define (boolean->c-boolean bool) - (if bool C-TRUE C-FALSE)) - -(define (c-boolean->boolean bool) - (not (zero? bool))) - -(define (c-not b) - (-> b c-boolean->boolean not boolean->c-boolean)) - -(define (c-procedure? expr) - (and (list? expr) - (not (null? expr)) - (eq? 'lambda (car expr)))) - -(define* (ensure-c-procedure expr optional: calling-procedure) - (unless (c-procedure? expr) - (scm-error 'c-eval-error calling-procedure - "Value not a procedure: ~s" - (list procedure #f)))) - -(define (procedure-formals procedure) - (ensure-c-procedure procedure "procedure-formals") - (list-ref procedure 1)) - -(define (procedure-body procedure) - (ensure-c-procedure procedure "procedure-body") - (list-ref procedure 2)) - -(define (procedure-arity procedure) - (length (procedure-formals procedure))) - -(define (literal? expression) - (or (number? expression) - (bytevector? expression))) - - - -;; Internal helper procedures - -(define (mod-set operation) - (lambda (env slot value) - ;; a += b - ;; a = a + b - (c-eval env `(= ,slot (,operation ,slot ,value))))) - -(define (fold-2 proc init lst) - (car+cdr - (fold (lambda (arg env+done) - (let ((env* arg* (proc (car env+done) arg))) - (cons* env* arg* (cdr env+done)))) - init - lst))) - -;; TODO this disregards -;; - floating point convertions -;; - integer truncation -(define ((simple-infix operation) env . operands) - (let ((env done (fold-2 c-eval (cons env '()) operands))) - (values env (apply operation (reverse done))))) - -(define ((binary-operator proc) env i c) - (let ((env* i* (c-eval env i))) - (let ((env** c* (c-eval env* c))) - (values env** (proc i* c*))))) - - - - -;; The order of evaluation for a number of these is undefined, meaning -;; that any side effects without sequence points is undefined. -;; However, for many of these I do the sensible thing and evaluate them -;; from left to right, instead of ignoring all side effects. - -;; TODO double check these with a C standard - - -;; Operators have their own namespace. They are called without funcall -;; in the pseudo-lisp which C is compiled to, and they expand more like -;; lisp macros, since its up to each operator what to do with its operands. -;; This to allow assignment and short circuting. -(define primitives - `((and . ,(lambda (env . operands) - (let loop ((env env) (operands operands)) - (if (null? operands) - (values env C-TRUE) - (let* ((env* result (c-eval env (car operands)))) - (if (c-boolean->boolean result) - (loop env* (cdr operands)) - (values env* result))))))) - (or . ,(lambda (env . operands) - (let loop ((env env) (operands operands)) - (if (null? operands) - (values env C-FALSE) - (let* ((env* result (c-eval env (car operands)))) - (if (false? result) - (values env* result) - (loop env* (cdr operands)))))))) - (= . ,(lambda (env slot value) - ;; TOOD if slot isn't a variable, but a field (or array index) - ;; then it needs to be resolved... - (let ((env* result (c-eval env value))) - (values (env-set! env* slot result) - result)))) - (and_eq ,(mod-set 'bitand)) ; &= - (or_eq ,(mod-set 'bitor)) ; |= - (xor_eq ,(mod-set 'xor)) ; ^= - (+= ,(mod-set '+)) - (-= ,(mod-set '-)) - (*= ,(mod-set '*)) - (/= ,(mod-set '/)) - (<<= ,(mod-set '<<)) - (>>= ,(mod-set '>>)) - (%= ,(mod-set '%)) - (+ . ,(simple-infix +)) - (* . ,(simple-infix *)) - (/ . ,(simple-infix /)) - (- . ,(lambda (env op . operands) - (if (null? operands) - (let ((env* value (c-eval env op))) - (values env* (- value))) - (apply (simple-infix -) - env op operands)))) - (bitor . ,(simple-infix bitwise-ior)) - (bitand . ,(simple-infix bitwise-and)) - (xor . ,(simple-infix bitwise-xor)) - (not_eq . ,(lambda (env a b) (c-eval env `(not (== ,a ,b))))) ; != - (<< . ,(binary-operator bitwise-arithmetic-shift-left)) - (>> . ,(binary-operator bitwise-arithmetic-shift-right)) - (< . ,(binary-operator (compose boolean->c-boolean <))) - (> . ,(binary-operator (compose boolean->c-boolean >))) - ;; this assumes that = handles pointers - (== . ,(binary-operator (compose boolean->c-boolean =))) - (<= . ,(binary-operator (compose boolean->c-boolean <=))) - (>= . ,(binary-operator (compose boolean->c-boolean >=))) - (% . ,(binary-operator modulo)) - - (not . ,(lambda (env value) - (let ((env* result (c-eval env value))) - (values env* (c-not result))))) - (compl . ,(lambda (env value) - (let ((env* result (c-eval env value))) - (values env* (bitwise-not result))))) - - ;; ++C - (pre-increment . ,(lambda (env slot) (c-eval env `(+= ,slot 1)))) - (pre-decrement . ,(lambda (env slot) (c-eval env `(-= ,slot 1)))) - ;; TODO these (C++, C--) need to handle if slot isn't a direct variabl - (post-increment . ,(lambda (env slot) - (let ((value (env-ref env slot))) - (values (env-set! env slot (1+ value)) - value)))) - (pre-decrement . ,(lambda (env slot) - (let ((value (env-ref env slot))) - (values (env-set! env slot (1+ value)) - value)))) - - (ternary . ,(lambda (env test true-clause false-clause) - (let ((env* value (c-eval env test))) - (c-eval env* - (if (c-boolean->boolean value) - true-clause false-clause))))) - - ;; TODO remaining operations - (as-type . ,(lambda (env target-type value) - (format (current-error-port) "cast<~s>(~s)~%" target-type value) - (values env value))) - - (object-slot . ,(lambda (env object slot) - (scm-error 'not-implemented "object-slot" - "Object slots are not implemented, when accessing ~s.~s" - (list object slot) #f))) - (dereference-slot ,(lambda (env ptr slot) - (scm-error 'not-implemented "dereference-slot" - "Object slots are not implemented, when accessing ~s->~s" - (list object slot) #f))) - (dereference . ,(lambda (env ptr) - (scm-error 'not-implemented "dereference" - "Poiner dereferencing is not implemented: *~s" - (list ptr) #f))) - (pointer . ,(lambda (env value) - (scm-error 'not-implemented "pointer" - "Pointer of is not implemented: &~s" - (list value) #f))))) - -;; TODO |,| - - -(define (c-eval environment expression) - (match expression - (('lambda formals body) (values environment `(lambda ,formals ,body))) - ;; hack since sizeof really should be a operator - (('funcall 'sizeof arg) - ;; TODO - (format (current-error-port) "sizeof ~s~%" arg) - (values environment 1)) - - (('funcall procedure-name ('#{,}# args ...)) - (let ((procedure (env-ref environment procedure-name))) - (ensure-c-procedure procedure "c-eval") - (unless (= (length args) (procedure-arity procedure)) - (scm-error 'c-eval-error "c-eval" - "Procedure arity mismatch for ~s, expected ~s, got ~s" - (list procedure-name - (procedure-arity procedure) - (length args)) - #f)) - (let ((env args* (fold-2 c-eval (cons environment '()) args ))) - (let ((inner-environment - (fold (lambda (name value env) (env-set! env name value)) - (push-frame! env) - (procedure-formals procedure) args*))) - (let ((resulting-environment - result-value - (c-eval inner-environment (procedure-body procedure)))) - (values (pop-frame! resulting-environment) - result-value)))))) - - (('funcall procedure arg) - (c-eval environment `(funcall ,procedure (#{,}# ,arg)))) - - ((operator operands ...) - (apply (or (assoc-ref primitives operator) - (scm-error 'c-eval-error "c-eval" - "Applying non-existant primitive operator: ~s, operands: ~s" - (list operator operands) #f)) - environment operands)) - - ;; "f()" gets compiled to simply f - ;; meaning that we instead use the environment to determine - ;; if something is a variable or procedure - (expr - (if (literal? expr) - (values environment expr) - (let ((value (env-ref environment expr))) - (if (c-procedure? value) - (c-eval environment `(funcall ,value (#{,}#))) - (values environment value))))))) diff --git a/module/c/eval/environment.scm b/module/c/eval/environment.scm deleted file mode 100644 index 12eefaf7..00000000 --- a/module/c/eval/environment.scm +++ /dev/null @@ -1,34 +0,0 @@ -(define-module (c eval environment) - :use-module (srfi srfi-1) - :export (make-environment - env-set! env-ref push-frame! pop-frame!)) - -(define (make-frame) - (make-hash-table)) - -(define (make-environment) - (list (make-frame))) - -;; Returns an updated environment, linear update -(define (env-set! env key value) - ;; get handle to differentiate #f - ;; (even though #f should never be stored since it's not a C value) - (cond ((find (lambda (frame) (hashq-get-handle frame key)) env) - => (lambda (frame) (hashq-set! frame key value))) - (else (hashq-set! (car env) key value))) - env) - -(define (env-ref env key) - (cond ((null? env) - (scm-error 'misc-error "env-ref" - "~s unbound" - (list key) - #f)) - ((hashq-get-handle (car env) key) => cdr) - (else (env-ref (cdr env) key)))) - -(define (push-frame! environment) - (cons (make-frame) environment)) - -(define (pop-frame! environment) - (cdr environment)) diff --git a/module/c/cpp.scm b/module/c/old/cpp.scm index aed496f2..1623bd11 100644 --- a/module/c/cpp.scm +++ b/module/c/old/cpp.scm @@ -1,4 +1,4 @@ -(define-module (c cpp) +(define-module (c old cpp) :use-module (hnh util) :use-module (srfi srfi-1) :use-module (ice-9 popen) @@ -9,9 +9,9 @@ :use-module (ice-9 format) :use-module ((hnh util io) :select (read-lines)) :use-module (hnh util graph) - :use-module (c lex) - :use-module (c parse) - :use-module (c operators) + :use-module (c old lex) + :use-module (c old parse) + :use-module (c old operators) :export (replace-symbols include#) ) diff --git a/module/c/lex.scm b/module/c/old/lex.scm index 0bde5c9e..dcc7336d 100644 --- a/module/c/lex.scm +++ b/module/c/old/lex.scm @@ -1,6 +1,6 @@ -(define-module (c lex) +(define-module (c old lex) :use-module (ice-9 peg) - :use-module (c operators) + :use-module (c old operators) :export (lex)) diff --git a/module/c/operators.scm b/module/c/old/operators.scm index 910dc8a9..0b253ada 100644 --- a/module/c/operators.scm +++ b/module/c/old/operators.scm @@ -1,4 +1,4 @@ -(define-module (c operators) +(define-module (c old operators) :export (wordy-binary-operators symbol-binary-operators binary-operators)) diff --git a/module/c/parse.scm b/module/c/old/parse.scm index 7d11ea17..d598e3c9 100644 --- a/module/c/parse.scm +++ b/module/c/old/parse.scm @@ -1,4 +1,4 @@ -(define-module (c parse) +(define-module (c old parse) :use-module (hnh util) :use-module (srfi srfi-1) :use-module (srfi srfi-71) 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__ diff --git a/module/c/util.scm b/module/c/util.scm deleted file mode 100644 index f258d3e3..00000000 --- a/module/c/util.scm +++ /dev/null @@ -1,20 +0,0 @@ -(use-modules (c lex2) - (srfi srfi-1) - (srfi srfi-88) - (c to-token) - (c cpp-types)) - -(define (tok s) - (map preprocessing-token->token (remove whitespace-token? (lex s)))) - -(define* (parse tokens optional: (parser make-parser)) - ((parser) - (build-lexical-analyzer tokens) - error)) - - -(define (mm) - (lalr-parser - (x) - (y (x)) - )) diff --git a/module/c/zipper.scm b/module/c/zipper.scm deleted file mode 100644 index 65cea211..00000000 --- a/module/c/zipper.scm +++ /dev/null @@ -1,60 +0,0 @@ -;;; Commentary: -;; Zipper data structure. Could be moved to (hnh util), but would then need to -;; be at least slightly more thorough. -;;; Code: - -(define-module (c zipper) - :use-module (srfi srfi-88) - :use-module (hnh util object) - :export (list-zipper - list-zipper? - left focused right - zip-left - zip-right - zip-find-right - list->zipper - zipper->list - rezip)) - -(define-type (list-zipper) - (left type: list?) - focused - (right type: list?)) - -;; Move zipper one step to the left -(define (zip-left zipper) - (if (null? (left zipper)) - zipper - (list-zipper left: (cdr (left zipper)) - right: (cons (focused zipper) (right zipper)) - focused: (car (left zipper))))) - -;; Move zipper one step to the right -(define (zip-right zipper) - (if (null? (right zipper)) - zipper - (list-zipper left: (cons (focused zipper) (left zipper)) - right: (cdr (right zipper)) - focused: (car (right zipper))))) - -;; find first element matching predicate, going right -(define (zip-find-right predicate zipper) - (cond ((null? (right zipper)) zipper) - ((predicate (focused zipper)) zipper) - (else (zip-find-right predicate (zip-right zipper))))) - -(define (list->zipper list) - (list-zipper left: '() - focused: (car list) - right: (cdr list))) - - -(define (rezip zipper) - (if (null? (left zipper)) - zipper - (rezip (zip-left zipper)))) - -(define (zipper->list zipper) - (let ((z (rezip zipper))) - (cons (focused z) - (right z)))) diff --git a/module/glob.scm b/module/glob.scm index 64f97690..bd9a6ea5 100644 --- a/module/glob.scm +++ b/module/glob.scm @@ -1,7 +1,7 @@ (define-module (glob) :use-module (system foreign) :use-module (rnrs bytevectors) - :use-module (c cpp) + :use-module (c old cpp) :export (glob)) diff --git a/module/vulgar/termios.scm b/module/vulgar/termios.scm index ddd8920f..5ef86c00 100644 --- a/module/vulgar/termios.scm +++ b/module/vulgar/termios.scm @@ -7,7 +7,7 @@ :use-module (ice-9 rdelim) :use-module (srfi srfi-9) ; records :use-module (srfi srfi-88) - :use-module (c cpp) + :use-module (c old cpp) :use-module (hnh util) :export (make-termios copy-termios diff --git a/tests/test/c-parse.scm b/tests/test/c-parse.scm index c16958de..22aaf92a 100644 --- a/tests/test/c-parse.scm +++ b/tests/test/c-parse.scm @@ -6,11 +6,11 @@ (define-module (test cpp) :use-module (srfi srfi-64) :use-module (srfi srfi-88) - :use-module ((c lex) :select (lex)) - :use-module (c parse)) + :use-module ((c old lex) :select (lex)) + :use-module (c old parse)) -(define flatten-infix (@@ (c parse) flatten-infix)) -(define resolve-order-of-operations (@@ (c parse) resolve-order-of-operations)) +(define flatten-infix (@@ (c old parse) flatten-infix)) +(define resolve-order-of-operations (@@ (c old parse) resolve-order-of-operations)) (test-group "Flatten infix" (test-equal "Simple binary operator" diff --git a/tests/test/cpp.scm b/tests/test/cpp.scm deleted file mode 100644 index 1294bc96..00000000 --- a/tests/test/cpp.scm +++ /dev/null @@ -1,604 +0,0 @@ -;;; Commentary: -;; Tests my parser for a subset of the C programming language. -;;; Code: - -(define-module (test cpp) - :use-module (srfi srfi-1) - :use-module (srfi srfi-64) - :use-module (srfi srfi-88) - :use-module ((c lex) :select (lex)) - :use-module ((c parse) :select (parse-lexeme-tree)) - :use-module ((c eval) :select (c-eval)) - :use-module ((c eval environment) :select (make-environment env-set!)) - :use-module ((rnrs arithmetic bitwise) - :select (bitwise-xor))) - -;; Note that the lexer's output isn't stable. -;; The tests here are more to see where the lexer succeeds but the parser fails. -;; So changing the lexer test cases isn't a problem -;; but don't change the parser test cases - -;; __asm__ always has strings as arguments -(test-skip "__asm__") - -;; Lexer produces garbage when attempted. Fixing this would also fix cast -;; operations. -(test-skip "Float in infix expression") -;; order of operation is wrong, leading to an incorrect result -(test-skip "Cast with operation") - -;; not implemented -(test-skip "Token concatenation") - -;; A string follewed by a macro (which expands to a string) -;; should be concatenated. This is however not yet implemented -(test-skip "Implicit concatenation of string and macro") - -(define run (compose parse-lexeme-tree lex)) - -(define (alist->environment alist) - (fold (lambda (pair env) - (apply env-set! env pair)) - (make-environment) - alist)) - -(define (exec form . base-bindings) - (call-with-values - (lambda () (c-eval (alist->environment base-bindings) - (run form))) - (lambda (env value) value))) - -(define-syntax let-group - (syntax-rules () - ((let ((form name) rest ...) body ...) - (test-group name - (let ((form name) - rest ...) - body ...))))) - -(let-group - ((form "(*C)++ + 3")) - (test-equal '(infix (postfix (group (prefix (prefix-operator "*") - (variable "C"))) - (postfix-operator "++")) - (operator "+") - (integer (base-10 "3"))) - (lex form)) - (test-equal '(+ (post-increment (dereference C)) 3) - (run form))) - -(let-group - ((form "*C++ + 3")) - (test-equal '(infix (postfix (prefix (prefix-operator "*") - (variable "C")) - (postfix-operator "++")) - (operator "+") - (integer (base-10 "3"))) - (lex form)) - (test-equal '(+ (post-increment (dereference C)) 3) - (run form))) - -(let-group - ((form "*C++")) - (test-equal '(postfix (prefix (prefix-operator "*") - (variable "C")) - (postfix-operator "++")) - (lex form)) - (test-equal '(post-increment (dereference C)) - (run form))) - -(let-group - ((form "C++ + C++")) - (test-equal '(infix (postfix (variable "C") - (postfix-operator "++")) - (operator "+") - (postfix (variable "C") - (postfix-operator "++"))) - (lex form)) - (test-equal '(+ (post-increment C) (post-increment C)) - (run form))) - -(let-group - ((form "++C + ++C")) - (test-equal '(infix (prefix (prefix-operator "++") - (variable "C")) - (operator "+") - (prefix (prefix-operator "++") - (variable "C"))) - (lex form)) - (test-equal '(+ (pre-increment C) (pre-increment C)) - (run form))) - -(let-group - ((form "2 + 2 * 2")) - (test-equal '(infix (integer (base-10 "2")) - (operator "+") - (infix (integer (base-10 "2")) - (operator "*") - (integer (base-10 "2")))) - (lex form)) - (test-equal '(+ 2 (* 2 2)) (run form)) - (test-equal 6 (exec form))) - -(let-group - ((form "2 * 2 + 2")) - (test-equal '(infix (integer (base-10 "2")) - (operator "*") - (infix (integer (base-10 "2")) - (operator "+") - (integer (base-10 "2")))) - (lex form)) - (test-equal '(+ (* 2 2) 2) (run form)) - (test-equal 6 (exec form))) - -(let-group - ((form "2+2+2")) - (test-equal '(infix (integer (base-10 "2")) - (operator "+") - (infix (integer (base-10 "2")) - (operator "+") - (integer (base-10 "2")))) (lex form)) - (test-equal '(+ 2 2 2) (run form)) - (test-equal 6 (exec form))) - -(test-group "Unary minus" - (test-group "Without space" - (let ((form "-1")) - (test-equal '(prefix (prefix-operator "-") - (integer (base-10 "1"))) - (lex form)) - (test-equal '(- 1) (run form)) - (test-equal -1 (exec form)))) - - (test-group "With space" - (let ((form "- 1")) - (test-equal '(prefix (prefix-operator "-") - (integer (base-10 "1"))) - (lex form)) - (test-equal '(- 1) (run form)) - (test-equal -1 (exec form)))) - - (test-group "Before variable" - (let ((form "-x")) - (test-equal '(prefix (prefix-operator "-") - (variable "x")) - (lex form)) - (test-equal '(- x) (run form)) - (test-equal -5 (exec form '(x 5))))) - - (test-group "Before infix" - (let ((form "-x+3")) - (test-equal '(infix (prefix (prefix-operator "-") - (variable "x")) - (operator "+") - (integer (base-10 "3"))) - (lex form)) - (test-equal '(+ (- x) 3) (run form)) - (test-equal -2 (exec form '(x 5))))) - - (test-group "Inside infix expression" - (let ((form "x+-3")) - (test-equal '(infix (variable "x") - (operator "+") - (prefix (prefix-operator "-") - (integer (base-10 "3")))) - (lex form)) - (test-equal '(+ x (- 3)) (run form)) - (test-equal 2 (exec form '(x 5))))) - ) - - - - -;; Hand picked forms from output of `cpp -dM /usr/include/termios.h` on -;; FreeBSD 13.1-RELEASE releng/13.1-n250148-fc952ac2212 GENERIC amd64 -;; 2022-06-28 - -(let ((form "00000200")) - (test-equal '(integer (base-8 "0000200")) (lex form)) - (test-equal 128 (run form))) - -(let ((form "0")) - (test-equal '(integer (base-10 "0")) (lex form)) - (test-equal 0 (run form))) - -(let ((form "1000000U")) - (test-equal '(integer (base-10 "1000000") (integer-suffix "U")) (lex form)) - (test-equal '(as-type (unsigned) 1000000) (run form)) - (test-equal 1000000 (exec form))) - - -(let ((form "0x10c")) - (test-equal '(integer (base-16 "10c")) (lex form)) - (test-equal 268 (run form))) - -;; Lexer keeps original case, handled later by parser -(let ((form "0X10C")) - (test-equal '(integer (base-16 "10C")) (lex form)) - (test-equal 268 (run form))) - -(let ((form "a != b")) - (test-equal '(infix (variable "a") - (operator "!=") - (variable "b")) - (lex form)) - (test-equal '(not_eq a b) (run form)) - (test-equal 1 (exec form '(a 1) '(b 2))) - (test-equal 0 (exec form '(a 1) '(b 1))) - ) - -(let ((form "((c) == (val) && (val) != _POSIX_VDISABLE)")) - ;; (test-equal '() (lex form)) - (test-equal '(and (== c val) - (not_eq val _POSIX_VDISABLE)) - (run form)) - (test-equal 0 (exec form '(c 1) '(val 2) '(_POSIX_VDISABLE 3))) - ) - -(let ((form "CTRL('O')")) - (test-equal '(funcall (variable "CTRL") (group (char "O"))) (lex form)) - (test-equal '(funcall CTRL 79) (run form)) - (test-equal (bitwise-xor #x40 (char->integer #\O)) - (exec form - ;; Definition copied from our parsers output of - ;; preprocessing output as defined above - '(CTRL (lambda (x) - (ternary (and (>= x 97) (<= x 122)) - (+ (- x 97) 1) - (bitand (+ (- x 65) 1) 127))))))) - -(let ((form "CREPRINT")) - (test-equal '(variable "CREPRINT") (lex form)) - (test-equal 'CREPRINT (run form))) - -(let ((form "(CCTS_OFLOW | CRTS_IFLOW)")) - (test-equal '(group (infix (variable "CCTS_OFLOW") - (operator "|") - (variable "CRTS_IFLOW"))) - (lex form)) - (test-equal '(bitor CCTS_OFLOW CRTS_IFLOW) (run form))) - -;; ((x) >= 'a' && (x) <= 'z' -;; ? ((x) - 'a' + 1) -;; : (((x) - 'a' + 1) & 0x7f)) -(let ((form "((x) >= 'a' && (x) <= 'z' ? ((x) - 'a' + 1) : (((x) - 'a' + 1) & 0x7f))")) - ;; (test-equal '() (lex form)) - (test-equal '(ternary - (and (>= x #x61) - (<= x #x7A)) - (+ (- x #x61) 1) - (bitand (+ (- x #x61) 1) 127)) - (run form))) - -(let ((form "((x) & ~(IOCPARM_MASK << 16))")) - ;; (test-equal '() (lex form)) - (test-equal '(bitand x (compl (<< IOCPARM_MASK 16))) (run form))) - -(let ((form "(((x) >> 8) & 0xff)")) - ;; (test-equal '() (lex form)) - (test-equal '(bitand (>> x 8) 255) (run form))) - -(let ((form "(((x) >> 16) & IOCPARM_MASK)")) - ;; (test-equal '() (lex form)) - (test-equal '(bitand (>> x 16) IOCPARM_MASK) (run form))) - -(let ((form "((1 << IOCPARM_SHIFT) - 1)")) - ;; (test-equal '() (lex form)) - (test-equal '(- (<< 1 IOCPARM_SHIFT) 1) (run form))) - -(let ((form "_IO('t', 120)")) - (test-equal '(funcall - (variable "_IO") - (group (infix (char "t") - (operator ",") - (integer (base-10 "120"))))) - (lex form)) - (test-equal '(funcall _IO (#{,}# 116 120)) (run form))) - -;; note the lone type -(let ((form "_IOW('t', 98, int)")) - ;; (test-equal '() (lex form)) - (test-equal '(funcall _IOW (#{,}# 116 98 int)) - (run form))) - -;; note the multi-word type -(let ((form "_IOR('t', 19, struct termios)")) - ;; (test-equal '() (lex form)) - (test-equal '(funcall _IOR (#{,}# 116 19 (struct-type termios))) (run form))) - - -;; TODO concatenation rules -;; #define __CONCAT(x,y) __CONCAT1(x,y) -;; #define __CONCAT1(x,y) x ## y -;; #define __CONSTANT_CFSTRINGS__ 1 -;; #define __COPYRIGHT(s) __IDSTRING(__CONCAT(__copyright_,__LINE__),s) - -(test-group "Token concatenation" - (let ((form "x ## y")) - (test-equal '() (lex form)) - (test-equal '0 (run form)))) - -(test-group "Floating point numbers" - - (test-group "Diffent forms" - (test-group "No decimal point, exponent, no suffix" - (let ((form "10e10")) - (test-equal '(float (float-integer (base-10 "10")) - (exponent (base-10 "10"))) - (lex form)) - (test-equal 10e10 (run form)))) - - (test-group "No decimal point, negative exponent" - (let ((form "10e-10")) - (test-equal '(float (float-integer (base-10 "10")) - (exponent "-" (base-10 "10"))) - (lex form)) - (test-equal 10e-10 (run form)))) - - (test-group "No decimal point, exponent and suffix" - (let ((form "10e10L")) - (test-equal '(float (float-integer (base-10 "10")) - (exponent (base-10 "10")) - (float-suffix "L")) - (lex form)) - (test-equal '(as-type (long double) 10e10) - (run form)))) - - (test-group "Leading period, no exponent or suffix" - (let ((form ".1")) - (test-equal '(float (float-decimal (base-10 "1"))) (lex form)) - (test-equal 0.1 (run form)))) - - (test-group "Trailing period, no exponent or suffix" - (let ((form "1.")) - (test-equal '(float (float-integer (base-10 "1"))) (lex form)) - (test-equal 1.0 (run form))))) - - - (test-group "Negative float" - (let ((form "-1.0")) - (test-equal '(prefix (prefix-operator "-") - (float (float-integer (base-10 "1")) - (float-decimal (base-10 "0")))) - (lex form)) - (test-equal '(- 1.0) (run form)))) - - - - (test-group "Real world examples" - (let ((form "4.9406564584124654e-324")) - (test-equal '(float (float-integer (base-10 "4")) - (float-decimal (base-10 "9406564584124654")) - (exponent "-" (base-10 "324"))) - (lex form)) - (test-equal 4.9406564584124654e-324 (run form))) - - (let ((form "1.7976931348623157e+308")) - (test-equal '(float (float-integer (base-10 "1")) - (float-decimal (base-10 "7976931348623157")) - (exponent "+" (base-10 "308"))) - (lex form)) - (test-equal 1.7976931348623157e+308 (run form)))) - - (test-group "Float in infix expression" - (test-group "Simple case" - (let ((form "1. + .1")) - (test-equal '(infix (float (float-integer (base-10 "1"))) - (operator "+") - (float (float-decimal (base-10 "1")))) - (lex form)) - (test-equal '(+ 1.0 0.1) (run form)))) - ;; (test-group "Complicated case") - )) - -(test-group "Typecasts" - - (let ((form "(unsigned) 5")) - (test-equal '((group (variable "unsigned")) - (integer (base-10 "5"))) - (lex form)) - (test-equal '(as-type (unsigned) 5) - (run form))) - - (let ((form "(unsigned integer) 5")) - (test-equal '((group (variable "unsigned") - (variable "integer")) - (integer (base-10 "5"))) - (lex form)) - (test-equal '(as-type (unsigned integer) 5) (run form))) - - (test-group "Pointer with space" - (let ((form "(int *) 5")) - (test-equal '((group (postfix (variable "int") - (postfix-operator "*"))) - (integer (base-10 "5"))) - (lex form)) - (test-equal '(as-type (int *) 5) - (run form)))) - - (test-group "Pointer without space" - (let ((form "(int*) 5")) - (test-equal '((group (postfix (variable "int") - (postfix-operator "*"))) - (integer (base-10 "5"))) - (lex form)) - (test-equal '(as-type (int *) 5) - (run form)))) - - (test-group "Multi word type pointer" - (let ((form "(unsigned int*) 5")) - (test-equal '((group (variable "unsigned") - (postfix (variable "int") - (postfix-operator "*"))) - (integer (base-10 "5"))) - (lex form)) - (test-equal '(as-type (unsigned int *) 5) - (run form)))) - - (test-group "Double cast" - (let ((form "(int)(unsigned) 5")) - (test-equal '((group (variable "int")) - (group (variable "unsigned")) - (integer (base-10 "5"))) (lex form)) - (test-equal '(as-type (int) (as-type (unsigned) 5)) - (run form)))) - - (test-group "Cast with operation" - (let ((form "(int) 5 + 7")) - (test-equal '((group (variable "int")) - (infix (integer (base-10 "5")) - (operator "+") - (integer (base-10 "7")))) - (lex form)) - - (test-equal '(+ (as-type (int) 5) 7) - (run form)))) - - - - (test-group "Tripple cast, with value inside paranthesis" - (let ((form "(type)(__uintptr_t)(const void *)(var)")) - (test-equal '((group (variable "type")) - (group (variable "__uintptr_t")) - (group (variable "const") - (postfix (variable "void") - (postfix-operator "*"))) - (group (variable "var"))) - (lex form)) - (test-equal '(as-type (type) - (as-type (__uintptr_t) - (as-type (const void *) - var))) - (run form)))) - - (test-group "Same as above, but whole thing inside parenthesis" - (let ((form "((type)(__uintptr_t)(const void *)(var))")) - (test-equal '(group (group (variable "type")) - (group (variable "__uintptr_t")) - (group (variable "const") - (postfix (variable "void") - (postfix-operator "*"))) - (group (variable "var"))) - (lex form)) - (test-equal '(as-type (type) - (as-type (__uintptr_t) - (as-type (const void *) - var))) - (run form)))) - - (let ((form "((type)(__uintptr_t)(const volatile void *)(var))")) - ;; (test-equal '() (lex form)) - (test-equal '(as-type (type) - (as-type (__uintptr_t) - (as-type (const volatile void *) - var))) - (run form))) - - (let ((form "((unsigned long) ((inout) | (((len) & IOCPARM_MASK) << 16) | ((group) << 8) | (num)))")) - (test-equal '(group (group (variable "unsigned") (variable "long")) - (group (infix (group (variable "inout")) - (operator "|") - (infix (group (infix (group (infix (group (variable "len")) - (operator "&") - (variable "IOCPARM_MASK"))) - (operator "<<") - (integer (base-10 "16")))) - (operator "|") - (infix (group (infix (group (variable "group")) - (operator "<<") - (integer (base-10 "8")))) - (operator "|") - (group (variable "num"))))))) - (lex form)) - (test-equal '(as-type (unsigned long) - (bitor inout - (<< (bitand len IOCPARM_MASK) 16) - (<< group 8) - num)) - (run form)))) - -(test-group "Characters" - (let ((form "'c'")) - (test-equal '(char "c") (lex form)) - (test-equal #x63 (run form))) - - (let ((form "'\\n'")) - (test-equal '(char (escaped-char "n")) (lex form)) - (test-equal (char->integer #\newline) (run form)))) - -(test-group "Strings" - (test-group "Empty string" - (let ((form "\"\"")) - (test-equal 'string (lex form)) - (test-equal #vu8(0) (run form)))) - - (test-group "Simple string" - (let ((form "\"li\"")) - (test-equal '(string "li") (lex form)) - (test-equal #vu8(#x6C #x69 0) (run form)))) - - (test-group "Implicit concatenation of strings" - (let ((form "\"a\" \"b\"")) - (test-equal '((string "a") - (string "b")) - (lex form)) - (test-equal #vu8(#x61 #x62 0) - (run form)))) - - (test-group "Implicit concatenation of string and macro" - (let ((form "\"a\" MACRO")) - (test-equal '((string "a") (variable "MACRO")) (lex form)) - (test-equal '() (run form)))) - - (test-group "String with only escape" - (let ((form (string #\" #\\ #\" #\"))) - (test-equal `(string (escaped-char "\"")) (lex form)) - (test-equal #vu8(34 0) (run form)))) - - (test-group "String with escape at start" - (let ((form (string #\" #\\ #\" #\a #\"))) - (test-equal `(string (escaped-char "\"") "a") (lex form)) - (test-equal #vu8(34 #x61 0) (run form)))) - - (test-group "String with escape at end" - (let ((form (string #\" #\a #\\ #\" #\"))) - (test-equal `(string "a" (escaped-char "\"")) (lex form)) - (test-equal #vu8(#x61 34 0) (run form)))) - - (test-group "String with escape in middle" - (let ((form (string #\" #\a #\\ #\" #\b #\"))) - (test-equal `(string "a" (escaped-char "\"") "b") (lex form)) - (test-equal #vu8(#x61 34 #x62 0) (run form)))) - - ;; \e is semi non-standard - (test-group "String with bakslash-e esacpe" - (let ((form "\"\\e\"")) - (test-equal '(string (escaped-char "e")) (lex form)) - (test-equal #vu8(#x1b 0) (run form)))) - - (test-group "String with byte secquence escape" - (let ((form "\"\\xf0\\x9f\\x92\\xa9\"")) - (test-equal '(string (escaped-char (base-16-char "f0")) - (escaped-char (base-16-char "9f")) - (escaped-char (base-16-char "92")) - (escaped-char (base-16-char "a9"))) - (lex form)) - (test-equal #vu8(#xf0 #x9f #x92 #xa9 0) (run form))))) - -(test-group "__asm__" - (let ((form "__asm__(\".globl \" __XSTRING(sym))")) - (test-equal '() (lex form)) - ;; TODO implicit string concatenation - (test-equal '(funcall __asm__ - (string ".globl ") - (funcall __XSTRING sym)) (run form)))) - -(let ((form "__attribute__((__aligned__(x)))")) - (test-equal '(funcall (variable "__attribute__") - (group (group (funcall (variable "__aligned__") - (group (variable "x")))))) - (lex form)) - ;; This drops the extra set of parenthesis. Do we care? - (test-equal '(funcall __attribute__ - (funcall __aligned__ x)) - (run form))) |