diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2022-07-21 18:05:59 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2022-07-21 18:05:59 +0200 |
commit | 3413f60db482ce7e6d6d786348723a2b406d1038 (patch) | |
tree | c3063d65d05e93ff6045f99fa15ff80acf7d3066 /module/c | |
parent | Major work on parser. (diff) | |
download | calp-3413f60db482ce7e6d6d786348723a2b406d1038.tar.gz calp-3413f60db482ce7e6d6d786348723a2b406d1038.tar.xz |
Remove old unused files.
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 |
9 files changed, 8 insertions, 757 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)))) |