nyacc-1.00.2/0000755000175100000240000000000013605250523012412 5ustar mwettedialoutnyacc-1.00.2/test-suite/0000755000175100000240000000000013605250515014521 5ustar mwettedialoutnyacc-1.00.2/test-suite/test-suite/0000755000175100000240000000000013605250515016627 5ustar mwettedialoutnyacc-1.00.2/test-suite/test-suite/lib.scm0000644000175100000240000006535413605250515020116 0ustar mwettedialout;;;; test-suite/lib.scm --- generic support for testing ;;;; Copyright (C) 1999, 2000, 2001, 2004, 2006, 2007, 2009, 2010, ;;;; 2011, 2012, 2013, 2014 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either ;;;; version 3, or (at your option) any later version. ;;;; ;;;; This program is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;;; GNU Lesser General Public License for more details. ;;;; ;;;; You should have received a copy of the GNU Lesser General Public ;;;; License along with this software; see the file COPYING.LESSER. ;;;; If not, write to the Free Software Foundation, Inc., 51 Franklin ;;;; Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite lib) #:use-module (ice-9 stack-catch) #:use-module (ice-9 regex) #:autoload (srfi srfi-1) (append-map) #:autoload (system base compile) (compile) #:export ( ;; Exceptions which are commonly being tested for. exception:syntax-pattern-unmatched exception:bad-variable exception:missing-expression exception:out-of-range exception:unbound-var exception:used-before-defined exception:wrong-num-args exception:wrong-type-arg exception:numerical-overflow exception:struct-set!-denied exception:system-error exception:encoding-error exception:miscellaneous-error exception:string-contains-nul exception:read-error exception:null-pointer-error exception:vm-error ;; Reporting passes and failures. run-test pass-if expect-fail pass-if-equal pass-if-exception expect-fail-exception ;; Naming groups of tests in a regular fashion. with-test-prefix with-test-prefix* with-test-prefix/c&e current-test-prefix format-test-name ;; Using the debugging evaluator. with-debugging-evaluator with-debugging-evaluator* ;; Clearing stale references on the C stack for GC-sensitive tests. clear-stale-stack-references ;; Using a given locale with-locale with-locale* with-latin1-locale with-latin1-locale* ;; The bit bucket. %null-device ;; Reporting results in various ways. register-reporter unregister-reporter reporter-registered? make-count-reporter print-counts make-log-reporter full-reporter user-reporter)) ;;;; If you're using Emacs's Scheme mode: ;;;; (put 'with-test-prefix 'scheme-indent-function 1) ;;;; CORE FUNCTIONS ;;;; ;;;; The function (run-test name expected-result thunk) is the heart of the ;;;; testing environment. The first parameter NAME is a unique name for the ;;;; test to be executed (for an explanation of this parameter see below under ;;;; TEST NAMES). The second parameter EXPECTED-RESULT is a boolean value ;;;; that indicates whether the corresponding test is expected to pass. If ;;;; EXPECTED-RESULT is #t the test is expected to pass, if EXPECTED-RESULT is ;;;; #f the test is expected to fail. Finally, THUNK is the function that ;;;; actually performs the test. For example: ;;;; ;;;; (run-test "integer addition" #t (lambda () (= 2 (+ 1 1)))) ;;;; ;;;; To report success, THUNK should either return #t or throw 'pass. To ;;;; report failure, THUNK should either return #f or throw 'fail. If THUNK ;;;; returns a non boolean value or throws 'unresolved, this indicates that ;;;; the test did not perform as expected. For example the property that was ;;;; to be tested could not be tested because something else went wrong. ;;;; THUNK may also throw 'untested to indicate that the test was deliberately ;;;; not performed, for example because the test case is not complete yet. ;;;; Finally, if THUNK throws 'unsupported, this indicates that this test ;;;; requires some feature that is not available in the configured testing ;;;; environment. All other exceptions thrown by THUNK are considered as ;;;; errors. ;;;; ;;;; ;;;; Convenience macros for tests expected to pass or fail ;;;; ;;;; * (pass-if name body) is a short form for ;;;; (run-test name #t (lambda () body)) ;;;; * (expect-fail name body) is a short form for ;;;; (run-test name #f (lambda () body)) ;;;; ;;;; For example: ;;;; ;;;; (pass-if "integer addition" (= 2 (+ 1 1))) ;;;; ;;;; ;;;; Convenience macros to test for exceptions ;;;; ;;;; The following macros take exception parameters which are pairs ;;;; (type . message), where type is a symbol that denotes an exception type ;;;; like 'wrong-type-arg or 'out-of-range, and message is a string holding a ;;;; regular expression that describes the error message for the exception ;;;; like "Argument .* out of range". ;;;; ;;;; * (pass-if-exception name exception body) will pass if the execution of ;;;; body causes the given exception to be thrown. If no exception is ;;;; thrown, the test fails. If some other exception is thrown, it is an ;;;; error. ;;;; * (expect-fail-exception name exception body) will pass unexpectedly if ;;;; the execution of body causes the given exception to be thrown. If no ;;;; exception is thrown, the test fails expectedly. If some other ;;;; exception is thrown, it is an error. ;;;; TEST NAMES ;;;; ;;;; Every test in the test suite has a unique name, to help ;;;; developers find tests that are failing (or unexpectedly passing), ;;;; and to help gather statistics. ;;;; ;;;; A test name is a list of printable objects. For example: ;;;; ("ports.scm" "file" "read and write back list of strings") ;;;; ("ports.scm" "pipe" "read") ;;;; ;;;; Test names may contain arbitrary objects, but they always have ;;;; the following properties: ;;;; - Test names can be compared with EQUAL?. ;;;; - Test names can be reliably stored and retrieved with the standard WRITE ;;;; and READ procedures; doing so preserves their identity. ;;;; ;;;; For example: ;;;; ;;;; (pass-if "simple addition" (= 4 (+ 2 2))) ;;;; ;;;; In that case, the test name is the list ("simple addition"). ;;;; ;;;; In the case of simple tests the expression that is tested would often ;;;; suffice as a test name by itself. Therefore, the convenience macros ;;;; pass-if and expect-fail provide a shorthand notation that allows to omit ;;;; a test name in such cases. ;;;; ;;;; * (pass-if expression) is a short form for ;;;; (run-test 'expression #t (lambda () expression)) ;;;; * (expect-fail expression) is a short form for ;;;; (run-test 'expression #f (lambda () expression)) ;;;; ;;;; For example: ;;;; ;;;; (pass-if (= 2 (+ 1 1))) ;;;; ;;;; The WITH-TEST-PREFIX syntax and WITH-TEST-PREFIX* procedure establish ;;;; a prefix for the names of all tests whose results are reported ;;;; within their dynamic scope. For example: ;;;; ;;;; (begin ;;;; (with-test-prefix "basic arithmetic" ;;;; (pass-if "addition" (= (+ 2 2) 4)) ;;;; (pass-if "subtraction" (= (- 4 2) 2))) ;;;; (pass-if "multiplication" (= (* 2 2) 4))) ;;;; ;;;; In that example, the three test names are: ;;;; ("basic arithmetic" "addition"), ;;;; ("basic arithmetic" "subtraction"), and ;;;; ("multiplication"). ;;;; ;;;; WITH-TEST-PREFIX can be nested. Each WITH-TEST-PREFIX appends ;;;; a new element to the current prefix: ;;;; ;;;; (with-test-prefix "arithmetic" ;;;; (with-test-prefix "addition" ;;;; (pass-if "integer" (= (+ 2 2) 4)) ;;;; (pass-if "complex" (= (+ 2+3i 4+5i) 6+8i))) ;;;; (with-test-prefix "subtraction" ;;;; (pass-if "integer" (= (- 2 2) 0)) ;;;; (pass-if "complex" (= (- 2+3i 1+2i) 1+1i)))) ;;;; ;;;; The four test names here are: ;;;; ("arithmetic" "addition" "integer") ;;;; ("arithmetic" "addition" "complex") ;;;; ("arithmetic" "subtraction" "integer") ;;;; ("arithmetic" "subtraction" "complex") ;;;; ;;;; To print a name for a human reader, we DISPLAY its elements, ;;;; separated by ": ". So, the last set of test names would be ;;;; reported as: ;;;; ;;;; arithmetic: addition: integer ;;;; arithmetic: addition: complex ;;;; arithmetic: subtraction: integer ;;;; arithmetic: subtraction: complex ;;;; ;;;; The Guile benchmarks use with-test-prefix to include the name of ;;;; the source file containing the test in the test name, to help ;;;; developers to find failing tests, and to provide each file with its ;;;; own namespace. ;;;; REPORTERS ;;;; ;;;; A reporter is a function which we apply to each test outcome. ;;;; Reporters can log results, print interesting results to the ;;;; standard output, collect statistics, etc. ;;;; ;;;; A reporter function takes two mandatory arguments, RESULT and TEST, and ;;;; possibly additional arguments depending on RESULT; its return value ;;;; is ignored. RESULT has one of the following forms: ;;;; ;;;; pass - The test named TEST passed. ;;;; Additional arguments are ignored. ;;;; upass - The test named TEST passed unexpectedly. ;;;; Additional arguments are ignored. ;;;; fail - The test named TEST failed. ;;;; Additional arguments are ignored. ;;;; xfail - The test named TEST failed, as expected. ;;;; Additional arguments are ignored. ;;;; unresolved - The test named TEST did not perform as expected, for ;;;; example the property that was to be tested could not be ;;;; tested because something else went wrong. ;;;; Additional arguments are ignored. ;;;; untested - The test named TEST was not actually performed, for ;;;; example because the test case is not complete yet. ;;;; Additional arguments are ignored. ;;;; unsupported - The test named TEST requires some feature that is not ;;;; available in the configured testing environment. ;;;; Additional arguments are ignored. ;;;; error - An error occurred while the test named TEST was ;;;; performed. Since this result means that the system caught ;;;; an exception it could not handle, the exception arguments ;;;; are passed as additional arguments. ;;;; ;;;; This library provides some standard reporters for logging results ;;;; to a file, reporting interesting results to the user, and ;;;; collecting totals. ;;;; ;;;; You can use the REGISTER-REPORTER function and friends to add ;;;; whatever reporting functions you like. If you don't register any ;;;; reporters, the library uses FULL-REPORTER, which simply writes ;;;; all results to the standard output. ;;;; MISCELLANEOUS ;;;; ;;; Define some exceptions which are commonly being tested for. (define exception:syntax-pattern-unmatched (cons 'syntax-error "source expression failed to match any pattern")) (define exception:bad-variable (cons 'syntax-error "Bad variable")) (define exception:missing-expression (cons 'misc-error "^missing or extra expression")) (define exception:out-of-range (cons 'out-of-range "^.*out of range")) (define exception:unbound-var (cons 'unbound-variable "^Unbound variable")) (define exception:used-before-defined (cons 'unbound-variable "^Variable used before given a value")) (define exception:wrong-num-args (cons 'wrong-number-of-args "^Wrong number of arguments")) (define exception:wrong-type-arg (cons 'wrong-type-arg "^Wrong type")) (define exception:numerical-overflow (cons 'numerical-overflow "^Numerical overflow")) (define exception:struct-set!-denied (cons 'misc-error "^set! denied for field")) (define exception:system-error (cons 'system-error ".*")) (define exception:encoding-error (cons 'encoding-error "(cannot convert.* to output locale|input (locale conversion|decoding) error)")) (define exception:miscellaneous-error (cons 'misc-error "^.*")) (define exception:read-error (cons 'read-error "^.*$")) (define exception:null-pointer-error (cons 'null-pointer-error "^.*$")) (define exception:vm-error (cons 'vm-error "^.*$")) ;; as per throw in scm_to_locale_stringn() (define exception:string-contains-nul (cons 'misc-error "^string contains #\\\\nul character")) ;;; Display all parameters to the default output port, followed by a newline. (define (display-line . objs) (for-each display objs) (newline)) ;;; Display all parameters to the given output port, followed by a newline. (define (display-line-port port . objs) (for-each (lambda (obj) (display obj port)) objs) (newline port)) ;;;; CORE FUNCTIONS ;;;; ;;; The central testing routine. ;;; The idea is taken from Greg, the GNUstep regression test environment. (define run-test (let ((test-running #f)) (lambda (name expect-pass thunk) (if test-running (error "Nested calls to run-test are not permitted.")) (let ((test-name (full-name name))) (set! test-running #t) (catch #t (lambda () (let ((result (thunk))) (if (eq? result #t) (throw 'pass)) (if (eq? result #f) (throw 'fail)) (throw 'unresolved))) (lambda (key . args) (case key ((pass) (report (if expect-pass 'pass 'upass) test-name)) ((fail) ;; ARGS may contain extra info about the failure, ;; such as the expected and actual value. (apply report (if expect-pass 'fail 'xfail) test-name args)) ((unresolved untested unsupported) (report key test-name)) ((quit) (report 'unresolved test-name) (quit)) (else (report 'error test-name (cons key args)))))) (set! test-running #f))))) ;;; A short form for tests that are expected to pass, taken from Greg. (define-syntax pass-if (syntax-rules () ((_ name) ;; presume this is a simple test, i.e. (pass-if (even? 2)) ;; where the body should also be the name. (run-test 'name #t (lambda () name))) ((_ name rest ...) (run-test name #t (lambda () rest ...))))) (define-syntax pass-if-equal (syntax-rules () "Succeed if and only if BODY's return value is equal? to EXPECTED." ((_ expected body) (pass-if-equal 'body expected body)) ((_ name expected body ...) (run-test name #t (lambda () (let ((result (begin body ...))) (or (equal? expected result) (throw 'fail 'expected-value expected 'actual-value result)))))))) ;;; A short form for tests that are expected to fail, taken from Greg. (define-syntax expect-fail (syntax-rules () ((_ name) ;; presume this is a simple test, i.e. (expect-fail (even? 2)) ;; where the body should also be the name. (run-test 'name #f (lambda () name))) ((_ name rest ...) (run-test name #f (lambda () rest ...))))) ;;; A helper function to implement the macros that test for exceptions. (define (run-test-exception name exception expect-pass thunk) (run-test name expect-pass (lambda () (stack-catch (car exception) (lambda () (thunk) #f) (lambda (key proc message . rest) (cond ;; handle explicit key ((string-match (cdr exception) message) #t) ;; handle `(error ...)' which uses `misc-error' for key and doesn't ;; yet format the message and args (we have to do it here). ((and (eq? 'misc-error (car exception)) (list? rest) (string-match (cdr exception) (apply simple-format #f message (car rest)))) #t) ;; handle syntax errors which use `syntax-error' for key and don't ;; yet format the message and args (we have to do it here). ((and (eq? 'syntax-error (car exception)) (list? rest) (string-match (cdr exception) (apply simple-format #f message (car rest)))) #t) ;; unhandled; throw again (else (apply throw key proc message rest)))))))) ;;; A short form for tests that expect a certain exception to be thrown. (define-syntax pass-if-exception (syntax-rules () ((_ name exception body rest ...) (run-test-exception name exception #t (lambda () body rest ...))))) ;;; A short form for tests expected to fail to throw a certain exception. (define-syntax expect-fail-exception (syntax-rules () ((_ name exception body rest ...) (run-test-exception name exception #f (lambda () body rest ...))))) ;;;; TEST NAMES ;;;; ;;;; Turn a test name into a nice human-readable string. (define (format-test-name name) ;; Choose a Unicode-capable encoding so that the string port can contain any ;; valid Unicode character. (with-fluids ((%default-port-encoding "UTF-8")) (call-with-output-string (lambda (port) (let loop ((name name) (separator "")) (if (pair? name) (begin (display separator port) (display (car name) port) (loop (cdr name) ": ")))))))) ;;;; For a given test-name, deliver the full name including all prefixes. (define (full-name name) (append (current-test-prefix) (list name))) ;;; A fluid containing the current test prefix, as a list. (define prefix-fluid (make-fluid '())) (define (current-test-prefix) (fluid-ref prefix-fluid)) ;;; Postpend PREFIX to the current name prefix while evaluting THUNK. ;;; The name prefix is only changed within the dynamic scope of the ;;; call to with-test-prefix*. Return the value returned by THUNK. (define (with-test-prefix* prefix thunk) (with-fluids ((prefix-fluid (append (fluid-ref prefix-fluid) (list prefix)))) (thunk))) ;;; (with-test-prefix PREFIX BODY ...) ;;; Postpend PREFIX to the current name prefix while evaluating BODY ... ;;; The name prefix is only changed within the dynamic scope of the ;;; with-test-prefix expression. Return the value returned by the last ;;; BODY expression. (define-syntax with-test-prefix (syntax-rules () ((_ prefix body ...) (with-test-prefix* prefix (lambda () body ...))))) (define-syntax c&e (syntax-rules (pass-if pass-if-equal pass-if-exception) "Run the given tests both with the evaluator and the compiler/VM." ((_ (pass-if test-name exp)) (begin (pass-if (string-append test-name " (eval)") (primitive-eval 'exp)) (pass-if (string-append test-name " (compile)") (compile 'exp #:to 'value #:env (current-module))))) ((_ (pass-if-equal test-name val exp)) (begin (pass-if-equal (string-append test-name " (eval)") val (primitive-eval 'exp)) (pass-if-equal (string-append test-name " (compile)") val (compile 'exp #:to 'value #:env (current-module))))) ((_ (pass-if-exception test-name exc exp)) (begin (pass-if-exception (string-append test-name " (eval)") exc (primitive-eval 'exp)) (pass-if-exception (string-append test-name " (compile)") exc (compile 'exp #:to 'value #:env (current-module))))))) ;;; (with-test-prefix/c&e PREFIX BODY ...) ;;; Same as `with-test-prefix', but the enclosed tests are run both with ;;; the compiler/VM and the evaluator. (define-syntax with-test-prefix/c&e (syntax-rules () ((_ section-name exp ...) (with-test-prefix section-name (c&e exp) ...)))) ;;; Call THUNK using the debugging evaluator. (define (with-debugging-evaluator* thunk) (let ((dopts #f)) (dynamic-wind (lambda () (set! dopts (debug-options))) thunk (lambda () (debug-options dopts))))) ;;; Evaluate BODY... using the debugging evaluator. (define-macro (with-debugging-evaluator . body) `(with-debugging-evaluator* (lambda () ,@body))) ;; Recurse through a C function that should clear any values that might ;; have spilled on the stack temporarily. (The salient feature of ;; with-continuation-barrier is that currently it is implemented as a C ;; function that recursively calls the VM.) ;; (define* (clear-stale-stack-references #:optional (n 10)) (if (positive? n) (with-continuation-barrier (lambda () (clear-stale-stack-references (1- n)))))) ;;; Call THUNK with a given locale (define (with-locale* nloc thunk) (let ((loc #f)) (dynamic-wind (lambda () (if (defined? 'setlocale) (begin (set! loc (false-if-exception (setlocale LC_ALL))) (if (or (not loc) (not (false-if-exception (setlocale LC_ALL nloc)))) (throw 'unresolved))) (throw 'unresolved))) thunk (lambda () (if (and (defined? 'setlocale) loc) (setlocale LC_ALL loc)))))) ;;; Evaluate BODY... using the given locale. (define-syntax with-locale (syntax-rules () ((_ loc body ...) (with-locale* loc (lambda () body ...))))) ;;; Try out several ISO-8859-1 locales and run THUNK under the one that works ;;; (if any). (define (with-latin1-locale* thunk) (define %locales (append-map (lambda (name) (list (string-append name ".ISO-8859-1") (string-append name ".iso88591") (string-append name ".ISO8859-1"))) '("ca_ES" "da_DK" "de_DE" "es_ES" "es_MX" "en_GB" "en_US" "fr_FR" "pt_PT" "nl_NL" "sv_SE"))) (let loop ((locales %locales)) (if (null? locales) (throw 'unresolved) (catch 'unresolved (lambda () (with-locale* (car locales) thunk)) (lambda (key . args) (loop (cdr locales))))))) ;;; Evaluate BODY... using an ISO-8859-1 locale or throw `unresolved' if none ;;; was found. (define-syntax with-latin1-locale (syntax-rules () ((_ body ...) (with-latin1-locale* (lambda () body ...))))) (define %null-device ;; On Windows (MinGW), /dev/null does not exist and we must instead ;; use NUL. Note that file system procedures automatically translate ;; /dev/null, so this variable is only useful for shell snippets. ;; Test for Windowsness by checking whether the current directory name ;; starts with a drive letter. (if (string-match "^[a-zA-Z]:[/\\]" (getcwd)) "NUL" "/dev/null")) ;;;; REPORTERS ;;;; ;;; The global list of reporters. (define reporters '()) ;;; The default reporter, to be used only if no others exist. (define default-reporter #f) ;;; Add the procedure REPORTER to the current set of reporter functions. ;;; Signal an error if that reporter procedure object is already registered. (define (register-reporter reporter) (if (memq reporter reporters) (error "register-reporter: reporter already registered: " reporter)) (set! reporters (cons reporter reporters))) ;;; Remove the procedure REPORTER from the current set of reporter ;;; functions. Signal an error if REPORTER is not currently registered. (define (unregister-reporter reporter) (if (memq reporter reporters) (set! reporters (delq! reporter reporters)) (error "unregister-reporter: reporter not registered: " reporter))) ;;; Return true iff REPORTER is in the current set of reporter functions. (define (reporter-registered? reporter) (if (memq reporter reporters) #t #f)) ;;; Send RESULT to all currently registered reporter functions. (define (report . args) (if (pair? reporters) (for-each (lambda (reporter) (apply reporter args)) reporters) (apply default-reporter args))) ;;;; Some useful standard reporters: ;;;; Count reporters count the occurrence of each test result type. ;;;; Log reporters write all test results to a given log file. ;;;; Full reporters write all test results to the standard output. ;;;; User reporters write interesting test results to the standard output. ;;; The complete list of possible test results. (define result-tags '((pass "PASS" "passes: ") (fail "FAIL" "failures: ") (upass "UPASS" "unexpected passes: ") (xfail "XFAIL" "expected failures: ") (unresolved "UNRESOLVED" "unresolved test cases: ") (untested "UNTESTED" "untested test cases: ") (unsupported "UNSUPPORTED" "unsupported test cases: ") (error "ERROR" "errors: "))) ;;; The list of important test results. (define important-result-tags '(fail upass unresolved error)) ;;; Display a single test result in formatted form to the given port (define (print-result port result name . args) (let* ((tag (assq result result-tags)) (label (if tag (cadr tag) #f))) (if label (begin (display label port) (display ": " port) (display (format-test-name name) port) (if (pair? args) (begin (display " - arguments: " port) (write args port))) (newline port)) (error "(test-suite lib) FULL-REPORTER: unrecognized result: " result)))) ;;; Return a list of the form (COUNTER RESULTS), where: ;;; - COUNTER is a reporter procedure, and ;;; - RESULTS is a procedure taking no arguments which returns the ;;; results seen so far by COUNTER. The return value is an alist ;;; mapping outcome symbols (`pass', `fail', etc.) onto counts. (define (make-count-reporter) (let ((counts (map (lambda (tag) (cons (car tag) 0)) result-tags))) (list (lambda (result name . args) (let ((pair (assq result counts))) (if pair (set-cdr! pair (+ 1 (cdr pair))) (error "count-reporter: unexpected test result: " (cons result (cons name args)))))) (lambda () (append counts '()))))) ;;; Print a count reporter's results nicely. Pass this function the value ;;; returned by a count reporter's RESULTS procedure. (define (print-counts results . port?) (let ((port (if (pair? port?) (car port?) (current-output-port)))) (newline port) (display-line-port port "Totals for this test run:") (for-each (lambda (tag) (let ((result (assq (car tag) results))) (if result (display-line-port port (caddr tag) (cdr result)) (display-line-port port "Test suite bug: " "no total available for `" (car tag) "'")))) result-tags) (newline port))) ;;; Return a reporter procedure which prints all results to the file ;;; FILE, in human-readable form. FILE may be a filename, or a port. (define (make-log-reporter file) (let ((port (if (output-port? file) file (open-output-file file)))) (lambda args (apply print-result port args) (force-output port)))) ;;; A reporter that reports all results to the user. (define (full-reporter . args) (apply print-result (current-output-port) args)) ;;; A reporter procedure which shows interesting results (failures, ;;; unexpected passes etc.) to the user. (define (user-reporter result name . args) (if (memq result important-result-tags) (apply full-reporter result name args))) (set! default-reporter full-reporter) nyacc-1.00.2/test-suite/env.sh0000644000175100000240000000041313605250515015643 0ustar mwettedialout#!/bin/sh # source this file: $ . env.sh topdir=`(cd ..; pwd)` if [ "X$GUILE_LOAD_PATH" = "X" ]; then GUILE_LOAD_PATH=$topdir/module else GUILE_LOAD_PATH=$topdir/module:$GUILE_LOAD_PATH fi; GUILE_LOAD_PATH=$topdir/test-suite:$GUILE_LOAD_PATH export GUILE_LOAD_PATH nyacc-1.00.2/test-suite/nyacc/0000755000175100000240000000000013605250515015616 5ustar mwettedialoutnyacc-1.00.2/test-suite/nyacc/lalr-01.test0000644000175100000240000000566213605250515017700 0ustar mwettedialout;; nyacc/lalr-01.test -*- scheme -*- ;; ;; Copyright (C) 2015,2016 Matthew R. Wette ;; ;; Copying and distribution of this file, with or without modification, ;; are permitted in any medium without royalty provided the copyright ;; notice and this notice are preserved. This file is offered as-is, ;; without any warranty. (define-module (lalr-01) #:use-module (nyacc lalr) #:use-module (nyacc parse) #:use-module (nyacc lex) #:use-module (test-suite lib)) (define calc-spec (lalr-spec (prec< (left "+" "-") (left "*" "/")) (start expr) (grammar (expr (expr "+" expr ($$ (+ $1 $3))) (expr "-" expr ($$ (- $1 $3))) (expr "*" expr ($$ (* $1 $3))) (expr "/" expr ($$ (/ $1 $3))) ($fixed ($$ (string->number $1)))) ))) (define calc-mach (make-lalr-machine calc-spec)) (define input-1 "1 + 4 / 2 * 3 - 5") (define output-1 2) (with-test-prefix "nyacc/lalr-01" (pass-if "calc-plain" (let* ((mach calc-mach) (raw-parser (make-lalr-parser mach)) (gen-lxr (make-lexer-generator (assq-ref mach 'mtab))) (parse (lambda () (raw-parser (gen-lxr)))) (res (with-input-from-string input-1 parse))) (equal? res output-1))) (pass-if "calc-hashify" (let* ((mach (hashify-machine calc-mach)) (raw-parser (make-lalr-parser mach)) (gen-lxr (make-lexer-generator (assq-ref mach 'mtab))) (parse (lambda () (raw-parser (gen-lxr)))) (res (with-input-from-string input-1 parse))) (equal? res output-1))) (pass-if "calc-compact" (let* ((mach (compact-machine calc-mach)) (raw-parser (make-lalr-parser mach)) (gen-lxr (make-lexer-generator (assq-ref mach 'mtab))) (parse (lambda () (raw-parser (gen-lxr)))) (res (with-input-from-string input-1 parse))) (equal? res output-1))) (pass-if "calc-compact-hashify" (let* ((mach (compact-machine (hashify-machine calc-mach))) (raw-parser (make-lalr-parser mach)) (gen-lxr (make-lexer-generator (assq-ref mach 'mtab))) (parse (lambda () (raw-parser (gen-lxr)))) (res (with-input-from-string input-1 parse))) (equal? res output-1))) (pass-if "calc-hashify-compact" (let* ((mach (hashify-machine (compact-machine calc-mach))) (raw-parser (make-lalr-parser mach)) (gen-lxr (make-lexer-generator (assq-ref mach 'mtab))) (parse (lambda () (raw-parser (gen-lxr)))) (res (with-input-from-string input-1 parse))) (equal? res output-1))) ;; not working: ;; ERROR: nyacc/lalr-01: parse-error - arguments: ;; ((wrong-type-arg "car" "Wrong type argument in position ~A (expecting ~A): ;; ~S" (1 "pair" 0) (0))) #;(expect-fail "parse-error" (let* ((mach calc-mach) (raw-parser (make-lalr-parser mach)) (gen-lxr (make-lexer-generator (assq-ref mach 'mtab))) (parse (lambda () (catch 'parse-error (lambda () (raw-parser (gen-lxr))) (lambda () #f))))) (with-input-from-string "a = 1" parse))) ) ;; --- last line --- nyacc-1.00.2/test-suite/nyacc/tmpl.test0000644000175100000240000000074613605250515017502 0ustar mwettedialout;; nyacc/tmpl.test -*- scheme -*- ;; ;; Copyright (C) 2015,2016 Matthew R. Wette ;; ;; Copying and distribution of this file, with or without modification, ;; are permitted in any medium without royalty provided the copyright ;; notice and this notice are preserved. This file is offered as-is, ;; without any warranty. (define-module (tmpl) #:use-module (test-suite lib)) (with-test-prefix "nyacc/tmpl" (pass-if "easy test" (let* () #t)) ) ;; --- last line --- nyacc-1.00.2/test-suite/nyacc/lex-01.test0000644000175100000240000000673713605250515017542 0ustar mwettedialout;; nyacc/lex-01.test -*- scheme -*- ;; ;; Copyright (C) 2015,2017,2019 Matthew R. Wette ;; ;; Copying and distribution of this file, with or without modification, ;; are permitted in any medium without royalty provided the copyright ;; notice and this notice are preserved. This file is offered as-is, ;; without any warranty. (define-module (lex-01) #:use-module (nyacc lex) #:use-module ((srfi srfi-1) #:select (fold)) #:use-module (test-suite lib)) ;; not used (define mt (list '("<=" . lteq) '(">=" . gteq) '("==" . eqeq) '("<>" . ltgt) '(".+" . dot-plus) '(".-" . dot-minus) '(".*" . dot-times) '("./" . dot-divide) '(".^" . dot-carat) '(":=" . colon-eq) '(class . class) )) (define read-comm-1 (make-comm-reader '(("/*" . "*/") ("//" . "\n")))) (with-test-prefix "nyacc/lex-01" ;; escape character (pass-if "C char literals" (fold (lambda (pair pass) (and pass (string=? (with-input-from-string (car pair) (lambda () (or (and=> (read-c-chlit (read-char)) cdr) ""))) (cdr pair)))) #t '(("'\\177'" . "\x7f") ))) (pass-if "C integer literals" (fold (lambda (pair pass) (and pass (with-input-from-string (car pair) (lambda () (let* ((p (read-c-num (read-char))) (t (and=> p car)) (r (and=> p cdr))) (and p (eq? t '$fixed) (string=? r (cdr pair)))))))) #t '(("123" . "123") ("1l" . "1l") ("23u" . "23u") ("34ull" . "34ull") ("0b11" . "0b11") ))) (pass-if "C floating-point literals" (fold (lambda (pair pass) (and pass (with-input-from-string (car pair) (lambda () (let* ((p (read-c-num (read-char))) (t (and=> p car)) (r (and=> p cdr))) (and p (eq? t '$float) (string=? r (cdr pair)))))))) #t '(("12.34" . "12.34") ("12.34e56" . "12.34e56") ("12.34E56" . "12.34E56") ("12.34e+56" . "12.34e+56") ("12.34d-6" . "12.34d-6") ("12.34D-6" . "12.34D-6") ("1." . "1.") (".1" . ".1") (".1e0" . ".1e0") ))) (pass-if "C fixed-point literals" (fold (lambda (pair pass) (and pass (with-input-from-string (car pair) (lambda () (let* ((p (read-c-num (read-char))) (t (and=> p car)) (r (and=> p cdr))) (and p (eq? t '$fixpt) (string=? r (cdr pair)))))))) #t '(("0.25r" . "0.25r") ("0.25ur" . "0.25ur") ;;("0.25lr" . "0.25lr") ;;("0.0078125HR" . "0.0078125HR") ;;("1r" . "1r") ))) (pass-if "C strings" (fold (lambda (pair pass) (and pass (string=? (with-input-from-string (car pair) (lambda () (or (and=> (read-c-string (read-char)) cdr) ""))) (cdr pair)))) #t '(("\"\\177\"" . "\x7f") ))) ;; Check that comment ending in newline does not eat the newline. (pass-if "C comments" (with-input-from-string "//abc\ndef" (lambda () (let* ((tp (read-comm-1 (read-char) #f)) (ch (read-char))) (and (equal? tp '($code-comm . "abc")) (equal? ch #\newline)))))) ;; C99 number string to Scheme number string (which works w/ string->number) (pass-if "C num to Scheme num (as strings)" (fold (lambda (pair pass) (and pass (string=? (cnumstr->scm (car pair)) (cdr pair)))) #t '(("0L" . "0") ("01l" . "#o1") ("0LL" . "0") ("0xa" . "#xa") ("0b11" . "#b11") ("0123" . "#o123") ("1234" . "1234") ("0.1e10" . "0.1e10")))) ) ;; --- last line --- nyacc-1.00.2/test-suite/nyacc/ChangeLog0000644000175100000240000000041013605250515017363 0ustar mwettedialout Copyright (C) 2017 Matthew R. Wette Copying and distribution of this file, with or without modification, are permitted in any medium without royalty provided the copyright notice and this notice are preserved. This file is offered as-is, without any warranty. nyacc-1.00.2/test-suite/nyacc/lang/0000755000175100000240000000000013605250515016537 5ustar mwettedialoutnyacc-1.00.2/test-suite/nyacc/lang/sx-util.test0000644000175100000240000000547713605250515021062 0ustar mwettedialout;;; nyacc/lang/sx-util.test -*- scheme -*- ;;; ;;; Copyright (C) 2017-2018 Matthew R. Wette ;;; ;;; Copying and distribution of this file, with or without modification, ;;; are permitted in any medium without royalty provided the copyright ;;; notice and this notice are preserved. This file is offered as-is, ;;; without any warranty. (define-module (sx-util) #:use-module (nyacc lang sx-util)) (cond-expand (guile-2 (use-modules (test-suite lib))) (else (use-modules (test-suite lib18)) (use-modules (nyacc compat18)))) (use-modules (ice-9 pretty-print)) (with-test-prefix "nyacc/sx-match" (pass-if "basics" (and (sx-match '(foo (bar)) (else #t)) (sx-match '(foo "hello") ((foo ,_) #t) (,_ #f)) (sx-match '(foo "hello") ((foo ,_) #t) (else #f)) (sx-match '(foo (bar (baz))) ((foo (bar (baz))) #t) (else #f)) (sx-match '(foo (bar)) ((foo ,nd) (equal? '(bar) nd)) (else #f)) (sx-match '(foo) ((foo . ,_) #t) (else #f)) #t)) (pass-if "w/ val attr, w/ pat attr" (and (sx-match '(foo (@ (a "1") (b "2"))) ((foo (@ . ,al)) #t) (else #f)) (sx-match '(foo (@ (a "1")) "hello") ((foo (@ . ,al) . ,rest) #t) (else #f)) (sx-match '(foo (@) (bar "baz") "hello") ((foo (bar (@ . ,al) . ,text) . ,rest) #t) (else #f)) (sx-match '(foo (bar (@ (a "1")) "baz") "hello") ((foo (@ . ,al) (bar . ,text) . ,rest) #t) (else #f)) #t)) (pass-if "no val attr, w/ pat attr" (and (sx-match '(foo) ((foo (@ . ,al)) #t) (else #f)) (sx-match '(foo "hello") ((foo (@ . ,al) . ,rest) #t) (else #f)) (sx-match '(foo (bar "baz") "hello") ((foo (bar (@ . ,al) . ,text) . ,rest) #t) (else #f)) (sx-match '(foo (bar "baz") "hello") ((foo (@ . ,al) (bar . ,text) . ,rest) #t) (else #f)) #t)) (pass-if "w/ val attr, no pat attr" (and (sx-match '(foo (@ (a "1") (b "2"))) ((foo) #t) (else #f)) (sx-match '(foo (@ (a "1")) "hello") ((foo . ,rest) #t) (else #f)) (sx-match '(foo (@) (bar "baz") "hello") ((foo (bar . ,text) . ,rest) #t) (else #f)) (sx-match '(foo (bar (@ (a "1")) "baz") "hello") ((foo (bar . ,text) . ,rest) #t) (else #f)) #t)) (pass-if "no val attr, no pat attr" (and (sx-match '(foo) ((foo) #t) (else #f)) (sx-match '(foo "hello") ((foo . ,rest) #t) (else #f)) (sx-match '(foo (bar "baz") "hello") ((foo (bar . ,text) . ,rest) #t) (else #f)) #t)) (pass-if "more random tests" (and ;;(sx-match '(foo "abc" "def") ((foo (bar . *)) #f) (else #t)) (sx-match '(foo "hi") ((foo ,greet) (string=? greet "hi")) (else #f)) (sx-match '(foo "hi") ((foo . ,rest) (string=? (car rest) "hi")) (else #f)) (sx-match '(foo "hi") ((foo "bar") #f) ((foo "hi") #t) (else #f)) #t)) ) ;;; --- last line --- nyacc-1.00.2/test-suite/nyacc/lang/util.test0000644000175100000240000000450713605250515020423 0ustar mwettedialout;;; nyacc/lang/util.test -*- scheme -*- ;;; ;;; Copyright (C) 2015,2016 Matthew R. Wette ;;; ;;; Copying and distribution of this file, with or without modification, ;;; are permitted in any medium without royalty provided the copyright ;;; notice and this notice are preserved. This file is offered as-is, ;;; without any warranty. ;; Test the runtime parsing utilities. ;; examples/nyacc$ guile lang/t-util.scm (define-module (util) #:use-module (nyacc lang util) #:use-module (test-suite lib)) (cond-expand (guile-2 #t) (else (use-modules (nyacc compat18)))) (with-test-prefix "nyacc/util" ;; The input-stack used to pull in input from include files. (pass-if "input-stack/1" (equal? "hello world!" (with-output-to-string (lambda () (with-input-from-string "hello X!" (lambda () (let iter ((ch (read-char))) (unless (eq? ch #\X) (write-char ch) (iter (read-char)))) (push-input (open-input-string "world")) (let iter ((ch (read-char))) (unless (eof-object? ch) (write-char ch) (iter (read-char)))) (pop-input) (let iter ((ch (read-char))) (unless (eof-object? ch) (write-char ch) (iter (read-char)))) )))))) ;; Should return #t if something there and #f if done. (pass-if "input-stack/2" (let ((sp (open-input-string "abc"))) (reset-input-stack) ;; maybe with-dynamic-extent (push-input sp) (and (pop-input) (not (pop-input))))) #! (pass-if "test1" (let* ((tl0 (make-tl 'abc 1)) (tl1 (tl-append tl0 2)) (tl2 (tl-insert tl1 'a)) (tl3 (tl+attr tl2 'x "true")) (tl4 (tl-append tl3 20 25)) (tl5 (tl-insert tl4 'z)) (tlx tl5)) (equal? (tl->list tlx) '(abc (@ (x "true")) z a 1 2 20 25)))) !# #! (pass-if "test2" (let* ((tl (make-tl 'abc 1))) (set! tl (tl-append tl 2)) (set! tl (tl-insert tl 'a)) (set! tl (tl+attr tl 'x "true")) (set! tl (tl-append tl 20)) (set! tl (tl+attr tl 'y "true")) (set! tl (tl-append tl 30)) (set! tl (tl+attr tl 'z "true")) (set! tl (tl-append tl 40)) (set! tl (tl-extend tl '(a b c))) (set! tl (tl-insert tl 'YYY)) (set! tl (tl-append tl 'ZZZ)) (equal? (tl->list tl) '(abc (@ (x "true") (y "true") (z "true")) YYY a 1 2 20 30 40 a b c ZZZ)))) !# ) ;;; --- last line --- nyacc-1.00.2/test-suite/nyacc/lang/c99/0000755000175100000240000000000013605250515017143 5ustar mwettedialoutnyacc-1.00.2/test-suite/nyacc/lang/c99/exam.d/0000755000175100000240000000000013605250515020317 5ustar mwettedialoutnyacc-1.00.2/test-suite/nyacc/lang/c99/exam.d/ex07.c0000644000175100000240000000007513605250515021250 0ustar mwettedialoutint foo () { int r = 1; #include "ex07.i" return r; } nyacc-1.00.2/test-suite/nyacc/lang/c99/exam.d/ex14.c0000644000175100000240000000015113605250515021241 0ustar mwettedialout#ifndef ABC #include "ex14.h" #define ABC #endif #ifdef ABC eval_t x; #endif /* used by c99-04.test */ nyacc-1.00.2/test-suite/nyacc/lang/c99/exam.d/ex04.c0000644000175100000240000000011413605250515021237 0ustar mwettedialout #define FOO \ int a; \ int b; //FOO #define BAR(A,B) int A; double B; nyacc-1.00.2/test-suite/nyacc/lang/c99/exam.d/ex20.c0000644000175100000240000000253113605250515021242 0ustar mwettedialout/* ex20.c -- test of attribute-specifiers */ struct __packed__ case01 { int x; double y; }; struct __packed__ case02; typedef struct __packed__ { int *ip; double x; } case03; typedef int case04 __attribute__ ((__deprecated__)); extern double case05(int x) __attribute__ ((__nothrow__, __leaf__)) __attribute__ ((__const__)); void (__attribute__((noreturn)) ****case06) (void); char *__attribute__((aligned(8))) *case07; int case08 __attribute__ ((aligned (16))) = 0; __attribute__((noreturn)) void case09 (void), __attribute__((format(printf, 1, 2))) case10 (const char *, ...), case11 (void); int case12 __attribute__((io(0x123))); struct case13 __attribute__ ((vector_size (16))) case14; struct case14 { char a; int x[2] __attribute__ ((packed)); }; struct case15 { int x[2] __attribute__ ((aligned (8))); }; short case16[3] __attribute__ ((aligned (__BIGGEST_ALIGNMENT__))); struct event { int events; void *data; } __attribute__ ((__packed__)); typedef struct { long long __max_align_ll __attribute__((__aligned__(__alignof__(long long)))); long double __max_align_ld __attribute__((__aligned__(__alignof__(long double)))); } max_align_t; int sscanf (const char *__restrict __s, const char *__restrict __format, ...) __asm__ ( "" "__isoc99_sscanf") __attribute__ ((__nothrow__ , __leaf__)); /* --- last line --- */ nyacc-1.00.2/test-suite/nyacc/lang/c99/exam.d/ex19.c0000644000175100000240000000022113605250515021244 0ustar mwettedialout int bar(int x) { typedef int foo_t; foo_t y = 1; return x + y; } int baz(int x) { typedef int foo_t; foo_t y = 1; return x + y; } nyacc-1.00.2/test-suite/nyacc/lang/c99/exam.d/ex09.c0000644000175100000240000000012013605250515021241 0ustar mwettedialout #define A 1 #define B(X) ((X)+1) #if B(2) == C int y; #else double y; #endif nyacc-1.00.2/test-suite/nyacc/lang/c99/exam.d/inc.h0000644000175100000240000000100313605250515021233 0ustar mwettedialout// inc.h #ifndef __inc_h__ #define __inc_h__ #ifdef A typedef enum { EA_ZERO = 0, EA_ONE, EA_TWO = 2 } eval_t; #elif defined(B) typedef enum { EB_ZERO = 0, EB_ONE, EB_TWO = 2 } eval_t; #else typedef enum { EC_ZERO = 0, EC_ONE, EC_TWO = 2 } eval_t; #endif typedef enum { ZZ_ZERO = 0, /* comment */ ZZ_ONE, ZZ_TWO = 2 } zz_t; typedef struct { int ix; /* comment for ix */ double c[4]; /* comment for c */ } ex1_t; /* Initialize ex1 object. */ int ex1_init(void*); #endif /* last line */ nyacc-1.00.2/test-suite/nyacc/lang/c99/exam.d/ex05.c0000644000175100000240000000073213605250515021246 0ustar mwettedialout// C99 run-through int x; int x,y; int x=1, y, z = 3; struct struct1 { int x; double d; }; union { int x; double d; } u1; typedef struct { int x; struct struct1 z; } tdef1_t; typedef struct zzz { int x; tdef1_t z; } tdef2_t; int foo(int x, int /* hello */); int foo(char *x) { int j; for (int i = 0; i < 32; i++) { j = 1; while (j < 3) { j += i; } } if (i > 2) { return 4; } else { return 9; } } /* --- last line --- */ nyacc-1.00.2/test-suite/nyacc/lang/c99/exam.d/ex02.c0000644000175100000240000000035413605250515021243 0ustar mwettedialout// /* hello */ #define XYZ 1 /* lame comment */ int x; /* hello */ int /* zoo */ foo /* z */(/* t */ int /* comment */ x) /* x */ { int /* hello */ y /* 8 */ = /* 9 */ 3; return /* 1 */ x /* 2 */ + /* 3 */ y /* 4 */; /* 5 */ } nyacc-1.00.2/test-suite/nyacc/lang/c99/exam.d/ex14.h0000644000175100000240000000002413605250515021245 0ustar mwettedialouttypedef int eval_t; nyacc-1.00.2/test-suite/nyacc/lang/c99/exam.d/ex13.c0000644000175100000240000000025413605250515021244 0ustar mwettedialout#if defined ABC #endif #if defined ABC /* hello */ #endif #if defined(ABC) #endif #if defined( ABC ) #endif #if defined ( ABC ) #endif #if defined ( ABC ) /* abc */ #endif nyacc-1.00.2/test-suite/nyacc/lang/c99/exam.d/ex18.c0000644000175100000240000000020413605250515021244 0ustar mwettedialout#define ELF32_ST_INFO(bind, type) (((bind) << 4) + ((type) & 0xf)) #define ELFW(type) ELF##32##_##type int x = ELFW(ST_INFO)(1, 0); nyacc-1.00.2/test-suite/nyacc/lang/c99/exam.d/ex10.c0000644000175100000240000000003713605250515021240 0ustar mwettedialout#include int32_t x; nyacc-1.00.2/test-suite/nyacc/lang/c99/exam.d/ex16.h0000644000175100000240000000012113605250515021245 0ustar mwettedialout#define __builtin_va_list void* #define __DARWIN_ALIAS(X) /* */ #include "inc.h" nyacc-1.00.2/test-suite/nyacc/lang/c99/exam.d/ex12.c0000644000175100000240000000033613605250515021244 0ustar mwettedialout#define foo1( X , Y ) ((X)*(Y)) #define foo(A,B,...) foo1(A,B)+bar(0, A, B, __VA_ARGS__) int x = foo(1, 2, 3, 4, foo1(2,3)); #define fix1(x) #x static char* y = fix1(bar); #define fix2(X) ex12_ ## X int z = fix2(abc2); nyacc-1.00.2/test-suite/nyacc/lang/c99/exam.d/ex15.c0000644000175100000240000000004113605250515021240 0ustar mwettedialout#define FOO "inc.h" #include FOO nyacc-1.00.2/test-suite/nyacc/lang/c99/exam.d/ex06.c0000644000175100000240000000013013605250515021237 0ustar mwettedialout// pretty-print oddities int foo(int x) { do { x = x + 1; } while (x < 10); } nyacc-1.00.2/test-suite/nyacc/lang/c99/exam.d/README0000644000175100000240000000104213605250515021174 0ustar mwettedialout Copyright (C) 2016-2017 Matthew R. Wette Copying and distribution of the files in this directory, with or without modification, are permitted in any medium without royalty provided the copyright notice and this notice are preserved. This file is offered as-is, without any warranty. ex01.c random file ex02.c comments ex03.c lexical analyzer ex04.c C preprocessor ex05.c declarations ex06.c pretty-print-c99 cases ex15.c c99-01.test: #defined #include target ex16.h include/include no C stmts inc.h sample include used by ... nyacc-1.00.2/test-suite/nyacc/lang/c99/exam.d/ex08.c0000644000175100000240000000012213605250515021242 0ustar mwettedialout#define assert(x) ((x) ? (void)0 : assert_fail (#x)) int foo() { assert(boo); } nyacc-1.00.2/test-suite/nyacc/lang/c99/exam.d/ex11.c0000644000175100000240000000014313605250515021237 0ustar mwettedialout/*Begin C Code*/ #if defined __HAB__ #define __HAB__ #endif #define A 1 int a = A; /*end C code*/ nyacc-1.00.2/test-suite/nyacc/lang/c99/exam.d/ex03.c0000644000175100000240000000002713605250515021241 0ustar mwettedialout// lex int x; \ int y; nyacc-1.00.2/test-suite/nyacc/lang/c99/exam.d/ex17.c0000644000175100000240000000034113605250515021245 0ustar mwettedialout// provided by Jan Nieuwenhuizen // worked in 0.80.4, broken in 0.82.1 #define DEF_BWL(x) DEF(TOK_ASM_ ## x, #x) #define DEF_BWLX DEF_BWL enum tcc_token { TOK_LAST #define DEF(id, str) ,id DEF_BWLX(mov) #undef DEF }; nyacc-1.00.2/test-suite/nyacc/lang/c99/exam.d/ex01.c0000644000175100000240000000126613605250515021245 0ustar mwettedialout// ex1.c #ifdef __cplusplus__ extern "C" { #endif #include "inc.h" #define A 1 #define B(X) ((X)+1) #ifdef A int y; #elif defined(B) /* check */ double y; #else /* else */ #error "foo" #endif /* def A */ eval_t x; struct foo; int d = 0x123; /* d comment */ float f = 0.0; const volatile int * const * foo = 0; #define OFFSET(T,V) (((T*)0)->V) typedef struct { /* hello */ eval_t x; /* comment */ int y; } xyz_t; typedef struct zippy { double z[2]; } zip_t; int foo(int y) { double d; if (y > 0) { d = +1.0; } else if (y == 0) { d = 0.0; } else { d = -1.0; } return 1; } /* this is lone comment */ #ifdef __cplusplus__ } #endif /* --- last line --- */ nyacc-1.00.2/test-suite/nyacc/lang/c99/exam.d/ex07.i0000644000175100000240000000001313605250515021246 0ustar mwettedialoutr = r + 1; nyacc-1.00.2/test-suite/nyacc/lang/c99/exam.d/ex21.c0000644000175100000240000000110713605250515021241 0ustar mwettedialoutint sscanf (const char *__restrict __s, const char *__restrict __format, ...) __asm__ ( "" "__isoc99_sscanf"); int foo1() { __asm__ ( "idivl %[divsrc]" : "=a" (quotient), "=d" (rem) : "d" (hi), "a" (lo), [divsrc] "rm" (divisor) : ); } int foo2() { __asm ( "idivl %[divsrc]" : "=a" (quotient), "=d" (rem) : "d" (hi), "a" (lo), [divsrc] "rm" (divisor) : ); } int foo3() { asm ( "idivl %[divsrc]" : "=a" (quotient), "=d" (rem) : "d" (hi), "a" (lo), [divsrc] "rm" (divisor) : ); } nyacc-1.00.2/test-suite/nyacc/lang/c99/c99-01.test0000644000175100000240000001623213605250515020672 0ustar mwettedialout;; nyacc/lang/c99/c99-01.test -*- scheme -*- ;; ;; Copyright (C) 2017 Matthew R. Wette ;; ;; Copying and distribution of this file, with or without modification, ;; are permitted in any medium without royalty provided the copyright ;; notice and this notice are preserved. This file is offered as-is, ;; without any warranty. ;; CPP tests (define-module (c99-01) #:use-module (nyacc lang c99 parser) #:use-module (test-suite lib)) (use-modules (ice-9 pretty-print)) (define incs '("exam.d")) (define (parse-file file) (with-input-from-file file (lambda () (parse-c99 #:inc-dirs incs #:mode 'code)))) (define (parse-string str) (with-input-from-string str (lambda () ;;(simple-format #t "\n~A\n" str) (parse-c99 #:inc-dirs incs #:mode 'code)))) (define (parse-string-list . str-l) (parse-string (apply string-append str-l))) ;; parser test (with-test-prefix "nyacc/c99-01, CPP" ;; add ex04.c ;; Get a simple statement to parse. (pass-if "include in place" (equal? (parse-file "exam.d/ex07.c") '(trans-unit (fctn-defn (decl-spec-list (type-spec (fixed-type "int"))) (ftn-declr (ident "foo") (param-list)) (compd-stmt (block-item-list (decl (decl-spec-list (type-spec (fixed-type "int"))) (init-declr-list (init-declr (ident "r") (initzer (p-expr (fixed "1")))))) (expr-stmt (assn-expr (p-expr (ident "r")) (op "=") (add (p-expr (ident "r")) (p-expr (fixed "1"))))) (return (p-expr (ident "r"))))))))) (pass-if "skip space and #" (equal? (parse-file "exam.d/ex08.c") '(trans-unit (fctn-defn (decl-spec-list (type-spec (fixed-type "int"))) (ftn-declr (ident "foo") (param-list)) (compd-stmt (block-item-list (expr-stmt (cond-expr (p-expr (ident "boo")) (cast (type-name (decl-spec-list (type-spec (void)))) (p-expr (fixed "0"))) (fctn-call (p-expr (ident "assert_fail")) (expr-list (p-expr (string "boo")))))))))))) (pass-if "#, ##, __VA_ARGS__" (equal? (parse-file "exam.d/ex12.c") '(trans-unit (decl (decl-spec-list (type-spec (fixed-type "int"))) (init-declr-list (init-declr (ident "x") (initzer (add (mul (p-expr (fixed "1")) (p-expr (fixed "2"))) (fctn-call (p-expr (ident "bar")) (expr-list (p-expr (fixed "0")) (p-expr (fixed "1")) (p-expr (fixed "2")) (p-expr (fixed "3")) (p-expr (fixed "4")) (mul (p-expr (fixed "2")) (p-expr (fixed "3")))))))))) (decl (decl-spec-list (stor-spec (static)) (type-spec (fixed-type "char"))) (init-declr-list (init-declr (ptr-declr (pointer) (ident "y")) (initzer (p-expr (string "bar")))))) (decl (decl-spec-list (type-spec (fixed-type "int"))) (init-declr-list (init-declr (ident "z") (initzer (p-expr (ident "ex12_abc2"))))))))) (pass-if "spacing in tokenization" (let ((sx1 (parse-string "#define foo(X) # X\nchar *s = foo(abc def);\n")) (sx2 (parse-string "#define foo(X) # X\nchar *s = foo(abc def);\n"))) (equal? sx1 sx2))) (pass-if "def-def-ref" (equal? (parse-string-list "#define A 123\n" "#define B A\n" "#if B > 0\n" "int x;\n" "#else\n" "char x;\n" "#endif\n") '(trans-unit (decl (decl-spec-list (type-spec (fixed-type "int"))) (init-declr-list (init-declr (ident "x"))))))) (pass-if "repeat in arg" (equal? (parse-string-list "#define bar(x,y) foo(x,y)\n" "#define foo(x,y) bar(x,y)\n" "#define FOO(x,y) foo(x,y)\n" "int x = FOO(FOO(1,2),3);\n") '(trans-unit (decl (decl-spec-list (type-spec (fixed-type "int"))) (init-declr-list (init-declr (ident "x") (initzer (fctn-call (p-expr (ident "foo")) (expr-list (fctn-call (p-expr (ident "foo")) (expr-list (p-expr (fixed "1")) (p-expr (fixed "2")))) (p-expr (fixed "3"))))))))))) (pass-if "multiple" (and (equal? (parse-string "#define inc(X) X++ + 1\nint x = inc(a);") '(trans-unit (decl (decl-spec-list (type-spec (fixed-type "int"))) (init-declr-list (init-declr (ident "x") (initzer (add (post-inc (p-expr (ident "a"))) (p-expr (fixed "1"))))))))) (equal? (parse-string "#define sqrt(X) sqrt(X)\ndouble x = sqrt(2.0);\n") '(trans-unit (decl (decl-spec-list (type-spec (float-type "double"))) (init-declr-list (init-declr (ident "x") (initzer (fctn-call (p-expr (ident "sqrt")) (expr-list (p-expr (float "2.0")))))))))) #t)) (pass-if "cond expr w/ undefined idents" (equal? (parse-string "#if X539101Z\nint x;\n#else\ndouble x;\n#endif\n") '(trans-unit (decl (decl-spec-list (type-spec (float-type "double"))) (init-declr-list (init-declr (ident "x"))))))) (pass-if "include w/ #defined arg " (pair? (parse-file "exam.d/ex15.c"))) ;; This breaks prior to 0.81.0 I think we need more testing on ;; possible escapes. See esc-str in cpp.c. (pass-if "CPP string building" (if (parse-string-list "int x;\n" "#define XYZ \"bar \\\"-baz\\\"\"\n" "char *s = XYZ;\n") #t #f)) ;; User needs to #define __has_include __has_include__ (pass-if "__has_include" (and (equal? (parse-string-list "#if __has_include__(\"exam.d/inc.h\")\n" "int x;\n" "#else\n" "char x;\n" "#endif\n") '(trans-unit (decl (decl-spec-list (type-spec (fixed-type "int"))) (init-declr-list (init-declr (ident "x")))))) (equal? (parse-string-list "#if __has_include__(\"xxxx.d/inc.h\")\n" "int x;\n" "#else\n" "char x;\n" "#endif\n") '(trans-unit (decl (decl-spec-list (type-spec (fixed-type "char"))) (init-declr-list (init-declr (ident "x")))))) )) (pass-if "Jan's macro-name redef test" (equal? (parse-file "exam.d/ex17.c") '(trans-unit (comment " provided by Jan Nieuwenhuizen") (comment " worked in 0.80.4, broken in 0.82.1") (decl (decl-spec-list (type-spec (enum-def (ident "tcc_token") (enum-def-list (enum-defn (ident "TOK_LAST")) (enum-defn (ident "TOK_ASM_mov")))))))))) (pass-if "Jan's ELF32_ST_INFO macro test" (equal? (parse-file "exam.d/ex18.c") '(trans-unit (decl (decl-spec-list (type-spec (fixed-type "int"))) (init-declr-list (init-declr (ident "x") (initzer (add (lshift (p-expr (fixed "1")) (p-expr (fixed "4"))) (bitwise-and (p-expr (fixed "0")) (p-expr (fixed "0xf"))))))))))) (pass-if "use of comment after #define" (equal? (parse-string-list "#define /* hello */ abc 123\n" "int x = abc;\n") '(trans-unit (decl (decl-spec-list (type-spec (fixed-type "int"))) (init-declr-list (init-declr (ident "x") (initzer (p-expr (fixed "123"))))))))) ) ;; --- last line --- nyacc-1.00.2/test-suite/nyacc/lang/c99/c99-04.test0000644000175100000240000000267513605250515020703 0ustar mwettedialout;; nyacc/lang/c99/c99-04.test -*- scheme -*- ;; ;; Copyright (C) 2017 Matthew R. Wette ;; ;; Copying and distribution of this file, with or without modification, ;; are permitted in any medium without royalty provided the copyright ;; notice and this notice are preserved. This file is offered as-is, ;; without any warranty. ;; test C99 parser in decl mode (define-module (c99-04) #:use-module (nyacc lang c99 parser) #:use-module (nyacc lang c99 util) #:use-module (test-suite lib)) (define incs '("exam.d")) (define (parse-string str) (with-input-from-string str (lambda () (parse-c99 #:inc-dirs incs #:mode 'decl #:inc-help c99-std-help)))) (define (parse-file file) (with-input-from-file file (lambda () (parse-c99 #:inc-dirs incs #:mode 'decl)))) ;; parser test (with-test-prefix "nyacc/c99-04, decl mode" ;; parse with include file (pass-if "remove CPP control, leave include" (equal? (parse-file "exam.d/ex14.c") '(trans-unit (cpp-stmt (include (@ (path "exam.d/ex14.h")) "\"ex14.h\"" (trans-unit (decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type "int"))) (init-declr-list (init-declr (ident "eval_t"))))))) (cpp-stmt (define (name "ABC") (repl ""))) (decl (decl-spec-list (type-spec (typename "eval_t"))) (init-declr-list (init-declr (ident "x")))) (comment " used by c99-04.test ")))) ) ;; --- last line --- nyacc-1.00.2/test-suite/nyacc/lang/c99/c99-05.test0000644000175100000240000000451413605250515020676 0ustar mwettedialout;; nyacc/lang/c99/c99-05.test -*- scheme -*- ;; ;; Copyright (C) 2016-2017 Matthew R. Wette ;; ;; Copying and distribution of this file, with or without modification, ;; are permitted in any medium without royalty provided the copyright ;; notice and this notice are preserved. This file is offered as-is, ;; without any warranty. ;; test pretty-print-c99 (define-module (c99-05) #:use-module (nyacc lang c99 parser) #:use-module (nyacc lang c99 pprint) #:use-module (srfi srfi-1) ; fold #:use-module (test-suite lib)) ;; io-list is list of input/output pairs where we expect ;; (pp-c99 (parsex input)) == output (define (pp-as-expected? io-list) (fold (lambda (pair all-working?) (let* ((src-str (car pair)) ; source string (exp-str (cdr pair)) ; expected output (expr (parse-c99x src-str)) ; parse tree (res-str (with-output-to-string ; resulting output (lambda () (pretty-print-c99 expr))))) (and all-working? (string=? res-str exp-str)))) #t io-list)) ;; pretty-printer, parser test ;; We generate a tree, send it to the pretty-printer, then through the parser. ;; This should be a unit function, methinks. (with-test-prefix "nyacc/c99-05, pretty-print-c99" ;; loop simple through pretty-printer (pass-if "simple" (let* ((sx0 '(trans-unit (decl (decl-spec-list (type-spec (fixed-type "int"))) (init-declr-list (init-declr (ident "x")))))) (cc1 (with-output-to-string (lambda () (pretty-print-c99 sx0)))) (sx2 (with-input-from-string cc1 parse-c99))) (equal? sx0 sx2))) (pass-if "protect-expr" (pp-as-expected? '(("((*(expr))->id)" . "(*expr)->id") ))) (pass-if "char-lit" (pp-as-expected? `(("'\\0'" . "'\\0'") ("'\\a'" . "'\\a'") ("'\\b'" . "'\\b'") ("'\\t'" . "'\\t'") ("'\\n'" . "'\\n'") ("'\\v'" . "'\\v'") ("'\\f'" . "'\\f'")))) ;; expected tranformations (pass-if "expression protection" (let ((red (lambda (in) (let* ((tree (parse-c99x in)) (out (with-output-to-string (lambda () (pretty-print-c99 tree))))) (string-delete #\space out))))) (fold (lambda (pair status) (and status (string=? (red (car pair)) (cdr pair)))) #t '(("(a*b)+c" . "a*b+c") ("a+=(b|=c)" . "a+=b|=c") ("(a-b)+c" . "a-b+c") ("*(p->q)" . "*p->q"))))) ) ;; --- last line --- nyacc-1.00.2/test-suite/nyacc/lang/c99/lang.zip0000644000175100000240000010001413605250515020604 0ustar mwettedialoutPK@5K‡Ç¦ufc® lang.txtUT (Ë…Y(Ë…Yux Mí½{s#Ç‘/ú7ñ)`ÄX²¥!Œ~à)Íl\{}6NÄÙ]Åž{öÆ …ìÉžX$À ’¼¶÷³ßzô£™ÕÕ p†äü"ìX•™õ®®üeVÖpø‡Ýý_÷›÷Ãßüá·Ãt’Ì^‹æÃ]ŠŸ‡ÿ1þ?ÅáP †Cñ¿ÿûÃæaø°{wøy½/†â÷õî§b_Ü ¯þ:äÃù·ÿ3ü—?þÛÿãÿú_ÃïþÏïÿ×ÿüÃPüÿÿö‡?¾þg±Øì¶Ãìµ´Û×Û¿oׇb?ü©Ì¹?^Ýn>4âþǾ(†ÿ»*îìŽÛ›õAPŽ‡Ãÿ]È*I¢w›Ûbø‡ÿîÿýŸÿö/ÃÍöúöx#$ü¼9|PÙYå›ÍÃa¿¹:*æÁ`2|õpXïÃ7o‡‡ýzûp«Ä^·›Ã Þï7wëý_/‹_î÷Ńªš ÜÜÛÃæݦØR†äz·r·‡AÆÈZlß_ÞnD³×·ƒœ!ýf44RF¿ ¦ÒÑßFëÛÝõ—BîþpŽþ1R|³áýîáðnó‹ÃçKÌ9R?uô½]ÁFƒEnQçõþýñNt¨‘^V\TzÙM–dI&xÆ#s4“¤ëå[›7íÀûõ×¢žY—Â.CÎ0È–þz_\n×w…ì56b oÖ·›ÿ*öõD$Óe¼i93~Ü„´µøóýÖɈÍ$ÈÄNQ(#qÑ&Q%_~X_ÿ8H–'oIJ'v‚d¿)®o×{½{<Ü×jV< ×Wb¥¯¯—UþNlI,û M‡Ç­¿Öý1¤I)§š—1HsšXL3‚xJë´Ý}¡5¼^?XC“Îè"ÄdÚ½£Š™‡¼:Hn%$ý"cIe|5d*C,Æ,¡2Ä¢ËR*ã¿EFFeüJdän_4½e47›Rdþ2tû5› ‡ÍýíæZL—Ÿ ÷ËãÒÏÃô|¦è0_Ú¢·´ßÒ–½¥ýÚ—–‹Uys³é"g'•,fJHVÚIÖePV6|ø°yçNBÐ ÏIR/môí·#ZÀ4RÀÛ·Œ€Ùp_èƒÓú¶EÊ ŸóÄtÆHÔÛ³è,æ-%fÙ½6o9ÓI÷êr’añÿÅ÷à”Á4åè©äÑQ&#(ë$èW¼ |xµ9ü¼y(.×Û›vYƒé4ÀÀäˆMž–5«9~Ùí£d ¦ó'gô§+nQçDJL—í,NùqÂf“áíî½ØRnÝé°$&gôÅ#N\Z3yÍ¡¥ fY;‹Û¢ 8i¹Ô¿ä>E¬FRÜ`6íÊ2ý“­ù¬FŒˆÁlF_KE‘d™ó,Þ)É ¬#ôyy¶ ‰åÁãЗlî×"{>a³/evÂf%³S6ûw2;c³-³s6ûÛoeþ”ÍûVæÏØü/döœÍþ“Ìæ»íï2{9´GˆîüÅÄ!3g«â,’Lˆ›:‹ÔT&ª‰Tî µD+;¯¾K†£oFÃÝýáòzwSˆîd•‹,R,Í+ÉoÞSŽQ¡"»ýú½`»Ñä ³îLœJµ˜d©³·Qî"š–-nÙ&B}ÇTqËI4-WÜ2 ˆxwÜ^ÛɃeÚ‰ž-6£§“DËìôÁ2%mÔoOÆÔM2'¤$˜… Äb»3ÍrÞB/öG , ðù—켕ÛÊúxØI(k¤*~9û­¤K‚tûâ½èÉb/)Ó ¥Øg›kI—éäd¼)ÞIÂÜ]2ÿ§ÝæFfN‰Ìw›_Š›Kg¥%“Ez»[|Ò9U䟿ÛÝÊ2D®Ø‡îo‹_|QK‚øá°?^äçþ¸µWK’Lúb{¼³ˆ‚¨ì1¥Ø ’”ì=vûƒhH’µÑ G›­¢Ì”â›RÜŒ ±ÓhâZþŒg))æ­BÑ"¢äRÞ’'½Ýmß ’tÒBRÉJ“ˆb+¡¡q±hkéQ* +ÙQ2)kÉ1å(’¥.+0~Ç-3-ÒÀxzL‚<0¦¹–F·&d±5dZmÍcìòêÀøú%ØœaLQ¿þ°–{x3ÊmÜÀVÔ rËUÔ*CÒ,yš›Ýñ궦Š OT¶·¡M˜íYoëÐy’0 êúÙ Yˆ¡¬€Í‘‡8ìšÛŒSþ³Q~Yeni2'› ea)™ÌcUc¬Ég‘BÛ%Í;WO0-Z˜TZÇ&-ãd¶ šNºVNð$f]ßX–Üdš:™ö{š±õiŽ F–àÈCb.5êQ2v“®³ÈRg}$9µ™„Š½êáF!kRŸÝ)]0™.ºŠgä,y_?ãHÉlÒAŽ OÚÉ=-PlÚAŽ ÷& ¡9y9‚Þ›~!úF×¢Dy³ÓS¸’™7ï|JCd.–!x½ùV¢+,ÃÂ9tkuH$y»‘L,Ì&*ëõ²?eŸOxlÁó¤#S]ZScA—y2J ¥(jž‡)š‚-®©ñ§»uÎgl¦R|É1œÏÝ¥¢Ž8’T¶wAåþ´“&uj˜/)!ý°ß\K ‹ …_h•åv³•2ÉОp÷;qr“(Çf_8kÀ€ÕʉMÐd~ªÛW‹œ¦‘–_s­HO‰•Q´~¢tñ»C# "K/Dbj§ ×bæ]Ä„ê³è"H³,;±”àF׎’¨Ü‰U•*%9¹”¯Ên‘˜^‡n©Ù˜ÙK°‰¹z/~ßb±èƒrí±•,™ N‹i–†)"~ÞWN_ËY½x•ÅDÏ#ÈÙÂ%k$,¬A:™…úßòt’ÄQêd;%{_î_u²ª:Éâ(õwf<ËVän¦En6ÓÉ4H[‹æØgtNÀº`ºQMæÙIw¬É¢«Á³ô¦®½Ñ§É$La Û&Wbøÿ„ŽÄ´cYjssµO2ŠŸøÒ¥ä-Ü‚dÊ‘ÏÙÕG’ÊRÞ`ɼ…;Ûýû™&‹ó§/O¨s:9M´’œ(¤ßw8MÓG,W—=¶ûÓ4o›÷ݧg:í)Ss·®Ä–‰Ö¶›ÙÔ¶ŒNš2mK)n^dmËæ”ÁÏN]Nåù-ÍÚÖ‡M}Ê\œÿÒ¬m2·ÖBZgo° 1ßM9·`>™÷¥LP˜_š-L›­Ì¤}4Òlé²øi>‰£-5ÿ4OüLõi—5ÑçÓ°œæ)IoÓdm4M%ø‚òx!6ãÔj4¦FÞȆϼt‹TPÌÃ:ÉâXVk‚ò¯Qk$_ºÔö}‘TÐëC!'„u×WÅmqsY' ’Ä&‘æy}É¢Imš¦UfS=ˆ¢Jxà Êm"u¿È#šÚD9ÞÝ[ù3;_ú2˜Ùs§I÷6÷ÂïZ†&Ç’æ]¯ f|l Òë‘” Vöúx+M$CBŒDµ‰+T‚# phŠÌãÙM’ ÈÃ:Éâ˜:Gz‘;srÍÎÉydÏ/‰¬ ÒKªó—ÔdÓXZy3Ãù[«§ç“ÞÌÃQq+'€)-a¥=ü¼9\h­NJ­ %àçeÖ óg,ÿÍΪ;/Nuêθº1ÔBT]j!kî µV×…ZÈêÛB¾Sõ¸º,Dæ‘w…hJêª]^ySˆÌd. ‘´ü=!’ܹ&DÒX>ǾƒÛ¸ö£39:¿ñ» ãÆ{Üwq`\ßéh')ïB ‹"h#¤ÇWl«4}‹£•¢K·´‹$ï¹DÔ!º²ýêܧê±%q—’:ñÄRÇKŽ•Ø£™í}¾ŽÔƒ3È£¯ Em;©wé‚»>4®o"…HªËE!çÒñgl^õ Óù·ÂôÄ]¢0é"xfÜë R´Ì³ 2œÙ[yºß?Šy.9fk|ÿýq‡; §°—®!}Ší[–Ù)®÷ÅØð¿ ñ†€î/цŠ¹&2‘\\§Ið¡¢:q*«iX§Îdj½Èšô¹L¯Vaº©åP'.e¢ÚÖ 8e¢«Pm{M†ZÊUÞ$J|EmãFšj˜Ï¯ÚV~›Ô© NvF²j]}(42TóêÓ¤‘¡Z¨Ï Fªl¢;”%2$êO†2S66¸”J:Ù~~[,‰T‡èý‘*ûƒû ”$²s¸SI2Óý±1»:UT)7FúBÏ$íúÕ$/ug—º•1CÕ\P œ‘(»†>£—iÙçö!¿Ì̪LŠ3W½Îjl%•š25ÖФˮ¨¡ #}î£}eŽì^ .‰Tï|c.RÕ-ªÕ$ËŽið2QMB)ód_¸èK™•Û53r¦f÷ÛPI1c€SƒdN¢Ù`š±·ÍM¶õõuqNƒlå­±f¿Óxj*†e¯ˆXî‰ck;¶oÀŽMg'/Ï×UÙÜ6/ŒkÓƒŸÑXBUîøå óµðÄ~\ŸI×Å5žRS.d-›ïk½ù¨lãã­-njÆŸ èÏÕBî.v}ÊŒ´Ê¨_fˆ6]…¿bÕYãé.¶ÈêŸv.¦º¡]äSê&g6æOo6NƒYÛl¬¹Ïu:6õ?q>Rñ¬'ääéMHqÚ™¯‡wC¹bÎ0‰8ò A•"f#5mqjT¤r·dj¢N©ßÛ,MÞÃÿøã¿þûþñŸå³÷ûâZôàöº –ÁÊ—úbdÝ+j®ê ®ê‹@ÕlÕ“ÉŠÕJ¥–6¡A ’$ÀÞ¨¿íx¢M‡RòaÿòNÜØа¡aCÆöI74cW ndQO ³Ü_V&ÉõÖeçt mù6å@Ljåtg¬£vúÑ]‹ìÿ*:àóã³Ï>øl|´Ïµc•äÒÏ­wåŽT¨ùXÚTb?_þÍjRrL™J4‡zëc*/r˜Ê|‰}ÝT¦š¯ÀYäËÁ Ÿ¬Ø·Ôd;8J’R8J L2c·D­à6Q*[©šF ·¦îýê»4ðDå«ï2‚_ÔLÍ°swL&¢Æ)ß?%`ê"ØJ8`KFqÎ3¾@] ”;!!® qɈÏyΗkm¡bd±LÿÊŒA>å‹5ÿ •J?öÇ<~!3ùŒ/•Ò“C¥ÏÈÒ™Hê2cÏéÒ뽆Ï$+ªÝ”¬¸Hf òE`G¨_½ŠÆŸõfR’%¢´åŠÝrÝzÜì½U¤%µ›¾v’ÓI´P>¦O×q:#‘×dŽü,ÉAÐ?+ƒÒ²iNÕG¯Ñ‹\´0YEÖNmâD%Ü”²FdòÐfõó¿|U§©ùVÿe6n¦ÌE6k•'+Ut•On,É2°ór{ÈLŦn_8»«Y™²e&iæå:GèDý#°wnMRæ3•Èw¦ÒE›: Ë£ôØWå3f̘á£Á ÏHÔ1gÆì­FØ×›äù{Îðû‰ãf˜;qÄO-NB·)NJi]^W÷åÝIRß݈mä9÷U¶Îç*¹Ûg¯‹”P Û„Êà{ËÝpân ‰rÕ#W¡\Å‹•SJµ àLƒ3 Î4ŸôLóqÎg9A$ 2ñq:tR»`›©×É×{‡H±N¦8$ñîx¸?Nä–¿7Ûó ’?¯owWW ”SS ¥;cLíþGwëï®rV×{˜wÈC΄ú-ÖÊñøäm85RÇŠmåÆw⋧Å÷VBÜx¿ÆwÜx7(qã7ÞqãÝ[ÜxÇwÜxÇ÷®7ÞOÐ )ÐO+«%Úqu»»þñRhµwFÛC ”O•º©N3U)®äãJ>®ä?…+ù‰šœÒReåŽÇFOÕ7Ö’P½¯€2#Qö¾¨U¹ ß©rê;UNƒÙ„ ým(4ÑIÓ[ké8Jç:i 1á¶(wf_JÕ°‰¨r¼»9ë>Kû„‚d8˜‚3QNûƒ¡½Å/„øö;ÚP'NüRöR0`f4ÂÄ‘Š"f+vó±0v8ÅbÌæ!)Ž>7柶Òq¼ïçÿ®Wø÷5y“üÃð?þø¯ÿþŸüçáÕ_‡bÑ^‹s{]ˆÚ/bjî9–1bô·5ªJÒ65`hQò8Ž¦³Ý€ò¼÷†€¹   èß7Bštn ¨ã©óILWëC7d™ØæI@ŽÑ%¬q¾ÌÓv!í£nòÓžóÞTç¢3¾ÅÞÈM\mtR^=bKy%ϯɄy)É'ªO“Ç7& ‚)µ/*‚‡&ܱö­'†cÁ·`ׂð|\ A¡-Ý„:õDû4¦äGU<'¹%Ô`0—äu*%ö£,í²ñÔƒyèûçB`üŽ4’Ä·(°Ò<Š–‹û|æCM¼4ñ‘_LVamÉÂŒÆQ0 m™õ3[Ì«teëÌÎer™mu)¹«Žs}w†~!íÁ¥ÓbÜ_c3è—(…“ö†0årÄÝÄDQ7Gë“ u¯‰ÀŠÉÒ|L+&l”n±°QÂF %l”°Q:2a£„òì6JXó‚Ö<˜íN0Ûq²eÈB¶Ì^`†rZÊþ i:¥YeW×+³fMŸ’†³åœ$pÍgÒ¶³HÊpzSxóÖRXˆaš ÖÔe¸9Mc‹MâÇ'î´¤L×w`É„ÌHò¹¨vÞVmã“Dˆ  *@T€¨Q¢Dˆ  *@T€¨Qy¡ˆÊr1,¦‘(Á9± B¤mpþ6S‰É`ÀÞ|3¶š1¿A™‰µ&¥[ š}‹fÒôfü>O‹P‹lm…iéh¤kw˜{ï í’®±W¨H+‹e¹µ55.ççÄÊpW–„ çIê­¦Èj4;ÿm%D¸‹oÁù?Ï%Žºˆk×ç;ñNèÞ3ŸpI¦ÙRÌÝåÊa5m|cy÷FOª¾îb­eãßÏ‘iƒådEUØ(mLó#¨Ë´Á2iù(º%ƒ‹‘¦vgT—ÂôÝÇX5kÚR%ÍESÒî‡X1`Å€V X1`Å€ƒá#Ì +¬°bÀŠ+¬°b<+FšI$Eúh*ã4~VÒ\ê3)˜ÐS¡§BO…ž =z*ôTè©ÐS¡§BO…ž =õ½Ìÿ”•»äöv³-Ê%áNÕ‘H$OÞêÜ݉CûãááDnù{³=¯ ùóúvwu¥±Rj¯t0‘rªmo6rĦk®óËq»ÞÿÕL5hw÷åC´Ìöû(죰Â> û(죰Â>úÑí£ÞáEÜïb+±Ž*4åèë¯GÞ ˆ%¾¼Œ'Ö©õêzýpˆ)âaó_Åî]‡:U òª¶ÕOêpIKtt÷~s-ÒŨ˜…tfŽþÉÖŒu EòêK9\ûÍÛZ–ÖO—ÑìÜ z]ØEÇ­÷ïÎáö²‰L×QXgž±‰ftc½|ÛŸWLýŽ…]¼ù§ ‰9jî§Ê¨vgi_p_q_s—\Æs¿I·mjXKh½½±f{‹³êþþ÷+Í_O.LÌÓT0Oa«º<†i„X3ÒMÕÌW›ÃÏ›‡ÂÝÊB,LÞè‹/Fœ82Ù®À/ÝYÜQ±Âª©puT&’åéÒO¾þ Æk@˜GM{(•ë¤5Ät=íÖ¹3†ÇÉýiÔ*ŽáB¡T‡¿F30yb;¡e‰Zо¸]?–žÊ½y3: _ñ‚ÈärÔ¥-;–˜Î};:‹˜·çóí›3U‡”㦔Hý<ýTDz©£oEÿ$àí[F‘¨eÜo›û[±3ÆóPâƒz>Y—AYlVù5sOÝ-ô|¶ Ã{Fi¿;«´_ÒœëeÈüs˜'žb¬|*¥]°1¡t¡afC剩"3¾Ê—®Qì*®ˆ¤C³mV$Ò/‘ÿÉfòL'˸™<7ªà!+ª…AÅ•™]W(;›(·Ñæ€P¥'Ê7’;5UTÊŸôW¦›ëLyÑþ·•¤\h/­$å,úµ•¤üi¿²i•¬/,*åüËW6>LVfc¸~š§Ú+XkÐFºl£¾¯rU/­ÆÍU{¿¶Z7— ¦UŠ1×Z¼°)У꼅žÆ ^QQ©¥Ù1äº2ëÍ›ë¦(¦91á&~¢›xmÅ7ÒzNëwšä¥îìÒ‰ÀX+jV–NÆPsR90´2‘5…V£1©fŒô¿0˜çŠÙµW\‰®Ÿöþ0ÒÕ2(}LŒä¬œ ¥{Š‘£ƒöq1RÕJW~5FâL/h+Muké¹c$ë^-Ý‹ŒtÕ­k&ªG­xüÙ:ªÝéDµïoÖrQ]Q;ˆ´ºÑÊõÌH• ¦^0H'jj‘.夫Yèªr¥8˜”T²žwNU»Y9ÈL9 ¾ƒP•+GƒqŸªHÔ'œv«–ÿÄš&)×¾ïbWQÈ>$½ü*Ù¼ÿb5è™êP‚=·ÙÍ,Ù½¶—q•3³rÜ zƒµ.4‰­u$ò¶C5_ÄTÈ¡.’i€ñlÑKücY¢qÅöÆK¥Ôå ž­Üž`ª5Žsf¹;ú]“äJpr:6Pm› ÍÞÀq¢k§½±Pä®øüx5 ¯FáÕ(¼…W£t*÷DT¢aÄn[ê´K?×ùÖO½ÃèT^CLrëSZ3¹O5‘ßbyë0™¶ ¨îO[—¢žäÍ'\öy‰—}à›ßüê›onxsÛÞÜðæ†77¼¹{É7÷)Þܽ±[Bk£‚;œÿr:eúÁíÉb“oØä Cë 1´~rË]œÑŠ´M%‹¥‰f+ ¼r, c߶Pþ¡7 æî¬GÇûËG’V[ñÓ¹Œë9¸žƒë9¸žƒë9æÚÁõœ—w=§—Uwzp§§‡ Üé)kƒ;=õùwzp§'H†;= Õ£ßééèºóɯQ~AÉL¹ ãrÐG¾tžû/6H½˜FÜ‚XÌJ×,wª²”ÿÔ|E\†Ð7gÆ'…Ä;‡ÔÓuç.„[Óp‘ÉnZ´!ˆN9cÒ99@ï;'_È£iãAWºÀé‹#¯$QÛåŠvþóÇ –Ò‰#Þ‰““ÐÍ™””ÒêÈÊquw¤í$©¯ß/ÛÈsz0³…tæ8WÉÝÌ»H ÕÐÊ:þ뇾·¬co`_vXH'×t½eI®?ckS(ò7o=9Ñ„:#Ì\FÏåÔvr÷|–˜°µÃvÛlG°‘K¶#Ÿ¶#ØŽ`;‚í¶#ØŽ`;z‘¶£Núg¦äx\$+€D`rŸ|DA?·Î¨NøR'¹Ú°’æ0´ÂÐúÄ ­³ ­} ­­VÕÉ™o²P×'’4ór¨¥}!‰·/üFîu¬éÊÐXSQJ‰#Ô8Ðx<¶dSÔVpŽ0i-¸•;6‡Ä©;÷úJLƒµ ª³DÿðD ú‡&BôY¢ ú‡'Ñ?ýÑ?ýÑ?ýÑ?žFôNª(éGê&¾qMã-FÌb’©¬rŒy¶ScJ÷áßZq3z<\@JùÄÊq‘€\B4H‚€$Hòé’ä²,Te‘»žs+ׂÙ*’©ÿRüsbŠ3»“ ·Ÿf+ftz’ Å+Ÿšbò•R˜ É<î”ù1C8G5ºªõG5]ÅôãÇ€ ³™kSPæ/rt¢^U¡<à—ò–Q:õ¦Fõ'3¥äK'‚o¶º0C$K‚/_Õ)¡‡Ô.ä=ì R©`Ò©*n¾ºp£2K"ëïP™²Ì W¦Z5‹ØÇ$¨˜ÑÚ,2¢2*‘¨‹ºä”.c«ÂFÅ3‘­íÐßI&w®lâÝ©ª— ûEûSz1u À3x†ÏPà ¹2CÔ6íZ[Yò8¦¶<‰nC8?P•#µÜ¼JÇZò¥£:j¢†5k»=nýÎúwÁÇåmpî.x'Žˆ»ç‘ÜíWà» òoè·ugÌ9'ÐÿèïnýíÝø×ðõˆ)û|¥Öñì  ûzí$‰•÷8~»MûÅå~qjýNOV.dAcB¹ T¶1“<´Yý|C½ÔþŒµ²Ùô²‚Ã\Ö*OŽUtµ’ziØUù‘±m³Y$xC9àò€Žô+ËæQ€N«&/CRd‹8˜JÂSœ …šGñ±-Ê3_1¹ r©…ú¨ºqš7¨YÝ=Ko’Ë4!-i‘V¡I®q¢C“a>²—åFl*IB1¹8p°È$³"Ç6Ž…v‹#I•·s€"$öSŸàùº5Z9•i*,=~‚Â~ÎÒÎ!÷ñj|§)þRì£f<ÖÀÏ÷óÏË“&߉3,z=æ\9Ï„xÌQo›Í_uéÅXâP¡@S_¹Q2Nª@Ouþn‡ÐfÓ¦L˜~2ÀtoЙÊÈ”‹•ì-SnUØ)çoÉoFÞ™röháœjè‚PC¥!;ÏV„g ý-2r¢,©|çyX®¡Ü¶^βsLG‘è/­s„‹ 4*ús> ÇÝ3åË'«j$©ýó×VÒŒîó\úåL'+®&Tò¸-¢I7YáH+ªþ1‚ÎñL*­›äYÆØ'sižœ&+>ò€Sg60M¬64N8¶×b)ÇhŸú¨ËÊiL¼Ö\®¶iºâK¤3Æ\¡îr:4âës¦êPb˜0Œ5$fïkobk@´/ñ·o¬4µÝ¿µÓ[ÈTÚ+¦âÔÃTJ£huˆëÅÔ e)+ Ýfµ™ýÊN›2ý OiSqJãKerÆ|H4>À'kàDÈRf“™ª7]Y±5ª "Ü'1•v›éÌeÒ!FX&Õ3sI a™Ô¸XEt“3ŽŠp-Mv蟬M™•‡érÕ^„Wß@dC>Ž #MÖ÷ïV}™w&¿µ3ñ­%B¯Ø)fDC&X‰Ã0 âÔ¤¬;®¬ˆøÜѲëYÃYL%wÊq;ÖDêÔ(ùÅþÅ÷4“3†Ädc¶pÒÔʵ—.Ó_3Õd±Õø¡]d@nI©nž’\ÿÍs©²f$×%Ï¥:uNr}Ís©É™«y¸h¬µ2¢¬¯tYVü(ÖªŸJ3òlIVú ¶ÒÊ}}.–‘JßMS:÷­ÉVJZ{ú(eAu˜ihN</#À 7U¨®âˆ»‰‰¢n:ì¤B1B(„r9#ø…P.–H„ri#D(„r1÷!„rA(„rA(—Ç åB£e°“Ðc !FÓŽù[uOɾhÁ¼#å’™b^3>$x ï`Óï`9ÂðÞÁÂ;Xx ï`á,¼ƒ…w°ðVDñÖgð}î£L©ás쪰«Â® »*쪰«v …]• …]vUØUaW…]vÕgnW=Q»„f Íš%4Kh–Ð,¡YB³„f Íš%4Kh–Ÿ»fI<«çÂd<… ¶"”WS+võžž¼ÌÆõùòºw8l‡ ’wØwŠDÆ àÝZ*ªœ¼êLtTmMÀ Ÿªd/ÀHžédÀHžwKÆ;UBK$«OÜ‹/ß.œ¨ äT•ž0qÑ’™¬0ïkVQ©?~e=“¨"Pü·•4uÉ$³™n&™ÍÝÐ<2ˆ·"™-ÝkÉ\6Ž¹å_R$Fc¸œ«p7•ß±‘.Ûè{EV¹ªŠ—Vã檽_[­›ÏT07 Ê©(æu9tþB!ãÈ\Q©õøÀx¥WQ°ÔC“DN¦_Ïü›uù\½ VíFÆ…â±P<ª¹óAàµP5KÎó\h¦¦VÙªèæUœe›¨ð2x ¹)GB†ã™§«ö¸!~ô˜€—7¿Ã±ââ¯jt.gÊ?YÓDÍ©¿[ñj.^ #4ÏVä®^i3úVŒÁ{7†Â·VpC7tºÈxÚ7t^à™q=äI©›çÖ?¾ö×®ê=]-.Óa¸­áê1¨yNœ*nüìÜŽƒ8Xà`ƒ8X|âƒ|ógT=>ÂÚx²‰|Ë`>eà Yg 8à<€óÎ8|†çGMÏŸÅ!„=(‹ÍŒùàËÒðÁÇ||ðñÁÇüçÿÁ—Í笫‡Ÿ:n‰4C`ÓeJˆÚáiÞ¨ ÍþŽ±<}>¤´0â£N Åönl/2×&—.$ʺHWR¹tA²æ¯õÃ}Â’N+†>:¸0þ(¿GTït¼vIZ)Áãډƌ0Ž\Bã|Z€qãÆŒ0`À8€qã¼RóIâsV@Íd1m‡ìåxéàNR6‘HY&ýïæ‘H•oÃ8“Oé g<«v*\ûãááéTDþÞlŸläÏëÛÝÕ•Œÿxî ²;.·e¥s¥hQG)2—žÜ$_×TqMWîT–+b€.¼Õœ›B.õ]b1_ƒ¼ISƒþÅ42ž$m6ÉêÊ:°ø›'\»ÕsêÜJ M@áÏ o®¬û÷£z³Dþ0"ˆccàêÀÕ«W®\¸z =põ àêÀÕ«?9\={îܸpàÀ€;wîܸpàÀjÀ€;Äâðç3ÒáÏ÷Âýù¬È“©öÞ³BV*ǽgáõgköUõó³ù RUÈôìÍWeÍm.¯6ò©àÅÌóÞb¢ʪ¿VU¯¼¿2uøDÚ7nš(hÞvùWÞö5«2ö$©Žv%–ò™›ÅbÕ¼î|S¼SRt_0/.Åšª‡ä‹Ù»£X´òfs!ûAUåËW·»mq)rïŒòõëÏ_¾*¶7^*m2Qá—« ¯X§²%ÔX'p>xúÅçådå<ùÎ"!D¹ÿ-ítÚ4[‰±|Å—ñ›Q3.ÕLJ${ººøËñîÞæí‹ÃQ>Ð]r)Ì/º$öŽGT›|2SÌk&(åS‚¥"?#¸/p_à¾À}û÷îk î«Kî ܸ/p_à¾À}©RŸîû,Ýg1QoÛP9©î^“׸— ‰]í‹õ5"æ0Îœ—“Œ¢‡ÍöX°¼ ]NIÞ÷»ÃndéOZD¯#y×ÕJ-–T½”³”ø³\x¡µªün·•{r©>_^ß®ÅpwoñE/¸Ib뮥¹“?Iv9狾Ùé«ÜUÚèç*„¦¯ê^´¸…j¶¾*n Aö(|Ù#1`žèA”s}Óôhìãe[¸°ß˜{‹×k½«¹+€­a$¾´ã¢' DºG.=ñkZ}3(j°ÜatAmO˜šIþ€–¹›wäü3‡¥7ïpTÜʾŽöðóæpý¡­2ÌÒ‡ÖR»\›ñ+“—£¶—sl.þn;®ö[w·%I›m§)¿=[,ntáFntáF×Ùntq»ºnÌú(zº¨øẼm+Ù¾x/Ö|±o%”=±¹n%“µØ„ó…ÐÙ?í67Lž.ÝoI)…(ÊÑŸ¿ÛÝ2Ê-î¶ø%JÐÃa¼>H=ë¸u¾!y±=޵є=¥`º’¢ùÀÕëäá0b2ÚIÕVìL¾˜L‡ýæZòŸ²r—ÜÞn¶E×›x¸BøįRK©ZÆv{5%ÚHääh#e7£8¡6m„ôØâãŠm•v»Û¾ èÒ-í"mÒØZv¨l¿:÷©zlIÇm÷©àñÄRÇKŽ•Ø£™í}éËï[LLi×Öûȱm'5*P_çê*³Â$7»ã•ú¦hÊ–Ö¤ô‡¼:üAç¶ÑéºÅÓ—¥Ç3ص¶øØÓE}ö’ùåáZ|Í~,”V²ya±•~+ól‚šÊµó¨Ôó¶§y.9fkìÓ\u¾‰^ dba`jZSîÏ^Ùh"úÛ·,³SÌãky’Iú4 Ä0€G `ðsÊ„|Àà0ªÖðƒØçêÖmôi°—£á0ß,›­ˆq o,,0WÐ\K,lx‹Ú@ÆFêÀ`Ò„i¤áó†£7 RØËRÒ­/TÈýfÚÝAYËrݸ}ª®!f‹•“ët Ü뺰À½îup¯S€Üëà^Å÷:¸×…|•à^gvÜëà^×EÜëà^÷:¸×Á½îu­îu¹|·;[½¸ô[Ð;í•æ¢w=ˬ>rŽƒY>ña5éw”Oú·Ð@ìž/FùèÀ¢Óíy&ý6óä„n€Æ³…ž®¨ÉÛĸHuræçÙŠ[ Ìêb¤-Ô,Ë[ Uª¨qÓu5&>ó½Aç»Í§]‘÷×£0ú®ª=‹FßÖQõΉz«nŽ½4o®å﫹á߯ö½.ÎuÁ`w ΛRUÀ÷Xn«@Àwð¹û¾æe<ʾ¯ÓnÎÕæ&Üî]m»H:ú™üÒ]ÂûÝf+N¼Ã›Í¾p*îU‡ q“üÏ C"‚fû¤RÃúÉ`°M™z è0Ç 8Yvw)çªMŽ*”ôG浪àG-ä«^}ÒKLÑ{ñû® DÛª“”f=ô•PBXz­Vè Ù;%Q5AÅò¤S ¥ë*MÈÒ@@öi™?W*jݦ2uáÝÃQÁØ) iºô=L‚<“ŽSêúŒ$r¶sؼ»°Àæ ›7lÞ°y«›w[aó†Í»•6ïR:lÞQ¬°yÃæ ›7lÞ°y;åÃæ ›·F†ReWð£4†Y;µeîÛ»fòý«iô‹Rç0xÉ;9Ó<ôVµó¦­tF½¦Sɷˤq:]]¸Å7ÉxmiO:“ÃélE? gZTWÚÊSæÊÍß =~Âï1Ä8ÿñDÄ;y ñÜžGc?Øçe[ýù¹·xÉÞ»ý×ÎP¾—H-‰HõKŒ==_ÇÜŒ 3hÿ b°Üa”Õ¥Êf>¹›R“±ORÖ,ìÍ;·²¯£„Uoi†+Ã<ò(øË':û²ËW?ŠóÒTòrÔ“¢Ê.£õò1ÌãC¡ Þö yIvUýÇ.…týŒ©9çemHÒæ-Tž¦|F•'¨Þ_u§[XQxyêåî ò-OØò©ØÁ…{Œ'->™YÈkÆ^8 žžmP/ÓïSväÄ»ãáþxx8‘[þÞlÏ+Hþ¼¾Ý]]ÉWGûk@ìÛ¿¼I)Àâ] Úú0ÍŒ&p©.õÔÌxÀÉ€“}8Ù'·V¿@ ø§†:Â!Ã!px¹Ÿ¯EáQ­mg4Wô³ÄÅ9>¾UŽ°yµê¢l1ŸÚšÇ›î’ù"ÂV”Ì—=\¢pÔÈPñîXŒ¦$ZNª‚$N×ddšÙ…§*.e2­PB#]u~‰Eɪz Œiä¨~×X¨‘ªz^á¯F¢šk76¡šl%Âk$+wí †6ÒÕ¬Û˜ó"LëY•$[Gµ;¨öýÍêeÕµ!Á ÕV& #5gLãéD6ÚQ«ÌY9d¦ìÇ­reg0(wE¢öÏ/ITGI!i’Ác ©(dÿ‘ƘŠ@ûxy*¯®MçŒé-` »¶Û?O•UtÁ ¶,D0éÁ¤“_˜ô`ÒƒI&=˜ôX˜ôª?aÒƒI&=˜ô`ÒƒI&=˜ô60éÙGq˜ô`Ò ’Á¤ÇPÁ¤“Lz0éI0é==“žŒ:•~™:˜ßÎoØ[†©º×8›¬œñ5¹UÐEiJÚF ”()PR ¤äJêÓ% ¢¤/"F  U@«Z´ hÐ* ÕÇŒMöÉ‘X>Ì0Úç‰Ñ¶à«¹zi~&÷ÓðZíy;øºz;?UhçI@ZmÄ€´iÒ¤E.!@Z>- -@Z€´iÒ¤HëEBZýZâ2©7h ÑÛðŒ áºÄÐp¡á¶ ƒ† .4\h¸Ðp¡áBÃ…†ÑFh¸Ÿ† § #NpÚøLœ6ô¥8*'Oå£^³”wç0cŸÁ¥€/^¼xYk€/^¼ú àUÖ€W}~àÀ+HÀ‹¡àÀ‹$à5ÌÓL^ÙŠ‹ d†×Þ¼ xð.à]À»¬µ¼ xð.à]}ï*k¼«>¿ïÞ$ÞÅPïÞEïæi*ñ®œÇ»ì×%Ç­ïKúáÉó4‘eLù2ê—'Ç'¿=éð{ šz“ a3n ñ—®õ#£zFI^Ñ—÷ŵZ²ª‹.«¼]©“¿ú.©{çzwSˆîtÄŠ¥¹ŸÔÈT»TxvûõûBÜÃC“Û‹‰éŸ°,õá,צí_œú6FWÓö*îÝq{mgt¥g‹€üŒdnÅ膬‡Ý¨¨øE|¶­dûâ½ØÕŠ}+¡Üú7×­d²coŠw‚ÎY}:û§Ýæ†ÉS'¾Kw}“”òÈE9úóïw»[¦@ù ÄmñK” qþ;^䀷Îú¤È‹íñ®¦ì)5 KŠfóеWçÊ“ùÓNžëŀɓIZ¯%?±MhšÍöv³-Bè8,°XÀbq6‹µÉUì‡Ý^-Ö6¹lÛŹ®¸Å µi#¤ÇWl«´ÛÝö}E—nii“ÆÖ²CeûÕ¹OÕcK:n»O'–:^r¬ÄÍlïK_~ßbbJ»þ°ÞGŽm;©QŠ˜87•Ä*+Lr³;^©ÓF€¦liMJ±ª³Ùtn®[<}Yz<ƒ]k‹=÷Õ§b™_~èÅ'ðÇB}K6Sk>±±2Ï&¨©\;J=o{J‘ç’c¶Æ>gWšHôZ  ÆQ%žÀ^s"úÛ·,³SLÅB})“´ž— ¸LÀe.½Áe¢¬ \&j;\&à2$ƒËC— #=ì2Qb› å#¡Àušò(U…¦mÊ¡T‡êTå)Q+{Mºr—¨´Á:U=ý]ê¢u¢ò™Pêµ9zº •úÝd¨½µ¶Ù$*ç 'i™v˜pùUÛJlÆèí—æOR™%Laõ,|iÑ0dFm 1k4Ð/Ã?Xä²N®~¤³Rå¹áiXef¢'4¯Ÿ–téà"€5”Dj(´eÊH•=ÈA+%‰ñ)Ifº?6æ¼IU'U–9#]¿f¯ {FòRwvi4–›šØ¥aÑXFjÌ”QÒ }6ŽA´q¬lEZÎÛºVffU&Å™«ÚJKªéÙ<“x7jóÉbý—G–r_ÕKís«U‹Œ’“«…æ{ùT~Jé§4[]üåxwï¸(½ßÉyd|Æ•»“]ôLŠ˜“"D‡6Ûc¡¥†cÁûJLüµ8@Èì}qs¼.ÄäWÎR RÂÕ¾XÿØ®ü¹–+§ýÆ_ãQè¾8å²EPmW“ýµ¹dg²Gç²1•Ü`kdø±y²äÎf— æÑ0$D>I7OWbÉ6WËVQm€©^Ñõ(C$òDµ3óªøýÈÀ·¬öþ0jÀ #ý7žš?É'·{£¼x+ (Þ¼xë…Â[p¿ ¸ßÂûÞ‡Ÿ÷á ´½¿Ëó“BàÏ ›|Ì7àýÄJó \š§Ÿ³uꌡ8#Eh܆‰¦yf¬’$Od²ynbAzw$<$Ѯћ‘ tåj}Œ‰´ïÝ4Q´¥46R<5VGžòˆsC•_6ß/Y4¯idÕ;IÓÆÊŒ6M¬’2…›åWüÏVÞWZÐiº_Ûý¦ ú‡›&äÍiyf ǦôI^jM$ ëÑñ§”HÒê0òtnvB yFw¡A)ú ”¢OnšxZ¬-/B/…É&£@ƒa2‚É&£—k2ú|1§§„Ç>aèåôû,|EÏãª)ÏîF/N#ü2³ÆŸ²Â* M¹þ-Vn6© Ž=‹ÂäjÚ×#Lkã3!¹ ÇU³ÒZmGÇ|²h Á*i);`©}íÞ‰$ ö8ko¬üwÇÃýñð ~o¶õÏëÛÝÕ•ŠÔö[ß5„zë^1©†L‚ÀLÐŽ¡6ñ©5ú•ýh5$6Z·^–Õ©9ª òsmÌ¿)ùÉJÕÙƒt¦ÖºÕ”*k.fñb¢—±uP’¹î¸oF>˜þ œ/¾.’DQÉêâf³/®½Â¼D ÚNðz•Ò›ÖXcŠâ_³yÒñv‘ž\¦”ÊøËMR”‘^Fu%‚1èÖo'¬X°>`}r Ö÷iëÖ¬X°>`}Àú€õëÖ÷J¬ÿ$aý ?ŸHãE¾"š%`<8·’Rhô-¥!³TBç‹i'ÄŒ…Äx\NA›³Õ…iÉÖÿý Ë®ØViêÑôvŠ.ÝÒ.Ò&­e‡Êö«sŸªÇ–Ô¼Z?<žXêxɱ{4³½/}ù}‹‰)íúÃz9¶í¤F*bæ…yA¬²Â$7»ã•ú´hÊ–Ö¤ô÷´úÿAç¶ÑéºÅÓ—¥Ç3ص¶øØ|}’ùåq]|m~,Ô¨d3u¦æ +ól‚šÊµó¨Ôó¶§y.9fkìCUủ^ d¢>Ô%žÀ^i+}Ší[–Ù)æ)R})“ô¡ phˆ¬3Ú‰áЇ84|f –DÜèl9…_Äsò‹¨OPÆÊAÕ§¯:MYéËsjSŒ2ø—gñ:Uy&ÔšF“®Ü*U¤NU¼KE¨NT> J·3;RW¡Òýš õ¦§VušDåŒ uY#-Ó .¿j[ ½ó©œF* ÒL—É5Æid¨>­ÁQ#Cu«†TTY]÷­³TXwÿ^f&º™¼SÒéGl9…´$R£ ±j#U§—$rD8X $™éþؘ㛪Nª°z#}¡§¯ŽŠÞ$/ug—¦cY¨ XšŒé®¦Ÿ2S´¦ÃÌ‹ðþ¡aõ²µi9¯l\¾Ì̪LŠ3W3‹5²”TÓÏËýˆ7`WYõâ‚ë×ReÎÛ=˜2õ€BÈE§¢[ÙdÒÅŸi5'øÃÿ8Ð`øÃÿþÇ/×ÿøóu`zTç¾O~w7ô>¶ó ‚D‚DžçúbG—YmÖ3š7 \å‹ Wu—µö¿0˜çŠÙµW\‰®Ÿöþ0ÒÕ2(}LŒä¬œ ¥{Š‘£ƒöq1RÕJW~5FâL/h+Muké¹c$ë^-Ý‹ŒtÕ­k&ªG¿±’æ~o:ñà%z;¨Ä ZÝhåzf¤æŒ¿y:QS«wtÑl.šbc‹zÞ9Uífå| 3å0øBU® Æ}ª"QŸpÚQ¬Zþö¥kš&)×¾ïbWQ¨{ù”—_E û±-Àj’è»{n³›Y²{m/ã*gfå¸QZséJ¯‚]y1¿WâRŸé­•çýd <«žŽg™*ÓpÍi_ܯ‹ábÙø)•Ie0´ï‰´ß¸iQv„­²©tŒ­Ò †­¶Ê'¥ÂCA‡‚ :t(èPС ?1Ý<:ÃVYl•åT„­Šl•P…  A‚*UªT¡—  }ž¶Ê ¶JØ*Ÿ¯­2óm•FL…Ú9!l•ÂV©ž¨™­tŪ‘bÖÐØ+ZÞ%üs‡ŸmÇx¸¾û¾6߈\‰z[»ß‰É,µû;Ù½˜!±UÑzþjäàº=u1ÔË/¶q¶n%‘ bHdªàimÌ|9i¨¦Ò—èUèÅG(ír¯Æg‘Q}J?ng‹}´Ñ¬ =¡]0/Oš|'ΰèiô˜så<â1G½m6Õ¥c‰C…Š]÷^ü¾+Än­OMÔØåFÉ8©u)ÕÑ  ‘4'ƒ*àBÞ*Ês¯ ë,¡'Ï(Æ­)8aÎÅL'+&ˆ’¥lÜ+æl¼ŒJ)#âžQBü€iΙlÛrUõ¡Ý~¢1eÕÉëU_Å<¾-åñ+¬A¼BOÙHªŸ:ô)B"Ôh Á5ŠP£5úrCâ‡ÀxSo*|o*¼À' z=ý÷Ô^xÜhÈã¶ö‹xL…ž,oò|ô(Çí!?u´b"3£7Í•eæs~–`ÞÙBiõÉŠ'ä5êv:5tjèÔЩ¡SC§†N :5tjèÔЩ¡SC§~Ž:u¶H¤ºœ®”]µ]ù…¶ mÚ*´Uh«ÐV¡­B[…¶ mÚ*´Uh«ÐV-=TÞ¥K³U€2 2:%ô@èСB„=z ô@èСBüøz`6_J /_qd¬ŽÅªkPŽ A9‚råÊ”#(GPŽ A9‚rôÄ”£l¾šÏ´›æó+h>Ð| ù@óæÍš4h>Ð| ù@óyVšÏ\j>³OÈk ”*ƒÃ:ë8¬ã°ŽÃ:ë8¬ã°ŽÃ:ë8¬·Ö³¹|"w?‡¿Å9çpœÃqÇ9çpœÃqÇ9çpœÃ{ŸÃ§ò¾è‡¿ÁAqÄqÇAqÄqÇAqÄ{Äsy_öÄqÇAqÄqÇAqÄqÇAñþñLijɊ§ñÎÄ̱‡Zjq¨Å¡‡Zjq¨Å¡‡ZjçP›ÍåóY{h}û‡VZqhÅ¡‡VZqhÅ¡‡VZ?ú¡U¾ôœ¥+ŽŒ;=Ï¢8óá̇3Î|8óá̇3Î|8ó}´3_6—O¦fY·Ý%t8Ðá@‡t8Ðá@‡tOæ@7“/$fù*L>RG4\ppÁÁ\ppÁÁ—؃K6“ï–eÓþç‘ßá<‚óÎ#8à<‚óÎ#8œx‘¯ e³þç‘_ã<‚óÎ#8à<‚óÎ#8œx‘¯ªdóÕ…Ú Ô#îrôBdTòØI8ÌåêS£=b2ÚÉÐt·—/j*¦Òµä¿Ùì‹ëÃåMq}»®»ÖO”ßË‘˜^‡Íõˆ©öZ´þýÖù"ê/+Um^Ò É{À>Àâ‡A[O’g­àY‹ Íw»{/Ì·—»½}æíÊ2ý“ýYØ9€³Î~ŸÁÙ^'ÖZoo¬ÙÁ⬺¿ÿ}ÄJ{‡Oº©šùjsøyóP¸[Yˆ…É}!Ž8Œ82Ù®À/ÝYÜQ±Â^Äñ›nœÝ%îlŽáqòFµŠ£¦E¡A‡¿F30yò¤LÊ"µ 2øp€žÊ½y3: _ñ‚ØðÉTŒä1ÿ ø9ļ=ùËYªCÊqS´DFÜ’—zåái„ L¦˜`WqE$¡fÛ¬H$Á*ªü‰ÁNüµº0¨X¢å# Xü™­¢Ê> ÎE HíÐ{¨¯ˆÒ'€ñ`X2_è1dŠJ­ÇÝ©€3UÁ}S™ì2£Æ·Ì¡3Rea>Vff ž[¬¢A01ª÷â÷]!¦ï¥[)ýñ(èÕMñn-¶$ɽ/nŽ×…¨€ _»\]PŒ‚®I®UU±5ŽÇc©ýØyu“XÕUkuT²Þz„ˇûâZuÌðijîõ•­µÕc=Ä .ñ¥¢°Û¯ß—‚âá¡ÉíÅÔ«jì"˵iûg@Áñ´½Š{wÜ^Û]éÙb¹AÐGõñ°µ¿ˆy´m%ÛïÅÚ(ö­„%œÝF&ûU,ì Kw³Úmn˜<õñ½t§ I)¿ÞQ”£?ÿ~·»e ¼ÞÝÝß¿D ‹õ(«øØ·ÎSäÅöx×FSö”:Ð=²Ù‚˜yšf³½Ýl¥ªó«ÿ°ÛbH¤¸6Bñ+nFqBmÚé±ÅÇÛ*ív·}AÑ¥[ÚEÚ¤±µìPÙ~uîSõØ’ŽÛîSÁ㉥Ž—+±G3ÛûÒ—ß·˜˜Ò®?¬÷‘cÛNjT "&öó’Xe…InvÇ+µ hÊ–Ö¤ôÖ_}3þ sÛètÝâéËÒãìZ[|ì÷¨þZËüÒz%Ž¿?ÊP²™ÇŽÆn+ól‚šÊµó¨Ôó¶§y.9fkìïu"‰^ d¢ÖBO`¯Œw}Ší[–Ù)æG})“ôùç¢þm(¶RIÕrê4¥Ÿ—=Þ/JÕ/gUª0‰zÍ4éJ)®Uª4ârI׉ P»” -é*T»X“¡«©²?¸M½$‘Ã}kJ’™îÙÕ©ê¤JW1Òz&iÏ&y©;»T•ŒªæB©j3OÍ¥¦´2‘>‰—i~ɲ*“âÌÕ`°zYI%;‹WP«I(kÁâ¤Lâ.f¢|4Ÿ¬xîV$EC j0¡t¢ðµ›&ŠJj,Š@S$¹ô]Q® Úm%†˜òÖª'DÀi‹ñYkóOc uƧpn ÷eÈ«-º“ƒR%;–x1<ðà×. xðÀƒ<ðàbË2“–¤5!SÓäÑý5ÓÌË­wŪ"‰ë£›Íä[¬yÊxyÊI26ñz¥¼Ú4[ÙlÒ»Íá“R$TÁ¶rÏÈÚyu£Ié;Ûýàèþ²»K9Wmzpœ†ÙŸÐIÖ—Ó ùªWŸtçâ¢;JiÖC_ %Ž«×j!’½SÅQT,Oا圩6)³?‚„ìp0>ècǯ<šP㺜³z„gzP0üÚá×îѯ~íðk‡_;üÚá׿vøµÃ¯~íðkoã9§_{ŒJe* ”áò6RéjcP„Ä~jÀ Ü¡d;´9ß‹ŒGñ >­ØGÍxh“Ÿï矗'M¾gXô4z̹rž ñ˜£Þ6›ã®<Œ»‡ ÀµûÊ’qRêR.d¼i®ÕHûX˜¹¢”ƶ0‰6qã–n¹á–Û³¸å–¨Eí›_ªÜÜʵL?UUfÍu¶*©‡ëŠe¡WŽ5–³F¦C¹—¨òI›`™?Wõ»’—]hyf¤Ê; k»wÈÇné­2zîöa¹ñŸÃV9óéo¯þ‰ç–Ó xÄvAÆãÕî±:»c÷(Æ;ôè-ÇÚ`ôžc_ËÕ_ì×nšØò•³yT; Ü}àîsNî>Ý}z¹Û0»J½¬Û)‚ˆ"= z@ô€èÑ Íf zÑÓúxGEýëš8¼ð! U›æ« —IÐxrTDgSUèu¾é:ÌÔ˜fÓDÖ{±ºˆôÁè&ÝžWß%ÃÑ7£áîþpy½»)Ä?wr3Qõå«ÛÝV'ýµÐÕ,¶7n"ѹ ß,WË[ßšÓ¥îe>sLæ Hqº›k$PTFŹ“GJ­;B O'‡UnÍEáý~ýþn¢¨áÏúN›txõ]è®Wße¥#/ö›ÑÀ1¬ou§9/–æ&F.(ÅXò^GHd|wÜÞ˜ƒq‚|Jœ9%ª¥_§ .¬™`ì‡; D9"þNý¥#9Wý¬ëNpM‡k:\ÓášnŽ,\Óáš×t¸¦Ã5®épM‡kúSvMç´Ò>ªî¸QvåY”„ ôÏ !™ÀpÏ×îIzº5pE“>« M‰nésE,s>s™êoÌEJû*Œ½TÊD5A\¦Ì“}á8eVn×ÌÈ™šÝoƒH%…ìn“+IÔù‡ pg TŸNh´ïþ(w±Þ«òª,eqI4Þm€Ïb¯w­×nš(!…Óœöà´×:ØOÆi¯ýŽß Î{±MÈ·W§§øö~®¡ÃÐ5x£otàŽ&ÞèÐ…áŽ2ot\â¯x£ot”óotà£:x££­x£ã³££U#= zÌç/O+öôOsÔð5a•Êõs?XIÒøgEšt<+bZ“Oõ¬ÈWÖ$UTxiDçŸí¥‘\õžÉE›Ù4?Åb€üÁ«ˆÀkEâš®94¸æ€kn™¸æ€k¸æ`ãš®9”³fƒk/øšÃ‰ÊiEä·²‘â&n2<ß› åÛ5”o>WÞ±Ó6¬‹‹UÇì#2fÌt#”ª#T¹ûÏc„âð¤ÙLŠY´Ša=´Ç•Eò\ÌÔu‡eŒXÉÈÕ.•Qˆf“(1Õê€krîy)ñ$ó™ÌgI̬¥ÁþÐqž™ð‡v„ÁþÐð‡†?4ü¡á høCÃ:¢ð‡þìý¡yU4 ÐO ø`šá¯L9éj/Éý#c *´‹¨Íà Wà§í œ,r¸?†+ðLÁàéŠh–€qüU}¯ÅÝZr}—þ,[•X·XºÄyY`ÚØ2Œ4QT¾â¬3œ/ùš4á̦ñ/ô‹›Ãô¥*|¶ ïÅŽœq$SÃ3ï_”¦a‹R€ö¢QþaŒ-JMõeï¢Æô骿´Î'¿ 4êTÊ|;Ÿ®õb07äL`eŒ$µü~m%Íè±Èå;ó Æ¢»Ötþ±6äy²êRÃq›6ÖMVXKdŒ1J®î®¯­ŽHÝCH¦| ¨¾‘_yúÜû†ANìæp.>âQu`ˆX,ª  Ý²£éÊÙEÖÛHKèî˜J¯‰yþ»ƒBÄNíŽ\ž!æÓçØÎxroÈcÎ|ö{ƒoOî y›‹óeǺŒ9е»œŽ 0_Ÿ3U‡Ã`ÝÀýr¬ÌaÑþÖHiï@Ù)Fš‚—ÞÚiKfó“ÊÉ|=߈²vŸ4¢ê„._z‹¯ó8hdê&(`öâ½n–;Ý‘oìîPGé_ÙiS¦‹äáp!”˜ÎóÆDìlÕíûÂj s–›Êy‘¬º?Ž²Ë²ÒbMåº-²Ú¼Q8•'EºêZø8h©çÐÎnº-·ÚÂ|)gR7[ˆ36Ïû¦ÂÊõȶxê<õàϸÏÀ3î:¦½·,zÖQ_ð¬;UŽ~²âo–-#yb–×s›K?¾!´Ýêù© š„©–·q¦ú¹Î+!ŸIõdÑ9ȸCˆ8Bˆ#„8B†ÄB!ÄjHGq„:s Žâ!Žâ!Žâµi d!©2\ãˆWþÚ™!±UÑÞHú¸ÖEÄPT,[‡ŽÙX*x@¨á}žh|„ÒÎ!÷ñj|òÌÁiÅ>ÚhžüFìø1æåI“ïÄ=s®œgB<樷Í渇Ç݈[¢Þõ|¥¹Un”Œ“*P—⼋«Þ$·ßÅÕP¼‰Î«eá*q*œXóE«DJx=Ì©!ˆÐøy„Ì”¡ÓŠÑ—i‡­éªííïqëëàá#>ŽØ8bãˆ#6ŽØ8bª#vÔZ9÷8÷µõñµ›&>œ³ÕEã¼$…TwoZS¡x‰’”Ÿî|uẔ 7il¤ †rtL 7SNåâNy›Å:aH,£òº ¯¾K†£oFÃÝýáòzw#ŽA»»nbiîº~š÷v}UÜŠÓ¦Qm‡BžuwÇmˆÄpQå‰D9åQ‘¥Q¾]-49Þݲ×w¡ÆÜ[¼p[y‰n+Þœ.'Wã (ƒ¥Ó€a]¯ŠQík}’â”·F.½¿¦JÚã5Ì Ät§ÜB”*›X¦eî¦t¡·]xÍfõ玊[Ù×QÂ~Þ®?´U†ØKJþŸ?( ¡/ûÍΪ8/Mõ'/çÝn¯ÙJ\¹i µgÛƒæ%ÙUµwÄRúûTÖÍ9/kC’Š ~ØlÅ(@sµ/Ö?†öÅá(1wº‰…µc7›¸+ÈÚº5Ù—:íî`ÎêJ¶Ú%3 yÍœ?á?¸j|$?8gþ—óìáNïŽ'¼¶=wáÄ»ãáþxx8‘[þÞlÏ+Hþ¼¾Ý]]©Clï»O'V>¼áÕ¯Fx5«^ðj„WãG÷jD<ÖƒIð”B౞z0Ïõ<µxwïîŒwwðîÞÝy¹ïîÐ_rî;>n¾äò×›&”Ê$iï¿œ…è“?è‚g[>v”#ÜÌÜÌ8Ï›6c{i¡Ñ¼9œ;"-%ËI5c¤/‡Áò¹“e²"¿éŒIdæ ÒÎøu¼Œ ¿¶¯ÕåSùNÇ2]=é:Ê«ËŒ«c»‚[]êÃ2ï"x%WM•i¹Ú†Ã ”Þ—³ÕÅzÿ^q]~X_ÿ(ó™}M^‚Œ%¥£V"ú ¢¯àjèGél\ ÅÕP\ ÅÕÐ'}%7C1Ô—?‰[¦ò„2W'Ú«EÐÚGÿR©†—^;IBî¢E.9™ ù3_þLÊ_¶Ö›Î+Õ³Yƒ“$ÑŠO§Sd¨ˆßgëÜUtr©¼æ“ÞjZ|m¿wõ3âh hzŠX>‘Ï·rHXÿëÜ\¾žOÒNa“°ÞðXÅa™Èr²ÓË oôL_§²ðüäÂÙ Ûì…šr2¸‹‡O†.ê”ï™YÑbÖ vÚk7M9ÓEV÷fdy+•²NzËvëñûb`uqÇd‘=eÒüà·†rFϪ‘[ õ-Êó9.W&N»ÁUNÒà*U·+tÚ ö[7M ϼӌ09ænPErSW±Ê¿õˆ®èĆÑÏ6e¾ö(áqRÒšóñÔ6ù·Â·Î'&Ÿzˆ[^ÁÑÀ*gî}µäë²ùD Iu+5°äå †þ¦›˜†| y­¾ÉÐgÈ2¡v63j¨vMA&e+N¤š=…¼LÿÈ vü};t„Õx§¿Ù›ÁF’VØàÓ¹ˆˆ{¸€{¸€{æÚÁ=€—wàE¼‰Ë¸<h0.àò.¼ÜËpøwA¾Oñìð'¿À¿`Œ›ûæÀyœãmç]mÑ|»H+{€ƒ;UȢ꘱å躈x:×>¥&ÆVåäVŽØ>Ol«R¹2ÑÚ•ò\ÂœËH˜ó¥=Ä׳e#ÖNûÆMäÉdEBƒ J•§ ×ÿpÓ„ìd嶜@N9QšKQ’®¨ÎåaSÊB¤ñä1‘ö½›&JÌVÎ@s¸+mSÓMÏ=!¾¡[Ë%Q£%Qs5nÓá­ÍD‘d»x‘IQ3R“$7ɼžKU,Î7–"Ë>W¿ ØC¥Î¥E/Yöµ[û…ٜߌÜkyn³Lãt*—íÏÆ)wTêäÊ“™84›éaéÞàE„úà|;1Ày€óçΓKà¼O pà<Ày€óçÎœ8pà¼W*Àù' ÎG+¡ròLâƒYU.`Ï¥SpšðÐýÔ¥ThŸ9ºy&aÉ4í/2µ¢_<»`ŸãW,è1ë[?&X÷>Tk§Ló[ñ®•S ñ²Õy[Û^ªY^ã¥á&†‚­o+L=­èX'ÌÛh,V®‡bÎI ?Õf=ˈÛ_®Ã[yx+Oñã­<¼•×Ñ †§Ë^ÎÓe0JÂ( £$Œ’0JškFÉ—g”„}öÅ‚`_,kûb}‡}öÅ ì‹ ^û€YðišÏñ ÞA0ÓŸü;x†`@>0gòÖMº`LqœéˆµìM•|¹ª^Vq‚øÑûVÌ=&ϲ^n†¯Ý´AžMˆrš;otŽäWŽ*6'Š•–Õ,ñŠ­fsØÜIÈÕ¥4q\ïn ñÏ]ݵ_¾ºÝmu’Y¼úìQ eŒú<“ÎÞk7žÃfC$Îä=¯,ëg±˜6J|7Û¼ŠÀ[0lÁ°³•-¶`Ø‚a †-˜e€-¸ú¶`Ø‚a †-¶`Ø‚a †-x[°}‡-¶à Y„-¸?ÀIÁC@N6å{K,q|e`‰ƒ%–8Xâ`‰c`‰«þ„%–8Xâ`‰ƒ%–8Xâ`‰ÛÀgÅa‰ƒ%.HKCK,q°ÄÁg$Á÷ô,qòI¨lÆ?ŸÆÃü0ÄÁC_â`ˆƒ!†8âXâª?aˆƒ!†8â`ˆƒ!†8â60ÄÙGqâ`ˆ ’ÁÇPÁC q0ÄI0Ä=9CÜD=Å3ç q<ê?&qï B-”þ€4ÀÔ6b€©S¦L%—ÀTŸ`jLíeõ ¶‡ °em€ÀÖçw °@`ƒd@`ªGG`;iŸ°¥ð¡d–Ê}¶Pn KåL'òéòl±rr¿Æ!$ÊñLu8õSâ%þ63ÐÐêlÕ¹]Ùi¢VKŽ‹tžG¸ÏÚèìt"Ï'¢h[²Ý4É#›G=ë-fƒ¬.n ÙgÕü‘0 éKþƒ5zcuÚ%—6vÓDii]ßFMD¤ên$šCT Tünš($ëPHÕv= ÉÀ”ÄF=:Ј$­p à§íÄÀOŸ?~J.!à§>-ðSà§ÀOŸ?~ üø)ðSà§^©ÀOŸ$~jû\.¦êBÖÏÁ*q&Ѳ|åf‡”A‰›H æ2ŠH>]]˜W¸E¾u±üõh86R1yèUàª> ºOn²Hä¤ùÁ¿ OH9ãyœÝ—JàT'åyh­çj»µ›V ¤BrgºcËûðrWU_ª´A“Íö¤«H:qé 9cG ŒíÝ©òZæzwªü”­æV¹ûkÏì×DÚÊM3_.ä]㌉VŠ —ìá >•]Àkš¥é}«rÚöbÍ´SÛ«šXõ|¹´Kûk+iÙô{5dÕJ1ÛWåÉGEòEï!Q1|3Èbîïw:íµ›&Š_®œ…,gê¸ÇÕ ­èz¡ÎùR6d:YQ+ÊN;ë×ؾ\Bª‰ö¡ _ÎÈŸ¦òã2M¼‹œF©cb‘&ÄbNˆE/gÎ4]]ÜlöÅõáò¦¸¾]×Ç?QŽ©:¨«Ã­lPù%•F½Í5c«¬íl„ÉNÚGE²sàˆí9áj<ó.¢[}® iœÊSÇ+÷Vny>À}ƒö2ØËÚ…Á^{ìe°—Á^{ìe°—Á^ÑFØË>{Ù)šèþ½Ê¹ü°¾þQIjþÔåWˆ€d|¸/®Õ'ña¸¾Ÿµ…t`\0bËïÜn¿~_H—à‡‡&·S¯ ¨þŽ,צí_\²t¡íUÜ»ãöÚÎèJÏË ‚žÉëãa7j#*~§›m+Ù¾x/fq±o%,Ѫ62Ù¯7Å;Aç ¨Îþi·¹aòÔáïÒ2$¥<FQŽþüûÝî–)PÆæ¸-~‰$éQ,RqŽ;n!§È‹íñ®¦ì)µ•Í|ÔµW'Þ“ùÓN~Ìo ._ìRâX{-ù‰™§i6ÛÛÍVJ :¿ø»ý!†DŠk#ܼß7£8¡6m„ôØâãŠm•v»Û¾ èÒ-í"mÒØZv¨l¿:÷©zlIÇm÷©àñÄRÇKŽ•Ø£™í}éËï[LLi×Öûȱm'5*PûyI¬²Â$7»ã•Ú4eKkRz믾йmtºnñôeéñ v­->ö{T­e~ ¾Šƒê…°J6óØÑÀž±2Ï&¨©\;J=o{J‘ç’c¶ÆþþW'2‘èµ@&jˆÖ(ñö {ˆèSlß²ÌN1<%L'“ôùç¢þ-³´1W9Ÿi9ušòÂ({¼NT.Õ¬ªS• Z½fšteŽ¯Uª< Ê%]'*ŸµK5i*ö›±‹5ÊX¬m“¨¼Îä®l¤eÚÍåWm+?qMêT P5#Yµ®>ãªyõáÐÈP-ÔGJ#U6љҖ®názc[f&Ú‹†_•A~pØåJ"Õ!ú¬n¤Êþà6õ’Dv÷­©.ñêþؘ]ªNªt#]‡J, óMòRwv©*3TÍ…RÕ2fžš JM3he"}/ Òr(ì£|™™U™g®ƒÕËJ*ÙY¼‚Z)Ç €¨¼.rxë^ÅÑËñ*nq!Εãt¶òw‡xlS;^ÙUßïJù7Í9'$Ê·XâO•ó‘ëuÏ”ØâiÕ‘š¼ Ž ·UL”ÙÚå*0•¢ýox/¬§æôÉ]%àW“5ÌDh<ò”æé猟ŸÃS£€Ê6 0_fƒA>›¬˜ÙÚØÆôMÝT Lâa2)~Ü7³vÌ[±;¹Èy7:Dh_O,°¨Ù$«+kï›'~Ô­žSçVh2@¿xF4íÅãPˆb‚8V+€òåéå(OŸÜ„ñµ7Xe^„þ ÓLKôÓLK/×´t* QûJ”(…1”(P @ €±,%¼.(ÑK(QëÖ%J”xj Äçë0ó”œÉp¹òã\®,ß.ÆôUÊï­¤hϦOígköUõó³]Î$@¤ª©{‹ïÔaRÕf‡«²æ6—S›\EÇŸ¥+j#kÝÿ¸Pñ™¼y:Ë:…ܯoñS±÷»‡Ü_È'¾gy]ênëý€ƒ\0Qi¦\â¦1¢‚ï0ج†wž> 4ó¡™ @€ $Èvä d_1 @€É䀉èn3º›Œ¹6›õF¥€Wªà»y_ÑtÍÇE¸7­Ð0Ý" ¦ „¥t*K°ÓîóÒÿäö;ôˆ;lìØ!°C`‡À;vì0¢À;vìð%b‡ ÕÕûó=FD½€“d3î[H¸o÷uvùKÓ™>Ÿ´ “ç^üyWˆU¢Ÿ!ª°ÞP"¢ó$F4•¨Z§m¢¹%ÈÁW>—%d'–@uÙ˜ !¸P-ju½ •g¡.P[ã×,ÜÛí²„:ã á§õQ2~=÷øXšy¹®ûôBm ­¾ÁmãÚÕ¤gÞjçi+á«Qe#ñ?e*Óß«s¦FÒd3oµµT¨“‘H9·‰ZJdÌFÕ ,–Ç(ö9[«zµö+ö+دڅÁ~ûìW°_Á~ûìW°_Á~ÑFد`¿‚ý ö+د^¤ýjò©ìWúY¯24ÒeˆˆùruQü"¦®lœñĺ‚Xuƨ>¼*ýäÕwéâÐÚÊ«ï2ýP“Zz·»mqy½»»3 Ø,IT^±½ñR©°‰ ö±hµõÀ÷:À¹ÓL"Ú‹VcZZ„pôDš'ÙÙà '@Î @N€œ9íý '@N€œQ 9Í '@Î(€œ9+F€œ9r¾lsªü,'¹m÷r£OT¹'»o·ÕUPäÉŽ³ˆ™8pà8Àq€ãÇŽ8n8Ψ à¸úü8p\,Ž{¡wöb‚k:n<éÇ "( ÐÏU>{'Ý}ïìC^7_D…?îñh³™Ê˜‹Óã # (`7*øÊYÞ`KSxd٥ͯ²SGÊ€ ËdÅÌáHxfÜ4ÔÛy ½‘܉Ï|¹Ï’qjþ¡úçVÿ¨ðµ•¤†)]1{S °Á¾‡lØ Nc¹‚gªä|uÁ"¢‚–GK_+(U¥_~X_ÿ¨#cè7Õã‚˦›$Qèô”BéIî>÷ ŸËÂÅ6¹~¸»Ü÷Gýí´¿²rMM£R½0™®GêË=M¥ÏürîÖZî½ZåTS܆¸û€´/-Zº3¡E’668b›Š<¨ß›­úYMòѳÓÓ…:Í~C¤½vÓDM–º&¥H9Œ^kßñ2aÐP’X…J:N'2]è 9#JÆž\­÷b§“4pœN2uF0ZV îd0˜N&ºK¯owWWÅ^uªÜ-|x÷Œí" 4—m›ÞC¬•M&Þì‘i¢©‰ßTëoýqÛ}úÔw ñ£}MÍý¨JZÈ:§+{ìäÈ{ÌÊO·CÉÐlb®¨Q´SÆÎi&¬KGµÐ֦ɔœP©žõ¹»‘È)Ø”é0ÒåÌß”tÚÊMò§æ†\Ï´êOý¥ª÷ë1!%%JK‰Z¥²4ñÑŠ:(ŽIºvyÖ|Œ4Q øÞ¨±P׬䳸+gÃèÝn¯×F)\Ìüõñ¡îîíï7r»‰¿•s¹”6¸pråô$©0¸ð`AêDà“™µàÎðw€¿C#6üàïø;ÀßþðwpÁßA— ø;Àßá¥ú;ÀöîBz°½ÃöþòmïÉRö•“g²̪ÐËÜÇúæ ^¬yÆ_ãvÅv7;tŽ~þ Ü%f¬•ÒoäÚ3…¦3±.yŒ.ÃBÿXsø\"žÉduñPÜׄð‡Ÿ7‡ë}¥'RzÂKß¼k“<·…dö&ûV‹3z-qû@cî-^¯õ.¡`Ãv†‘8?££°Ž3qÊé2réýÞ/hP"Ì ¨Ár‡Qï$<¥Êf¦å¸}bžÂ¿|Çq{ »óŽ£6Â{ÔÖ]oܼœ6›°ÅÆ^;¥ô÷»ÃÎ6¤ËÚ¤b‚6Ûc1 Ð\í‹õ!‚}q8Ê ît + km7ËÝd-r{z8ÜÝå£Ç¼9ºöiˆæ°Œ”'qÛžçdÙÑû[µaÄk'†F<ñ`Ä#—Œx>-ŒxA#ìq°Çõ{\YØãê£8ìq°ÇÉ`c¨Ý÷É l0£=O3ZGC®ŽêöD”)®Æ隌l^Þ¡¹Ô[%Jh¤«Î/±H#YU¯1Õï 5RUÏ+üÕHTsíÆ&T“­DxduUª‚¡t5ë6æ¼HõŘo¬¤„1O¦êN‘TjŒ^V]Q ZÝèµe¦J'9cñN'²ÑˆZeÎÊá 3e/ø8n•+;ƒA¹+µ·Ðx~I’Ø&[š&QS›²„TʪOc*‚Lír^Æ4W&ÈŒ·žF£þãÊ`kŽù4—ÖÙ$?Ë 'iìÚ[q¶”EOWÁÛ=ú†¥«{{§-jµãZa Â@„"ü´a\댬)`äF `dÀÈ€‘#3ù/ FƵàÑÏôZÇ4“—4’µ'&—«_¸o>Ï¥ðù9Âq¹¾”dl®eÚi¯Ý4Q­EKt%Ÿë£Ju•ÉX=ɲGh"7z•KNÖFÆòÃU%^‡Ê´Á4´; ‡+òÜ•i+7M•´ÄSñ)câÇ}ÚáœÊ¶¤üìµHÄãÊr)*;1fõîðia>€ùæ˜`>€ùæƒi>8 [Pš0õ8E–Á2Ë,Ñ˱LØ.Ù‹i„±b!ëç@Z:+ÏUÇŒM·mÝWß[I²›lø®ÊÉ­œ·«²§F¶U©\Å‘O[_®ïùªQè=¥Lú?§­Ïaõ|˜*ø’“´ ¥­ObòÈ`°x9+m}ë”⻼1•©ê´>¤ÕR³=y•I›KÖúÌVêtŸ(ò)"Q¡ß5Áé#Wl–~ü鬔µ“í4Acm5Ò®”åÝìJµMÕ±·áòì´ßºi¢ÌiÓdЈG¾¤â?e½¤’‡^RÉf'ZO=ñ ¦TÿÑ™&*9ÛãYó¦ Ø}Róf.M†Yïømwnl9„M4g"=fH§EC`Á¦1,H –;Œ,¨ùX·þâ@`A„ü@bØá?øÀäiûÀ¥.=Á¥£¬ \:ê£8\:àÒ$ÃP† á.ñ4Ý%X«ÌÏ>° 4…æ“3”cÍYäçÒpŸò‚šk'á‹’ÖÇ<},ëcD¤E6ÏÚã:’©ûº Â/`AøH¢<ïat¿I·¥pÝæ·€|q£˜ üè:#ôBâ»îûÔn2Íåíð|Ö¯!­7Œsyi>pL@xÌF,ì°kÀ®»ìæÚ]ãåÙ5p¿Æ`Ma iÄÀcŒ!0†0ù/Ì‚K¨°ª<×𘹂/Ïs‡%+³E@œÚ>ˆk-ùòdä»–XoN`Â^žNzA„¶*F"ÎD$O¶rÓÿ?PK@5K‡Ç¦ufc® ¤lang.txtUT(Ë…Yux MPKN¨nyacc-1.00.2/test-suite/nyacc/lang/c99/c99-02.test0000644000175100000240000000367513605250515020702 0ustar mwettedialout;; nyacc/lang/c99/c99-02.test -*- scheme -*- ;; ;; Copyright (C) 2016-2017 Matthew R. Wette ;; ;; Copying and distribution of this file, with or without modification, ;; are permitted in any medium without royalty provided the copyright ;; notice and this notice are preserved. This file is offered as-is, ;; without any warranty. ;; test C99 parser in code mode (define-module (c99-02) #:use-module (nyacc lang c99 parser) #:use-module (test-suite lib)) (define incs '("exam.d")) (define (parse-string str) (with-input-from-string str (lambda () (parse-c99 #:inc-dirs incs #:mode 'code)))) (define (parse-file file) (with-input-from-file file (lambda () (parse-c99 #:inc-dirs incs #:mode 'code)))) ;; parser test (with-test-prefix "nyacc/c99-02, code mode" ;; Get a simple statement to parse. (pass-if "simple" (let ((sx (parse-string "int x;"))) (equal? sx '(trans-unit (decl (decl-spec-list (type-spec (fixed-type "int"))) (init-declr-list (init-declr (ident "x")))))))) ;; parse with include file ;; needs work ? (pass-if "include, code mode" (let* ((sx (parse-file "exam.d/ex01.c"))) (pair? sx))) ;; parse massive comments file (pass-if "comments, wanted and unwanted" (let* ((sx (parse-file "exam.d/ex02.c"))) (pair? sx))) ;; try to get all C99 in one file (pass-if "lots of C99 in one file" (let* ((sx (parse-file "exam.d/ex05.c"))) (pair? sx))) ;; appears in libxlsxwriter #;(pass-if "typedef name is parameter" (pair? (parse-string "typedef int t; int foo(t *t);"))) ;; typedef scoping (pass-if "typedef scoping" (pair? (parse-file "exam.d/ex19.c"))) ;; __attributes__ (pass-if "__attribute__ parsing" (and (pair? (parse-string "int foo(void) __attribute__((const));")) (pair? (parse-file "exam.d/ex20.c")))) ;; __asm__ (pass-if "__asm__ parsing" (pair? (parse-file "exam.d/ex21.c"))) ) ;; --- last line --- nyacc-1.00.2/test-suite/nyacc/lang/c99/c99-03.test0000644000175100000240000000240013605250515020664 0ustar mwettedialout;; nyacc/lang/c99/c99-03.test -*- scheme -*- ;; ;; Copyright (C) 2016-2017 Matthew R. Wette ;; ;; Copying and distribution of this file, with or without modification, ;; are permitted in any medium without royalty provided the copyright ;; notice and this notice are preserved. This file is offered as-is, ;; without any warranty. ;; test C99 parser in file mode (define-module (c99-03) #:use-module (nyacc lang c99 parser) #:use-module (nyacc lang c99 util) #:use-module (test-suite lib)) (define incs '("exam.d")) (define (parse-string str) (with-input-from-string str (lambda () (parse-c99 #:inc-dirs incs #:mode 'file #:inc-help c99-std-help)))) (define (parse-file file) (with-input-from-file file (lambda () (parse-c99 #:inc-dirs incs #:mode 'file)))) ;; parser test (with-test-prefix "nyacc/c99-03, file mode" ;; parse with include file (pass-if "included files" (let* ((sx (with-input-from-file "exam.d/ex01.c" (lambda () (parse-c99 #:inc-dirs incs #:mode 'file))))) (pair? sx))) ;; parse massive comments file (pass-if "comments, wanted and unwanted" (let* ((sx (with-input-from-file "exam.d/ex02.c" (lambda () (parse-c99 #:inc-dirs incs #:mode 'file))))) (pair? sx))) ) ;; --- last line --- nyacc-1.00.2/test-suite/nyacc/lang/c99/c99-06.test0000644000175100000240000000615113605250515020676 0ustar mwettedialout;; nyacc/lang/c99/c99-06.test -*- scheme -*- ;; ;; Copyright (C) 2017,2019 Matthew R. Wette ;; ;; Copying and distribution of this file, with or without modification, ;; are permitted in any medium without royalty provided the copyright ;; notice and this notice are preserved. This file is offered as-is, ;; without any warranty. ;; test C99 munge utilities (define-module (c99-06) #:use-module (nyacc lang c99 parser) #:use-module (nyacc lang c99 util) #:use-module (nyacc lang c99 munge) #:use-module (nyacc lang c99 pprint) #:use-module ((sxml xpath) #:select (sxpath)) #:use-module (test-suite lib)) (use-modules (ice-9 pretty-print)) (define pp pretty-print) (define incs '("exam.d")) (define (parse-string str) (with-input-from-string str (lambda () (parse-c99 #:inc-dirs incs #:mode 'decl #:inc-help c99-std-help)))) (define (parse-file file) (with-input-from-file file (lambda () (parse-c99 #:inc-dirs incs #:mode 'decl)))) (define (c99pp sx) (with-output-to-string (lambda () (pretty-print-c99 sx)))) (define (test-expand-typerefs code indx xcode) (let* ((tree (parse-string code)) (udict (c99-trans-unit->udict tree)) (decl (and=> ((sxpath `((decl ,indx))) tree) car)) (xdecl (expand-typerefs decl udict)) (ncode (c99pp xdecl))) ;;(newline) (display code) (display ncode) (string=? ncode xcode))) ;; parser test (with-test-prefix "nyacc/c99-06, munging" (pass-if "expand-typerefs w/ function declarator" (test-expand-typerefs (string-append "typedef int *foo_t;\n" "typedef double hmm_t[3];\n" "int bar(foo_t (*baz)(hmm_t y));\n") 3 ;; => "int bar(int *(*baz)(double y[3]));\n")) (pass-if "expand-typerefs w/ enum-ref" (test-expand-typerefs "enum foo x;\n" 1 ;; => "int x;\n")) (pass-if "expand-typerefs w/ enum typedef" (test-expand-typerefs "typedef enum _foo foo_t;\nfoo_t x;\n" 2 ;; => "int x;\n")) (pass-if "expand struct-ref w/ struct-def" (test-expand-typerefs (string-append "struct foo { int a; double b; };\n" "struct foo x;\n") 2 "struct foo {\n int a;\n double b;\n} x;\n")) (pass-if "knarly expand-typeref case" (test-expand-typerefs (string-append "typedef int *bla_t[2];\n" "bla_t foo(bla_t (*)(bla_t));\n") 2 "int *foo(int *(*)(int)[2])[2];\n")) (pass-if "canize-enum-def-list" (let* ((code "enum { FOO = 1, }; enum { BAR = 1 + FOO };") (tree (parse-string code)) (udict (c99-trans-unit->udict tree)) (ddict (c99-trans-unit->ddict tree)) (ddict (udict-enums->ddict udict ddict))) (and (string= "1" (or (assoc-ref ddict "FOO") "X")) (string= "2" (or (assoc-ref ddict "BAR") "X"))))) #;(pass-if "knarly expand-typeref case" (let ((code (string-append "typedef struct foo foo_t;\n" "struct foo {\n" "int (*bar)(foo_t*);" "};\n" "int baz(foo_t*);" )) (udict (c100-trans-unit->udict tree)) (udecl (udict-ref udict "baz"))) (pair? (expand-typerefs udecl udict '(foo_t))))) ) ;; --- last line --- nyacc-1.00.2/test-suite/Makefile.in0000644000175100000240000000205413605250515016567 0ustar mwettedialout# @configure_input@ # -*- Makefile -*- # # Copyright (C) 2016,2019-2020 Matthew R. Wette # # Copying and distribution of this file, with or without modification, # are permitted in any medium without royalty provided the copyright # notice and this notice are preserved. This file is offered as-is, # without any warranty. GUILE = @GUILE@ GUILD = @abs_top_builddir@/etc/guild SITE_SCM_DIR = @GUILE_SITE@ SITE_SCM_GO_DIR = @GUILE_SITE_GO@ SHELL = @SHELL@ SCMDIR = @abs_top_srcdir@/test-suite GODIR = @abs_top_builddir@/module TESTENV = GUILE_LOAD_PATH= GUILE_AUTO_COMPILE=0 $(GUILE) -C $(GODIR) -L $(SCMDIR) TESTS = \ nyacc/lex-01.test \ nyacc/lalr-01.test \ nyacc/lang/util.test \ nyacc/lang/sx-util.test \ nyacc/lang/c99/c99-01.test \ nyacc/lang/c99/c99-02.test \ nyacc/lang/c99/c99-03.test \ nyacc/lang/c99/c99-04.test \ nyacc/lang/c99/c99-05.test \ nyacc/lang/c99/c99-06.test .PHONY: check check: @for test in $(TESTS); do \ (cd $(SCMDIR)/`dirname $${test}`; $(TESTENV) `basename $${test}`); \ done # --- last line --- nyacc-1.00.2/etc/0000755000175100000240000000000013605250515013166 5ustar mwettedialoutnyacc-1.00.2/etc/pkg.m40000644000175100000240000002401113605250515014207 0ustar mwettedialoutdnl pkg.m4 - Macros to locate and utilise pkg-config. -*- Autoconf -*- dnl serial 11 (pkg-config-0.29.1) dnl dnl Copyright © 2004 Scott James Remnant . dnl Copyright © 2012-2015 Dan Nicholson dnl dnl This program is free software; you can redistribute it and/or modify dnl it under the terms of the GNU General Public License as published by dnl the Free Software Foundation; either version 2 of the License, or dnl (at your option) any later version. dnl dnl This program is distributed in the hope that it will be useful, but dnl WITHOUT ANY WARRANTY; without even the implied warranty of dnl MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU dnl General Public License for more details. dnl dnl You should have received a copy of the GNU General Public License dnl along with this program; if not, write to the Free Software dnl Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA dnl 02111-1307, USA. dnl dnl As a special exception to the GNU General Public License, if you dnl distribute this file as part of a program that contains a dnl configuration script generated by Autoconf, you may include it under dnl the same distribution terms that you use for the rest of that dnl program. dnl PKG_PREREQ(MIN-VERSION) dnl ----------------------- dnl Since: 0.29 dnl dnl Verify that the version of the pkg-config macros are at least dnl MIN-VERSION. Unlike PKG_PROG_PKG_CONFIG, which checks the user's dnl installed version of pkg-config, this checks the developer's version dnl of pkg.m4 when generating configure. dnl dnl To ensure that this macro is defined, also add: dnl m4_ifndef([PKG_PREREQ], dnl [m4_fatal([must install pkg-config 0.29 or later before running autoconf/autogen])]) dnl dnl See the "Since" comment for each macro you use to see what version dnl of the macros you require. m4_defun([PKG_PREREQ], [m4_define([PKG_MACROS_VERSION], [0.29.1]) m4_if(m4_version_compare(PKG_MACROS_VERSION, [$1]), -1, [m4_fatal([pkg.m4 version $1 or higher is required but ]PKG_MACROS_VERSION[ found])]) ])dnl PKG_PREREQ dnl PKG_PROG_PKG_CONFIG([MIN-VERSION]) dnl ---------------------------------- dnl Since: 0.16 dnl dnl Search for the pkg-config tool and set the PKG_CONFIG variable to dnl first found in the path. Checks that the version of pkg-config found dnl is at least MIN-VERSION. If MIN-VERSION is not specified, 0.9.0 is dnl used since that's the first version where most current features of dnl pkg-config existed. AC_DEFUN([PKG_PROG_PKG_CONFIG], [m4_pattern_forbid([^_?PKG_[A-Z_]+$]) m4_pattern_allow([^PKG_CONFIG(_(PATH|LIBDIR|SYSROOT_DIR|ALLOW_SYSTEM_(CFLAGS|LIBS)))?$]) m4_pattern_allow([^PKG_CONFIG_(DISABLE_UNINSTALLED|TOP_BUILD_DIR|DEBUG_SPEW)$]) AC_ARG_VAR([PKG_CONFIG], [path to pkg-config utility]) AC_ARG_VAR([PKG_CONFIG_PATH], [directories to add to pkg-config's search path]) AC_ARG_VAR([PKG_CONFIG_LIBDIR], [path overriding pkg-config's built-in search path]) if test "x$ac_cv_env_PKG_CONFIG_set" != "xset"; then AC_PATH_TOOL([PKG_CONFIG], [pkg-config]) fi if test -n "$PKG_CONFIG"; then _pkg_min_version=m4_default([$1], [0.9.0]) AC_MSG_CHECKING([pkg-config is at least version $_pkg_min_version]) if $PKG_CONFIG --atleast-pkgconfig-version $_pkg_min_version; then AC_MSG_RESULT([yes]) else AC_MSG_RESULT([no]) PKG_CONFIG="" fi fi[]dnl ])dnl PKG_PROG_PKG_CONFIG dnl PKG_CHECK_EXISTS(MODULES, [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND]) dnl ------------------------------------------------------------------- dnl Since: 0.18 dnl dnl Check to see whether a particular set of modules exists. Similar to dnl PKG_CHECK_MODULES(), but does not set variables or print errors. dnl dnl Please remember that m4 expands AC_REQUIRE([PKG_PROG_PKG_CONFIG]) dnl only at the first occurence in configure.ac, so if the first place dnl it's called might be skipped (such as if it is within an "if", you dnl have to call PKG_CHECK_EXISTS manually AC_DEFUN([PKG_CHECK_EXISTS], [AC_REQUIRE([PKG_PROG_PKG_CONFIG])dnl if test -n "$PKG_CONFIG" && \ AC_RUN_LOG([$PKG_CONFIG --exists --print-errors "$1"]); then m4_default([$2], [:]) m4_ifvaln([$3], [else $3])dnl fi]) dnl _PKG_CONFIG([VARIABLE], [COMMAND], [MODULES]) dnl --------------------------------------------- dnl Internal wrapper calling pkg-config via PKG_CONFIG and setting dnl pkg_failed based on the result. m4_define([_PKG_CONFIG], [if test -n "$$1"; then pkg_cv_[]$1="$$1" elif test -n "$PKG_CONFIG"; then PKG_CHECK_EXISTS([$3], [pkg_cv_[]$1=`$PKG_CONFIG --[]$2 "$3" 2>/dev/null` test "x$?" != "x0" && pkg_failed=yes ], [pkg_failed=yes]) else pkg_failed=untried fi[]dnl ])dnl _PKG_CONFIG dnl _PKG_SHORT_ERRORS_SUPPORTED dnl --------------------------- dnl Internal check to see if pkg-config supports short errors. AC_DEFUN([_PKG_SHORT_ERRORS_SUPPORTED], [AC_REQUIRE([PKG_PROG_PKG_CONFIG]) if $PKG_CONFIG --atleast-pkgconfig-version 0.20; then _pkg_short_errors_supported=yes else _pkg_short_errors_supported=no fi[]dnl ])dnl _PKG_SHORT_ERRORS_SUPPORTED dnl PKG_CHECK_MODULES(VARIABLE-PREFIX, MODULES, [ACTION-IF-FOUND], dnl [ACTION-IF-NOT-FOUND]) dnl -------------------------------------------------------------- dnl Since: 0.4.0 dnl dnl Note that if there is a possibility the first call to dnl PKG_CHECK_MODULES might not happen, you should be sure to include an dnl explicit call to PKG_PROG_PKG_CONFIG in your configure.ac AC_DEFUN([PKG_CHECK_MODULES], [AC_REQUIRE([PKG_PROG_PKG_CONFIG])dnl AC_ARG_VAR([$1][_CFLAGS], [C compiler flags for $1, overriding pkg-config])dnl AC_ARG_VAR([$1][_LIBS], [linker flags for $1, overriding pkg-config])dnl pkg_failed=no AC_MSG_CHECKING([for $1]) _PKG_CONFIG([$1][_CFLAGS], [cflags], [$2]) _PKG_CONFIG([$1][_LIBS], [libs], [$2]) m4_define([_PKG_TEXT], [Alternatively, you may set the environment variables $1[]_CFLAGS and $1[]_LIBS to avoid the need to call pkg-config. See the pkg-config man page for more details.]) if test $pkg_failed = yes; then AC_MSG_RESULT([no]) _PKG_SHORT_ERRORS_SUPPORTED if test $_pkg_short_errors_supported = yes; then $1[]_PKG_ERRORS=`$PKG_CONFIG --short-errors --print-errors --cflags --libs "$2" 2>&1` else $1[]_PKG_ERRORS=`$PKG_CONFIG --print-errors --cflags --libs "$2" 2>&1` fi # Put the nasty error message in config.log where it belongs echo "$$1[]_PKG_ERRORS" >&AS_MESSAGE_LOG_FD m4_default([$4], [AC_MSG_ERROR( [Package requirements ($2) were not met: $$1_PKG_ERRORS Consider adjusting the PKG_CONFIG_PATH environment variable if you installed software in a non-standard prefix. _PKG_TEXT])[]dnl ]) elif test $pkg_failed = untried; then AC_MSG_RESULT([no]) m4_default([$4], [AC_MSG_FAILURE( [The pkg-config script could not be found or is too old. Make sure it is in your PATH or set the PKG_CONFIG environment variable to the full path to pkg-config. _PKG_TEXT To get pkg-config, see .])[]dnl ]) else $1[]_CFLAGS=$pkg_cv_[]$1[]_CFLAGS $1[]_LIBS=$pkg_cv_[]$1[]_LIBS AC_MSG_RESULT([yes]) $3 fi[]dnl ])dnl PKG_CHECK_MODULES dnl PKG_CHECK_MODULES_STATIC(VARIABLE-PREFIX, MODULES, [ACTION-IF-FOUND], dnl [ACTION-IF-NOT-FOUND]) dnl --------------------------------------------------------------------- dnl Since: 0.29 dnl dnl Checks for existence of MODULES and gathers its build flags with dnl static libraries enabled. Sets VARIABLE-PREFIX_CFLAGS from --cflags dnl and VARIABLE-PREFIX_LIBS from --libs. dnl dnl Note that if there is a possibility the first call to dnl PKG_CHECK_MODULES_STATIC might not happen, you should be sure to dnl include an explicit call to PKG_PROG_PKG_CONFIG in your dnl configure.ac. AC_DEFUN([PKG_CHECK_MODULES_STATIC], [AC_REQUIRE([PKG_PROG_PKG_CONFIG])dnl _save_PKG_CONFIG=$PKG_CONFIG PKG_CONFIG="$PKG_CONFIG --static" PKG_CHECK_MODULES($@) PKG_CONFIG=$_save_PKG_CONFIG[]dnl ])dnl PKG_CHECK_MODULES_STATIC dnl PKG_INSTALLDIR([DIRECTORY]) dnl ------------------------- dnl Since: 0.27 dnl dnl Substitutes the variable pkgconfigdir as the location where a module dnl should install pkg-config .pc files. By default the directory is dnl $libdir/pkgconfig, but the default can be changed by passing dnl DIRECTORY. The user can override through the --with-pkgconfigdir dnl parameter. AC_DEFUN([PKG_INSTALLDIR], [m4_pushdef([pkg_default], [m4_default([$1], ['${libdir}/pkgconfig'])]) m4_pushdef([pkg_description], [pkg-config installation directory @<:@]pkg_default[@:>@]) AC_ARG_WITH([pkgconfigdir], [AS_HELP_STRING([--with-pkgconfigdir], pkg_description)],, [with_pkgconfigdir=]pkg_default) AC_SUBST([pkgconfigdir], [$with_pkgconfigdir]) m4_popdef([pkg_default]) m4_popdef([pkg_description]) ])dnl PKG_INSTALLDIR dnl PKG_NOARCH_INSTALLDIR([DIRECTORY]) dnl -------------------------------- dnl Since: 0.27 dnl dnl Substitutes the variable noarch_pkgconfigdir as the location where a dnl module should install arch-independent pkg-config .pc files. By dnl default the directory is $datadir/pkgconfig, but the default can be dnl changed by passing DIRECTORY. The user can override through the dnl --with-noarch-pkgconfigdir parameter. AC_DEFUN([PKG_NOARCH_INSTALLDIR], [m4_pushdef([pkg_default], [m4_default([$1], ['${datadir}/pkgconfig'])]) m4_pushdef([pkg_description], [pkg-config arch-independent installation directory @<:@]pkg_default[@:>@]) AC_ARG_WITH([noarch-pkgconfigdir], [AS_HELP_STRING([--with-noarch-pkgconfigdir], pkg_description)],, [with_noarch_pkgconfigdir=]pkg_default) AC_SUBST([noarch_pkgconfigdir], [$with_noarch_pkgconfigdir]) m4_popdef([pkg_default]) m4_popdef([pkg_description]) ])dnl PKG_NOARCH_INSTALLDIR dnl PKG_CHECK_VAR(VARIABLE, MODULE, CONFIG-VARIABLE, dnl [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND]) dnl ------------------------------------------- dnl Since: 0.28 dnl dnl Retrieves the value of the pkg-config variable for the given module. AC_DEFUN([PKG_CHECK_VAR], [AC_REQUIRE([PKG_PROG_PKG_CONFIG])dnl AC_ARG_VAR([$1], [value of $3 for $2, overriding pkg-config])dnl _PKG_CONFIG([$1], [variable="][$3]["], [$2]) AS_VAR_COPY([$1], [pkg_cv_][$1]) AS_VAR_IF([$1], [""], [$5], [$4])dnl ])dnl PKG_CHECK_VAR nyacc-1.00.2/etc/guile.m40000644000175100000240000003636513605250515014552 0ustar mwettedialout## Autoconf macros for working with Guile. ## ## Copyright (C) 1998,2001, 2006, 2010, 2012, 2013, 2014 Free Software Foundation, Inc. ## ## This library is free software; you can redistribute it and/or ## modify it under the terms of the GNU Lesser General Public License ## as published by the Free Software Foundation; either version 3 of ## the License, or (at your option) any later version. ## ## This library is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ## Lesser General Public License for more details. ## ## You should have received a copy of the GNU Lesser General Public ## License along with this library; if not, write to the Free Software ## Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA ## 02110-1301 USA # serial 10 ## Index ## ----- ## ## GUILE_PKG -- find Guile development files ## GUILE_PROGS -- set paths to Guile interpreter, config and tool programs ## GUILE_FLAGS -- set flags for compiling and linking with Guile ## GUILE_SITE_DIR -- find path to Guile "site" directories ## GUILE_CHECK -- evaluate Guile Scheme code and capture the return value ## GUILE_MODULE_CHECK -- check feature of a Guile Scheme module ## GUILE_MODULE_AVAILABLE -- check availability of a Guile Scheme module ## GUILE_MODULE_REQUIRED -- fail if a Guile Scheme module is unavailable ## GUILE_MODULE_EXPORTS -- check if a module exports a variable ## GUILE_MODULE_REQUIRED_EXPORT -- fail if a module doesn't export a variable ## Code ## ---- ## NOTE: Comments preceding an AC_DEFUN (starting from "Usage:") are massaged ## into doc/ref/autoconf-macros.texi (see Makefile.am in that directory). # GUILE_PKG -- find Guile development files # # Usage: GUILE_PKG([VERSIONS]) # # This macro runs the @code{pkg-config} tool to find development files # for an available version of Guile. # # By default, this macro will search for the latest stable version of # Guile (e.g. 2.2), falling back to the previous stable version # (e.g. 2.0) if it is available. If no guile-@var{VERSION}.pc file is # found, an error is signalled. The found version is stored in # @var{GUILE_EFFECTIVE_VERSION}. # # If @code{GUILE_PROGS} was already invoked, this macro ensures that the # development files have the same effective version as the Guile # program. # # @var{GUILE_EFFECTIVE_VERSION} is marked for substitution, as by # @code{AC_SUBST}. # AC_DEFUN([GUILE_PKG], [PKG_PROG_PKG_CONFIG _guile_versions_to_search="m4_default([$1], [2.2 2.0 1.8])" if test -n "$GUILE_EFFECTIVE_VERSION"; then _guile_tmp="" for v in $_guile_versions_to_search; do if test "$v" = "$GUILE_EFFECTIVE_VERSION"; then _guile_tmp=$v fi done if test -z "$_guile_tmp"; then AC_MSG_FAILURE([searching for guile development files for versions $_guile_versions_to_search, but previously found $GUILE version $GUILE_EFFECTIVE_VERSION]) fi _guile_versions_to_search=$GUILE_EFFECTIVE_VERSION fi GUILE_EFFECTIVE_VERSION="" _guile_errors="" for v in $_guile_versions_to_search; do if test -z "$GUILE_EFFECTIVE_VERSION"; then AC_MSG_NOTICE([checking for guile $v]) PKG_CHECK_EXISTS([guile-$v], [GUILE_EFFECTIVE_VERSION=$v], []) fi done if test -z "$GUILE_EFFECTIVE_VERSION"; then AC_MSG_ERROR([ No Guile development packages were found. Please verify that you have Guile installed. If you installed Guile from a binary distribution, please verify that you have also installed the development packages. If you installed it yourself, you might need to adjust your PKG_CONFIG_PATH; see the pkg-config man page for more. ]) fi AC_MSG_NOTICE([found guile $GUILE_EFFECTIVE_VERSION]) AC_SUBST([GUILE_EFFECTIVE_VERSION]) ]) # GUILE_FLAGS -- set flags for compiling and linking with Guile # # Usage: GUILE_FLAGS # # This macro runs the @code{pkg-config} tool to find out how to compile # and link programs against Guile. It sets four variables: # @var{GUILE_CFLAGS}, @var{GUILE_LDFLAGS}, @var{GUILE_LIBS}, and # @var{GUILE_LTLIBS}. # # @var{GUILE_CFLAGS}: flags to pass to a C or C++ compiler to build code that # uses Guile header files. This is almost always just one or more @code{-I} # flags. # # @var{GUILE_LDFLAGS}: flags to pass to the compiler to link a program # against Guile. This includes @code{-lguile-@var{VERSION}} for the # Guile library itself, and may also include one or more @code{-L} flag # to tell the compiler where to find the libraries. But it does not # include flags that influence the program's runtime search path for # libraries, and will therefore lead to a program that fails to start, # unless all necessary libraries are installed in a standard location # such as @file{/usr/lib}. # # @var{GUILE_LIBS} and @var{GUILE_LTLIBS}: flags to pass to the compiler or to # libtool, respectively, to link a program against Guile. It includes flags # that augment the program's runtime search path for libraries, so that shared # libraries will be found at the location where they were during linking, even # in non-standard locations. @var{GUILE_LIBS} is to be used when linking the # program directly with the compiler, whereas @var{GUILE_LTLIBS} is to be used # when linking the program is done through libtool. # # The variables are marked for substitution, as by @code{AC_SUBST}. # AC_DEFUN([GUILE_FLAGS], [AC_REQUIRE([GUILE_PKG]) PKG_CHECK_MODULES(GUILE, [guile-$GUILE_EFFECTIVE_VERSION]) dnl GUILE_CFLAGS and GUILE_LIBS are already defined and AC_SUBST'd by dnl PKG_CHECK_MODULES. But GUILE_LIBS to pkg-config is GUILE_LDFLAGS dnl to us. GUILE_LDFLAGS=$GUILE_LIBS dnl Determine the platform dependent parameters needed to use rpath. dnl AC_LIB_LINKFLAGS_FROM_LIBS is defined in gnulib/m4/lib-link.m4 and needs dnl the file gnulib/build-aux/config.rpath. AC_LIB_LINKFLAGS_FROM_LIBS([GUILE_LIBS], [$GUILE_LDFLAGS], []) GUILE_LIBS="$GUILE_LDFLAGS $GUILE_LIBS" AC_LIB_LINKFLAGS_FROM_LIBS([GUILE_LTLIBS], [$GUILE_LDFLAGS], [yes]) GUILE_LTLIBS="$GUILE_LDFLAGS $GUILE_LTLIBS" AC_SUBST([GUILE_EFFECTIVE_VERSION]) AC_SUBST([GUILE_CFLAGS]) AC_SUBST([GUILE_LDFLAGS]) AC_SUBST([GUILE_LIBS]) AC_SUBST([GUILE_LTLIBS]) ]) # GUILE_SITE_DIR -- find path to Guile site directories # # Usage: GUILE_SITE_DIR # # This looks for Guile's "site" directories. The variable @var{GUILE_SITE} will # be set to Guile's "site" directory for Scheme source files (usually something # like PREFIX/share/guile/site). @var{GUILE_SITE_CCACHE} will be set to the # directory for compiled Scheme files also known as @code{.go} files # (usually something like # PREFIX/lib/guile/@var{GUILE_EFFECTIVE_VERSION}/site-ccache). # @var{GUILE_EXTENSION} will be set to the directory for compiled C extensions # (usually something like # PREFIX/lib/guile/@var{GUILE_EFFECTIVE_VERSION}/extensions). The latter two # are set to blank if the particular version of Guile does not support # them. Note that this macro will run the macros @code{GUILE_PKG} and # @code{GUILE_PROGS} if they have not already been run. # # The variables are marked for substitution, as by @code{AC_SUBST}. # AC_DEFUN([GUILE_SITE_DIR], [AC_REQUIRE([GUILE_PKG]) AC_REQUIRE([GUILE_PROGS]) AC_MSG_CHECKING(for Guile site directory) GUILE_SITE=`$PKG_CONFIG --print-errors --variable=sitedir guile-$GUILE_EFFECTIVE_VERSION` AC_MSG_RESULT($GUILE_SITE) if test "$GUILE_SITE" = ""; then AC_MSG_FAILURE(sitedir not found) fi AC_SUBST(GUILE_SITE) AC_MSG_CHECKING([for Guile site-ccache directory using pkgconfig]) GUILE_SITE_CCACHE=`$PKG_CONFIG --variable=siteccachedir guile-$GUILE_EFFECTIVE_VERSION` if test "$GUILE_SITE_CCACHE" = ""; then AC_MSG_RESULT(no) AC_MSG_CHECKING([for Guile site-ccache directory using interpreter]) GUILE_SITE_CCACHE=`$GUILE -c "(display (if (defined? '%site-ccache-dir) (%site-ccache-dir) \"\"))"` if test $? != "0" -o "$GUILE_SITE_CCACHE" = ""; then AC_MSG_RESULT(no) GUILE_SITE_CCACHE="" AC_MSG_WARN([siteccachedir not found]) fi fi AC_MSG_RESULT($GUILE_SITE_CCACHE) AC_SUBST([GUILE_SITE_CCACHE]) AC_MSG_CHECKING(for Guile extensions directory) GUILE_EXTENSION=`$PKG_CONFIG --print-errors --variable=extensiondir guile-$GUILE_EFFECTIVE_VERSION` AC_MSG_RESULT($GUILE_EXTENSION) if test "$GUILE_EXTENSION" = ""; then GUILE_EXTENSION="" AC_MSG_WARN(extensiondir not found) fi AC_SUBST(GUILE_EXTENSION) ]) # GUILE_PROGS -- set paths to Guile interpreter, config and tool programs # # Usage: GUILE_PROGS([VERSION]) # # This macro looks for programs @code{guile} and @code{guild}, setting # variables @var{GUILE} and @var{GUILD} to their paths, respectively. # The macro will attempt to find @code{guile} with the suffix of # @code{-X.Y}, followed by looking for it with the suffix @code{X.Y}, and # then fall back to looking for @code{guile} with no suffix. If # @code{guile} is still not found, signal an error. The suffix, if any, # that was required to find @code{guile} will be used for @code{guild} # as well. # # By default, this macro will search for the latest stable version of # Guile (e.g. 2.2). x.y or x.y.z versions can be specified. If an older # version is found, the macro will signal an error. # # The effective version of the found @code{guile} is set to # @var{GUILE_EFFECTIVE_VERSION}. This macro ensures that the effective # version is compatible with the result of a previous invocation of # @code{GUILE_FLAGS}, if any. # # As a legacy interface, it also looks for @code{guile-config} and # @code{guile-tools}, setting @var{GUILE_CONFIG} and @var{GUILE_TOOLS}. # # The variables are marked for substitution, as by @code{AC_SUBST}. # AC_DEFUN([GUILE_PROGS], [_guile_required_version="m4_default([$1], [$GUILE_EFFECTIVE_VERSION])" if test -z "$_guile_required_version"; then _guile_required_version=2.2 fi _guile_candidates=guile _tmp= for v in `echo "$_guile_required_version" | tr . ' '`; do if test -n "$_tmp"; then _tmp=$_tmp.; fi _tmp=$_tmp$v _guile_candidates="guile-$_tmp guile$_tmp $_guile_candidates" done AC_PATH_PROGS(GUILE,[$_guile_candidates]) if test -z "$GUILE"; then AC_MSG_ERROR([guile required but not found]) fi _guile_suffix=`echo "$GUILE" | sed -e 's,^.*/guile\(.*\)$,\1,'` _guile_effective_version=`$GUILE -c "(display (effective-version))"` if test -z "$GUILE_EFFECTIVE_VERSION"; then GUILE_EFFECTIVE_VERSION=$_guile_effective_version elif test "$GUILE_EFFECTIVE_VERSION" != "$_guile_effective_version"; then AC_MSG_ERROR([found development files for Guile $GUILE_EFFECTIVE_VERSION, but $GUILE has effective version $_guile_effective_version]) fi _guile_major_version=`$GUILE -c "(display (major-version))"` _guile_minor_version=`$GUILE -c "(display (minor-version))"` _guile_micro_version=`$GUILE -c "(display (micro-version))"` _guile_prog_version="$_guile_major_version.$_guile_minor_version.$_guile_micro_version" AC_MSG_CHECKING([for Guile version >= $_guile_required_version]) _major_version=`echo $_guile_required_version | cut -d . -f 1` _minor_version=`echo $_guile_required_version | cut -d . -f 2` _micro_version=`echo $_guile_required_version | cut -d . -f 3` if test "$_guile_major_version" -gt "$_major_version"; then true elif test "$_guile_major_version" -eq "$_major_version"; then if test "$_guile_minor_version" -gt "$_minor_version"; then true elif test "$_guile_minor_version" -eq "$_minor_version"; then if test -n "$_micro_version"; then if test "$_guile_micro_version" -lt "$_micro_version"; then AC_MSG_ERROR([Guile $_guile_required_version required, but $_guile_prog_version found]) fi fi elif test "$GUILE_EFFECTIVE_VERSION" = "$_major_version.$_minor_version" -a -z "$_micro_version"; then # Allow prereleases that have the right effective version. true else as_fn_error $? "Guile $_guile_required_version required, but $_guile_prog_version found" "$LINENO" 5 fi elif test "$GUILE_EFFECTIVE_VERSION" = "$_major_version.$_minor_version" -a -z "$_micro_version"; then # Allow prereleases that have the right effective version. true else AC_MSG_ERROR([Guile $_guile_required_version required, but $_guile_prog_version found]) fi AC_MSG_RESULT([$_guile_prog_version]) AC_PATH_PROG(GUILD,[guild$_guile_suffix]) AC_SUBST(GUILD) AC_PATH_PROG(GUILE_CONFIG,[guile-config$_guile_suffix]) AC_SUBST(GUILE_CONFIG) if test -n "$GUILD"; then GUILE_TOOLS=$GUILD else AC_PATH_PROG(GUILE_TOOLS,[guile-tools$_guile_suffix]) fi AC_SUBST(GUILE_TOOLS) ]) # GUILE_CHECK -- evaluate Guile Scheme code and capture the return value # # Usage: GUILE_CHECK_RETVAL(var,check) # # @var{var} is a shell variable name to be set to the return value. # @var{check} is a Guile Scheme expression, evaluated with "$GUILE -c", and # returning either 0 or non-#f to indicate the check passed. # Non-0 number or #f indicates failure. # Avoid using the character "#" since that confuses autoconf. # AC_DEFUN([GUILE_CHECK], [AC_REQUIRE([GUILE_PROGS]) $GUILE -c "$2" > /dev/null 2>&1 $1=$? ]) # GUILE_MODULE_CHECK -- check feature of a Guile Scheme module # # Usage: GUILE_MODULE_CHECK(var,module,featuretest,description) # # @var{var} is a shell variable name to be set to "yes" or "no". # @var{module} is a list of symbols, like: (ice-9 common-list). # @var{featuretest} is an expression acceptable to GUILE_CHECK, q.v. # @var{description} is a present-tense verb phrase (passed to AC_MSG_CHECKING). # AC_DEFUN([GUILE_MODULE_CHECK], [AC_MSG_CHECKING([if $2 $4]) GUILE_CHECK($1,(use-modules $2) (exit ((lambda () $3)))) if test "$$1" = "0" ; then $1=yes ; else $1=no ; fi AC_MSG_RESULT($$1) ]) # GUILE_MODULE_AVAILABLE -- check availability of a Guile Scheme module # # Usage: GUILE_MODULE_AVAILABLE(var,module) # # @var{var} is a shell variable name to be set to "yes" or "no". # @var{module} is a list of symbols, like: (ice-9 common-list). # AC_DEFUN([GUILE_MODULE_AVAILABLE], [GUILE_MODULE_CHECK($1,$2,0,is available) ]) # GUILE_MODULE_REQUIRED -- fail if a Guile Scheme module is unavailable # # Usage: GUILE_MODULE_REQUIRED(symlist) # # @var{symlist} is a list of symbols, WITHOUT surrounding parens, # like: ice-9 common-list. # AC_DEFUN([GUILE_MODULE_REQUIRED], [GUILE_MODULE_AVAILABLE(ac_guile_module_required, ($1)) if test "$ac_guile_module_required" = "no" ; then AC_MSG_ERROR([required guile module not found: ($1)]) fi ]) # GUILE_MODULE_EXPORTS -- check if a module exports a variable # # Usage: GUILE_MODULE_EXPORTS(var,module,modvar) # # @var{var} is a shell variable to be set to "yes" or "no". # @var{module} is a list of symbols, like: (ice-9 common-list). # @var{modvar} is the Guile Scheme variable to check. # AC_DEFUN([GUILE_MODULE_EXPORTS], [GUILE_MODULE_CHECK($1,$2,$3,exports `$3') ]) # GUILE_MODULE_REQUIRED_EXPORT -- fail if a module doesn't export a variable # # Usage: GUILE_MODULE_REQUIRED_EXPORT(module,modvar) # # @var{module} is a list of symbols, like: (ice-9 common-list). # @var{modvar} is the Guile Scheme variable to check. # AC_DEFUN([GUILE_MODULE_REQUIRED_EXPORT], [GUILE_MODULE_EXPORTS(guile_module_required_export,$1,$2) if test "$guile_module_required_export" = "no" ; then AC_MSG_ERROR([module $1 does not export $2; required]) fi ]) ## guile.m4 ends here nyacc-1.00.2/etc/configure.ac0000644000175100000240000000371713605250515015464 0ustar mwettedialoutdnl configure.ac for guile-nyacc dnl Copyright (C) 2019-2020 Matthew R. Wette dnl dnl Copying and distribution of this file, with or without modification, dnl are permitted in any medium without royalty provided the copyright dnl notice and this notice are preserved. This file is offered as-is, dnl without any warranty. AC_INIT([nyacc], [1.00.2], [], [], [https://savannah.nongnu.org/project/nyacc]) AC_CONFIG_SRCDIR(module/nyacc) AC_CONFIG_AUX_DIR([etc]) AC_CONFIG_MACRO_DIR([etc]) m4_include([./pkg.m4]) m4_include([./guile.m4]) m4_include([./nyacc.m4]) AC_ARG_VAR([GUILE],[path to guile binary]) if test "x$ac_env_GUILE_set" = "xset"; then GUILE_EFFECTIVE_VERSION=`$GUILE -c "(display (effective-version))"` guile_libdir=`$GUILE -c "(display (assq-ref %guile-build-info 'libdir))"` PKG_PROG_PKG_CONFIG PKG_CONFIG_LIBDIR=$guile_libdir/pkgconfig export PKG_CONFIG_LIBDIR else GUILE_PKG([3.0 2.9 2.2 2.0]) GUILE_PROGS fi dnl AC_ARG_VAR([GUILE_SITE],[path to site sources]) GUILE_SITE_DIR dnl AC_ARG_VAR([GUILE_SITE_CCACHE],[path to site binaries]) GUILE_SITE_GO_DIR GUILE_DATA_DIR dnl AC_ARG_WITH(site-dir, [ --with-site-dir=PATH where to put .scm files], dnl ,with_site_dir=unspecified) dnl if test "_$with_site_dir" != "_unspecified"; then dnl GUILE_SITE=$with_site_dir dnl endif dnl AC_ARG_WITH(site-go-dir, [ --with-site-go-dir=PATH where to put .go files], dnl ,with_site_go_dir=unspecified) dnl if test "_$with_site_go_dir" != "_unspecified"; then dnl GUILE_SITE_GO=$with_site_go_dir dnl endif GUILE_MODULE_AVAILABLE([have_bytestructures],[(bytestructures guile)]) if test $have_bytestructures = "yes"; then NYACC_FH_BINS='$(NYACC_FH_BINS)' else NYACC_FH_BINS='' fi AC_SUBST([NYACC_FH_BINS]) AC_CONFIG_FILES([Makefile \ module/Makefile \ doc/nyacc/Makefile \ test-suite/Makefile \ examples/Makefile \ ]) AC_SUBST([installed_guile],$GUILE) AC_CONFIG_FILES([etc/guild],[chmod +x etc/guild]) AC_OUTPUT dnl --- last line --- nyacc-1.00.2/etc/install-sh0000755000175100000240000003546313605250515015205 0ustar mwettedialout#!/bin/sh # install - install a program, script, or datafile scriptversion=2014-09-12.12; # UTC # This originates from X11R5 (mit/util/scripts/install.sh), which was # later released in X11R6 (xc/config/util/install.sh) with the # following copyright and license. # # Copyright (C) 1994 X Consortium # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN # AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNEC- # TION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. # # Except as contained in this notice, the name of the X Consortium shall not # be used in advertising or otherwise to promote the sale, use or other deal- # ings in this Software without prior written authorization from the X Consor- # tium. # # # FSF changes to this file are in the public domain. # # Calling this script install-sh is preferred over install.sh, to prevent # 'make' implicit rules from creating a file called install from it # when there is no Makefile. # # This script is compatible with the BSD install script, but was written # from scratch. tab=' ' nl=' ' IFS=" $tab$nl" # Set DOITPROG to "echo" to test this script. doit=${DOITPROG-} doit_exec=${doit:-exec} # Put in absolute file names if you don't have them in your path; # or use environment vars. chgrpprog=${CHGRPPROG-chgrp} chmodprog=${CHMODPROG-chmod} chownprog=${CHOWNPROG-chown} cmpprog=${CMPPROG-cmp} cpprog=${CPPROG-cp} mkdirprog=${MKDIRPROG-mkdir} mvprog=${MVPROG-mv} rmprog=${RMPROG-rm} stripprog=${STRIPPROG-strip} posix_mkdir= # Desired mode of installed file. mode=0755 chgrpcmd= chmodcmd=$chmodprog chowncmd= mvcmd=$mvprog rmcmd="$rmprog -f" stripcmd= src= dst= dir_arg= dst_arg= copy_on_change=false is_target_a_directory=possibly usage="\ Usage: $0 [OPTION]... [-T] SRCFILE DSTFILE or: $0 [OPTION]... SRCFILES... DIRECTORY or: $0 [OPTION]... -t DIRECTORY SRCFILES... or: $0 [OPTION]... -d DIRECTORIES... In the 1st form, copy SRCFILE to DSTFILE. In the 2nd and 3rd, copy all SRCFILES to DIRECTORY. In the 4th, create DIRECTORIES. Options: --help display this help and exit. --version display version info and exit. -c (ignored) -C install only if different (preserve the last data modification time) -d create directories instead of installing files. -g GROUP $chgrpprog installed files to GROUP. -m MODE $chmodprog installed files to MODE. -o USER $chownprog installed files to USER. -s $stripprog installed files. -t DIRECTORY install into DIRECTORY. -T report an error if DSTFILE is a directory. Environment variables override the default commands: CHGRPPROG CHMODPROG CHOWNPROG CMPPROG CPPROG MKDIRPROG MVPROG RMPROG STRIPPROG " while test $# -ne 0; do case $1 in -c) ;; -C) copy_on_change=true;; -d) dir_arg=true;; -g) chgrpcmd="$chgrpprog $2" shift;; --help) echo "$usage"; exit $?;; -m) mode=$2 case $mode in *' '* | *"$tab"* | *"$nl"* | *'*'* | *'?'* | *'['*) echo "$0: invalid mode: $mode" >&2 exit 1;; esac shift;; -o) chowncmd="$chownprog $2" shift;; -s) stripcmd=$stripprog;; -t) is_target_a_directory=always dst_arg=$2 # Protect names problematic for 'test' and other utilities. case $dst_arg in -* | [=\(\)!]) dst_arg=./$dst_arg;; esac shift;; -T) is_target_a_directory=never;; --version) echo "$0 $scriptversion"; exit $?;; --) shift break;; -*) echo "$0: invalid option: $1" >&2 exit 1;; *) break;; esac shift done # We allow the use of options -d and -T together, by making -d # take the precedence; this is for compatibility with GNU install. if test -n "$dir_arg"; then if test -n "$dst_arg"; then echo "$0: target directory not allowed when installing a directory." >&2 exit 1 fi fi if test $# -ne 0 && test -z "$dir_arg$dst_arg"; then # When -d is used, all remaining arguments are directories to create. # When -t is used, the destination is already specified. # Otherwise, the last argument is the destination. Remove it from $@. for arg do if test -n "$dst_arg"; then # $@ is not empty: it contains at least $arg. set fnord "$@" "$dst_arg" shift # fnord fi shift # arg dst_arg=$arg # Protect names problematic for 'test' and other utilities. case $dst_arg in -* | [=\(\)!]) dst_arg=./$dst_arg;; esac done fi if test $# -eq 0; then if test -z "$dir_arg"; then echo "$0: no input file specified." >&2 exit 1 fi # It's OK to call 'install-sh -d' without argument. # This can happen when creating conditional directories. exit 0 fi if test -z "$dir_arg"; then if test $# -gt 1 || test "$is_target_a_directory" = always; then if test ! -d "$dst_arg"; then echo "$0: $dst_arg: Is not a directory." >&2 exit 1 fi fi fi if test -z "$dir_arg"; then do_exit='(exit $ret); exit $ret' trap "ret=129; $do_exit" 1 trap "ret=130; $do_exit" 2 trap "ret=141; $do_exit" 13 trap "ret=143; $do_exit" 15 # Set umask so as not to create temps with too-generous modes. # However, 'strip' requires both read and write access to temps. case $mode in # Optimize common cases. *644) cp_umask=133;; *755) cp_umask=22;; *[0-7]) if test -z "$stripcmd"; then u_plus_rw= else u_plus_rw='% 200' fi cp_umask=`expr '(' 777 - $mode % 1000 ')' $u_plus_rw`;; *) if test -z "$stripcmd"; then u_plus_rw= else u_plus_rw=,u+rw fi cp_umask=$mode$u_plus_rw;; esac fi for src do # Protect names problematic for 'test' and other utilities. case $src in -* | [=\(\)!]) src=./$src;; esac if test -n "$dir_arg"; then dst=$src dstdir=$dst test -d "$dstdir" dstdir_status=$? else # Waiting for this to be detected by the "$cpprog $src $dsttmp" command # might cause directories to be created, which would be especially bad # if $src (and thus $dsttmp) contains '*'. if test ! -f "$src" && test ! -d "$src"; then echo "$0: $src does not exist." >&2 exit 1 fi if test -z "$dst_arg"; then echo "$0: no destination specified." >&2 exit 1 fi dst=$dst_arg # If destination is a directory, append the input filename; won't work # if double slashes aren't ignored. if test -d "$dst"; then if test "$is_target_a_directory" = never; then echo "$0: $dst_arg: Is a directory" >&2 exit 1 fi dstdir=$dst dst=$dstdir/`basename "$src"` dstdir_status=0 else dstdir=`dirname "$dst"` test -d "$dstdir" dstdir_status=$? fi fi obsolete_mkdir_used=false if test $dstdir_status != 0; then case $posix_mkdir in '') # Create intermediate dirs using mode 755 as modified by the umask. # This is like FreeBSD 'install' as of 1997-10-28. umask=`umask` case $stripcmd.$umask in # Optimize common cases. *[2367][2367]) mkdir_umask=$umask;; .*0[02][02] | .[02][02] | .[02]) mkdir_umask=22;; *[0-7]) mkdir_umask=`expr $umask + 22 \ - $umask % 100 % 40 + $umask % 20 \ - $umask % 10 % 4 + $umask % 2 `;; *) mkdir_umask=$umask,go-w;; esac # With -d, create the new directory with the user-specified mode. # Otherwise, rely on $mkdir_umask. if test -n "$dir_arg"; then mkdir_mode=-m$mode else mkdir_mode= fi posix_mkdir=false case $umask in *[123567][0-7][0-7]) # POSIX mkdir -p sets u+wx bits regardless of umask, which # is incompatible with FreeBSD 'install' when (umask & 300) != 0. ;; *) # $RANDOM is not portable (e.g. dash); use it when possible to # lower collision chance tmpdir=${TMPDIR-/tmp}/ins$RANDOM-$$ trap 'ret=$?; rmdir "$tmpdir/a/b" "$tmpdir/a" "$tmpdir" 2>/dev/null; exit $ret' 0 # As "mkdir -p" follows symlinks and we work in /tmp possibly; so # create the $tmpdir first (and fail if unsuccessful) to make sure # that nobody tries to guess the $tmpdir name. if (umask $mkdir_umask && $mkdirprog $mkdir_mode "$tmpdir" && exec $mkdirprog $mkdir_mode -p -- "$tmpdir/a/b") >/dev/null 2>&1 then if test -z "$dir_arg" || { # Check for POSIX incompatibilities with -m. # HP-UX 11.23 and IRIX 6.5 mkdir -m -p sets group- or # other-writable bit of parent directory when it shouldn't. # FreeBSD 6.1 mkdir -m -p sets mode of existing directory. test_tmpdir="$tmpdir/a" ls_ld_tmpdir=`ls -ld "$test_tmpdir"` case $ls_ld_tmpdir in d????-?r-*) different_mode=700;; d????-?--*) different_mode=755;; *) false;; esac && $mkdirprog -m$different_mode -p -- "$test_tmpdir" && { ls_ld_tmpdir_1=`ls -ld "$test_tmpdir"` test "$ls_ld_tmpdir" = "$ls_ld_tmpdir_1" } } then posix_mkdir=: fi rmdir "$tmpdir/a/b" "$tmpdir/a" "$tmpdir" else # Remove any dirs left behind by ancient mkdir implementations. rmdir ./$mkdir_mode ./-p ./-- "$tmpdir" 2>/dev/null fi trap '' 0;; esac;; esac if $posix_mkdir && ( umask $mkdir_umask && $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir" ) then : else # The umask is ridiculous, or mkdir does not conform to POSIX, # or it failed possibly due to a race condition. Create the # directory the slow way, step by step, checking for races as we go. case $dstdir in /*) prefix='/';; [-=\(\)!]*) prefix='./';; *) prefix='';; esac oIFS=$IFS IFS=/ set -f set fnord $dstdir shift set +f IFS=$oIFS prefixes= for d do test X"$d" = X && continue prefix=$prefix$d if test -d "$prefix"; then prefixes= else if $posix_mkdir; then (umask=$mkdir_umask && $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir") && break # Don't fail if two instances are running concurrently. test -d "$prefix" || exit 1 else case $prefix in *\'*) qprefix=`echo "$prefix" | sed "s/'/'\\\\\\\\''/g"`;; *) qprefix=$prefix;; esac prefixes="$prefixes '$qprefix'" fi fi prefix=$prefix/ done if test -n "$prefixes"; then # Don't fail if two instances are running concurrently. (umask $mkdir_umask && eval "\$doit_exec \$mkdirprog $prefixes") || test -d "$dstdir" || exit 1 obsolete_mkdir_used=true fi fi fi if test -n "$dir_arg"; then { test -z "$chowncmd" || $doit $chowncmd "$dst"; } && { test -z "$chgrpcmd" || $doit $chgrpcmd "$dst"; } && { test "$obsolete_mkdir_used$chowncmd$chgrpcmd" = false || test -z "$chmodcmd" || $doit $chmodcmd $mode "$dst"; } || exit 1 else # Make a couple of temp file names in the proper directory. dsttmp=$dstdir/_inst.$$_ rmtmp=$dstdir/_rm.$$_ # Trap to clean up those temp files at exit. trap 'ret=$?; rm -f "$dsttmp" "$rmtmp" && exit $ret' 0 # Copy the file name to the temp name. (umask $cp_umask && $doit_exec $cpprog "$src" "$dsttmp") && # and set any options; do chmod last to preserve setuid bits. # # If any of these fail, we abort the whole thing. If we want to # ignore errors from any of these, just make sure not to ignore # errors from the above "$doit $cpprog $src $dsttmp" command. # { test -z "$chowncmd" || $doit $chowncmd "$dsttmp"; } && { test -z "$chgrpcmd" || $doit $chgrpcmd "$dsttmp"; } && { test -z "$stripcmd" || $doit $stripcmd "$dsttmp"; } && { test -z "$chmodcmd" || $doit $chmodcmd $mode "$dsttmp"; } && # If -C, don't bother to copy if it wouldn't change the file. if $copy_on_change && old=`LC_ALL=C ls -dlL "$dst" 2>/dev/null` && new=`LC_ALL=C ls -dlL "$dsttmp" 2>/dev/null` && set -f && set X $old && old=:$2:$4:$5:$6 && set X $new && new=:$2:$4:$5:$6 && set +f && test "$old" = "$new" && $cmpprog "$dst" "$dsttmp" >/dev/null 2>&1 then rm -f "$dsttmp" else # Rename the file to the real destination. $doit $mvcmd -f "$dsttmp" "$dst" 2>/dev/null || # The rename failed, perhaps because mv can't rename something else # to itself, or perhaps because mv is so ancient that it does not # support -f. { # Now remove or move aside any old file at destination location. # We try this two ways since rm can't unlink itself on some # systems and the destination file might be busy for other # reasons. In this case, the final cleanup might fail but the new # file should still install successfully. { test ! -f "$dst" || $doit $rmcmd -f "$dst" 2>/dev/null || { $doit $mvcmd -f "$dst" "$rmtmp" 2>/dev/null && { $doit $rmcmd -f "$rmtmp" 2>/dev/null; :; } } || { echo "$0: cannot unlink or rename $dst" >&2 (exit 1); exit 1 } } && # Now rename the file to the real destination. $doit $mvcmd "$dsttmp" "$dst" } fi || exit 1 trap '' 0 fi done # Local variables: # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "scriptversion=" # time-stamp-format: "%:y-%02m-%02d.%02H" # time-stamp-time-zone: "UTC" # time-stamp-end: "; # UTC" # End: nyacc-1.00.2/etc/nyacc.m40000644000175100000240000000164213605250515014530 0ustar mwettedialoutdnl nyacc.m4 dnl dnl Copyright (C) 2019-2020 Matthew R. Wette dnl dnl Copying and distribution of this file, with or without modification, dnl are permitted in any medium without royalty provided the copyright dnl notice and this notice are preserved. This file is offered as-is, dnl without any warranty. dnl GUILE_SITE_GO_DIR AC_DEFUN([GUILE_SITE_GO_DIR], [AC_MSG_CHECKING(for Guile site directory) GUILE_SITE_GO=`$GUILE -c '(display (%site-ccache-dir))'` AC_MSG_RESULT($GUILE_SITE_GO) if test "$GUILE_SITE_GO" = ""; then AC_MSG_FAILURE(sitedir not found) fi AC_SUBST(GUILE_SITE_GO) ]) dnl GUILE_DATA_DIR AC_DEFUN([GUILE_DATA_DIR], [AC_MSG_CHECKING(for Guile data directory) GUILE_DATA=`$GUILE -c "(display (assq-ref %guile-build-info 'datadir))"` AC_MSG_RESULT($GUILE_DATA) if test "$GUILE_DATA" = ""; then AC_MSG_FAILURE(datadir not found) fi AC_SUBST(GUILE_DATA) ]) # --- last line --- nyacc-1.00.2/etc/guild.in0000755000175100000240000000547613605250515014641 0ustar mwettedialout#!/bin/sh # -*- scheme -*- exec ${GUILE:-@installed_guile@} $GUILE_FLAGS -e '(@@ (guild) main)' -s "$0" "$@" !# ;;;; guild --- running scripts bundled with Guile ;;;; Andy Wingo --- April 2009 ;;;; ;;;; Copyright (C) 2009, 2010, 2011, 2013, 2014 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either ;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;;; Lesser General Public License for more details. ;;;; ;;;; You should have received a copy of the GNU Lesser General Public ;;;; License along with this library; if not, write to the Free ;;;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;;;; Boston, MA 02110-1301 USA (define-module (guild) #:use-module (ice-9 getopt-long) #:use-module (ice-9 command-line) #:autoload (ice-9 format) (format)) ;; Hack to provide scripts with the bug-report address. (module-define! the-scm-module '%guile-bug-report-address "@PACKAGE_BUGREPORT@") (define *option-grammar* '((help (single-char #\h)) (version (single-char #\v)))) (define (display-version) (version-etc "@PACKAGE_NAME@" (version) #:command-name "guild" #:license *LGPLv3+*)) (define (find-script s) (resolve-module (list 'scripts (string->symbol s)) #:ensure #f)) (define (main args) (if (defined? 'setlocale) (catch 'system-error (lambda () (setlocale LC_ALL "")) (lambda args (format (current-error-port) "warning: failed to install locale: ~a~%" (strerror (system-error-errno args)))))) (let* ((options (getopt-long args *option-grammar* #:stop-at-first-non-option #t)) (args (option-ref options '() '()))) (cond ((option-ref options 'help #f) (apply (module-ref (resolve-module '(scripts help)) 'main) args) (exit 0)) ((option-ref options 'version #f) (display-version) (exit 0)) ((find-script (if (null? args) "help" (car args))) => (lambda (mod) (exit (apply (module-ref mod 'main) (if (null? args) '() (cdr args)))))) (else (format (current-error-port) "guild: unknown script ~s~%" (car args)) (format (current-error-port) "Try `guild help' for more information.~%") (exit 1))))) nyacc-1.00.2/etc/README0000644000175100000240000000057613605250515014056 0ustar mwettedialoutetc/README Copyright (C) 2019 Matthew R. Wette Copying and distribution of this file, with or without modification, are permitted in any medium without royalty provided the copyright notice and this notice are preserved. This file is offered as-is, without any warranty. To rebuild `configure': $ autoconf -o ../configure The files guile.m4 and guild.in are from guile-2.9.7. nyacc-1.00.2/HACKING0000644000175100000240000000530313605250515013403 0ustar mwettedialout Copyright (C) 2015-2019 Matthew R. Wette Copying and distribution of this file, with or without modification, are permitted in any medium without royalty provided the copyright notice and this notice are preserved. This file is offered as-is, without any warranty. === This package can be installed or executed in situ. To play with example code and try modifications without installing: $ cd examples $ source env.sh === Hacking on the C99 parser ==== To play with the C99 code, in place, I recommend the following: After sourcing env.sh in the examples subdirectory, execute $ cd nyacc/lang/c99 $ ./cxp hello.c The Guile source program cxp will print out the parse tree for hello.c This is based on a C99 parser written with the NYACC parser generator. IF you modify module/nyacc/lang/c99/mach.scm you will need to rebuild the files in the subdirectory mach.d. To do this run, in guile, the following: (use-modules (nyacc lang c99 mach)) (use-modules (nyacc lang c99 cppmach)) (gen-c99-files ".") (compile-file "parser.scm") (gen-cpp-files ".") (compile-file "cpp.scm") === Nyacc eXtension languages (or not-exactly languages) $ guile ... scheme@(guile-user)> ,L nx-javascript Happy hacking with nx-javascript! To switch back, type `,L scheme'. nx-javascript@(guile-user)> var a = 1; nx-javascript@(guile-user)> ,L nx-octave Happy hacking with nx-octave! To switch back, type `,L nx-javascript'. nx-octave@(guile-user)> b = 2; nx-octave@(guile-user)> ,L nx-tcl Happy hacking with nx-tcl! To switch back, type `,L nx-octave'. nx-tcl@(guile-user)> set c 3 nx-tcl@(guile-user)> ,L scheme Happy hacking with Scheme! To switch back, type `,L nx-tcl'. scheme@(guile-user)> (+ a b) $1 = 3 scheme@(guile-user)> c $2 = "3" === Hacking on the FFI Helper ==== $ cd examples $ source env.sh # if you haven't done so previously $ guild compile-ffi ffi/cairo.ffi $ cd nyacc/lang/c99/ffi-exam $ guile demo-cairo.scm # should generate demo-cairo.png $ guile guile> (use-modules (nyacc lang c99 ffi-help)) guile> (use-modules (bytestructures guile)) guile> (use-modules (system ffi-help-rt)) guile> (use-modules ((system foreign) #:prefix ffi:)) guile> (define fh-llibs '()) guile> (define fexp (fh-cnvt-cdecl "fmod" "double fmod(double x,double y);") guile> ,pp exp $1 = (begin (define ~fmod (delay (fh-link-proc ffi:double "fmod" (list ffi:double ffi:double) fh-llibs))) (define (fmod x y) (let ((~x (unwrap~float x)) (~y (unwrap~float y))) ((force ~fmod) ~x ~y))) (export fmod)) guile> (eval exp (current-module)) guile> (fmod 2.3 0.5) $2 = 0.2999999999999998 nyacc-1.00.2/configure0000755000175100000240000034047013605250515014332 0ustar mwettedialout#! /bin/sh # Guess values for system-dependent variables and create Makefiles. # Generated by GNU Autoconf 2.69 for nyacc 1.00.2. # # # Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. # # # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo # Prefer a ksh shell builtin over an external printf program on Solaris, # but without wasting forks for bash or zsh. if test -z "$BASH_VERSION$ZSH_VERSION" \ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='print -r --' as_echo_n='print -rn --' elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in #( *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Unset variables that we do not need and which cause bugs (e.g. in # pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" # suppresses any "Segmentation fault" message there. '((' could # trigger a bug in pdksh 5.2.14. for as_var in BASH_ENV ENV MAIL MAILPATH do eval test x\${$as_var+set} = xset \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH # Use a proper internal environment variable to ensure we don't fall # into an infinite loop, continuously re-executing ourselves. if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then _as_can_reexec=no; export _as_can_reexec; # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed `exec'. $as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 as_fn_exit 255 fi # We don't want this to propagate to other subprocesses. { _as_can_reexec=; unset _as_can_reexec;} if test "x$CONFIG_SHELL" = x; then as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which # is contrary to our usage. Disable this feature. alias -g '\${1+\"\$@\"}'='\"\$@\"' setopt NO_GLOB_SUBST else case \`(set -o) 2>/dev/null\` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi " as_required="as_fn_return () { (exit \$1); } as_fn_success () { as_fn_return 0; } as_fn_failure () { as_fn_return 1; } as_fn_ret_success () { return 0; } as_fn_ret_failure () { return 1; } exitcode=0 as_fn_success || { exitcode=1; echo as_fn_success failed.; } as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then : else exitcode=1; echo positional parameters were not saved. fi test x\$exitcode = x0 || exit 1 test -x / || exit 1" as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1" if (eval "$as_required") 2>/dev/null; then : as_have_required=yes else as_have_required=no fi if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then : else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR as_found=false for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. as_found=: case $as_dir in #( /*) for as_base in sh bash ksh sh5; do # Try only shells that exist, to save several forks. as_shell=$as_dir/$as_base if { test -f "$as_shell" || test -f "$as_shell.exe"; } && { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then : CONFIG_SHELL=$as_shell as_have_required=yes if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then : break 2 fi fi done;; esac as_found=false done $as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } && { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then : CONFIG_SHELL=$SHELL as_have_required=yes fi; } IFS=$as_save_IFS if test "x$CONFIG_SHELL" != x; then : export CONFIG_SHELL # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed `exec'. $as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 exit 255 fi if test x$as_have_required = xno; then : $as_echo "$0: This script requires a shell more modern than all" $as_echo "$0: the shells that I found on your system." if test x${ZSH_VERSION+set} = xset ; then $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should" $as_echo "$0: be upgraded to zsh 4.3.4 or later." else $as_echo "$0: Please tell bug-autoconf@gnu.org about your system, $0: including any error possibly output before this $0: message. Then install a modern shell, or manually run $0: the script under such a shell if you do have one." fi exit 1 fi fi fi SHELL=${CONFIG_SHELL-/bin/sh} export SHELL # Unset more variables known to interfere with behavior of common tools. CLICOLOR_FORCE= GREP_OPTIONS= unset CLICOLOR_FORCE GREP_OPTIONS ## --------------------- ## ## M4sh Shell Functions. ## ## --------------------- ## # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p # as_fn_executable_p FILE # ----------------------- # Test if FILE is an executable regular file. as_fn_executable_p () { test -f "$1" && test -x "$1" } # as_fn_executable_p # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : eval 'as_fn_append () { eval $1+=\$2 }' else as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : eval 'as_fn_arith () { as_val=$(( $* )) }' else as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi $as_echo "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits as_lineno_1=$LINENO as_lineno_1a=$LINENO as_lineno_2=$LINENO as_lineno_2a=$LINENO eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) sed -n ' p /[$]LINENO/= ' <$as_myself | sed ' s/[$]LINENO.*/&-/ t lineno b :lineno N :loop s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ t loop s/-\n.*// ' >$as_me.lineno && chmod +x "$as_me.lineno" || { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } # If we had to re-execute with $CONFIG_SHELL, we're ensured to have # already done that, so ensure we don't try to do so again and fall # in an infinite loop. This has already happened in practice. _as_can_reexec=no; export _as_can_reexec # Don't try to exec as it changes $[0], causing all sort of problems # (the dirname of $[0] is not the place where we might find the # original and so on. Autoconf is especially sensitive to this). . "./$as_me.lineno" # Exit status is that of the last command. exit } ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -pR' fi else as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi as_test_x='test -x' as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" test -n "$DJDIR" || exec 7<&0 &1 # Name of the host. # hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, # so uname gets run too. ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` # # Initializations. # ac_default_prefix=/usr/local ac_clean_files= ac_config_libobj_dir=. LIBOBJS= cross_compiling=no subdirs= MFLAGS= MAKEFLAGS= # Identity of this package. PACKAGE_NAME='nyacc' PACKAGE_TARNAME='nyacc' PACKAGE_VERSION='1.00.2' PACKAGE_STRING='nyacc 1.00.2' PACKAGE_BUGREPORT='' PACKAGE_URL='https://savannah.nongnu.org/project/nyacc' ac_unique_file="module/nyacc" ac_subst_vars='LTLIBOBJS LIBOBJS installed_guile NYACC_FH_BINS GUILE_DATA GUILE_SITE_GO GUILE_EXTENSION GUILE_SITE_CCACHE GUILE_SITE GUILE_TOOLS GUILE_CONFIG GUILD GUILE_EFFECTIVE_VERSION PKG_CONFIG_LIBDIR PKG_CONFIG_PATH PKG_CONFIG GUILE target_alias host_alias build_alias LIBS ECHO_T ECHO_N ECHO_C DEFS mandir localedir libdir psdir pdfdir dvidir htmldir infodir docdir oldincludedir includedir runstatedir localstatedir sharedstatedir sysconfdir datadir datarootdir libexecdir sbindir bindir program_transform_name prefix exec_prefix PACKAGE_URL PACKAGE_BUGREPORT PACKAGE_STRING PACKAGE_VERSION PACKAGE_TARNAME PACKAGE_NAME PATH_SEPARATOR SHELL' ac_subst_files='' ac_user_opts=' enable_option_checking ' ac_precious_vars='build_alias host_alias target_alias GUILE PKG_CONFIG PKG_CONFIG_PATH PKG_CONFIG_LIBDIR' # Initialize some variables set by options. ac_init_help= ac_init_version=false ac_unrecognized_opts= ac_unrecognized_sep= # The variables have the same names as the options, with # dashes changed to underlines. cache_file=/dev/null exec_prefix=NONE no_create= no_recursion= prefix=NONE program_prefix=NONE program_suffix=NONE program_transform_name=s,x,x, silent= site= srcdir= verbose= x_includes=NONE x_libraries=NONE # Installation directory options. # These are left unexpanded so users can "make install exec_prefix=/foo" # and all the variables that are supposed to be based on exec_prefix # by default will actually change. # Use braces instead of parens because sh, perl, etc. also accept them. # (The list follows the same order as the GNU Coding Standards.) bindir='${exec_prefix}/bin' sbindir='${exec_prefix}/sbin' libexecdir='${exec_prefix}/libexec' datarootdir='${prefix}/share' datadir='${datarootdir}' sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var' runstatedir='${localstatedir}/run' includedir='${prefix}/include' oldincludedir='/usr/include' docdir='${datarootdir}/doc/${PACKAGE_TARNAME}' infodir='${datarootdir}/info' htmldir='${docdir}' dvidir='${docdir}' pdfdir='${docdir}' psdir='${docdir}' libdir='${exec_prefix}/lib' localedir='${datarootdir}/locale' mandir='${datarootdir}/man' ac_prev= ac_dashdash= for ac_option do # If the previous option needs an argument, assign it. if test -n "$ac_prev"; then eval $ac_prev=\$ac_option ac_prev= continue fi case $ac_option in *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; *=) ac_optarg= ;; *) ac_optarg=yes ;; esac # Accept the important Cygnus configure options, so we can diagnose typos. case $ac_dashdash$ac_option in --) ac_dashdash=yes ;; -bindir | --bindir | --bindi | --bind | --bin | --bi) ac_prev=bindir ;; -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) bindir=$ac_optarg ;; -build | --build | --buil | --bui | --bu) ac_prev=build_alias ;; -build=* | --build=* | --buil=* | --bui=* | --bu=*) build_alias=$ac_optarg ;; -cache-file | --cache-file | --cache-fil | --cache-fi \ | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) ac_prev=cache_file ;; -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) cache_file=$ac_optarg ;; --config-cache | -C) cache_file=config.cache ;; -datadir | --datadir | --datadi | --datad) ac_prev=datadir ;; -datadir=* | --datadir=* | --datadi=* | --datad=*) datadir=$ac_optarg ;; -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ | --dataroo | --dataro | --datar) ac_prev=datarootdir ;; -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) datarootdir=$ac_optarg ;; -disable-* | --disable-*) ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=no ;; -docdir | --docdir | --docdi | --doc | --do) ac_prev=docdir ;; -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) docdir=$ac_optarg ;; -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) ac_prev=dvidir ;; -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) dvidir=$ac_optarg ;; -enable-* | --enable-*) ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=\$ac_optarg ;; -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ | --exec | --exe | --ex) ac_prev=exec_prefix ;; -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ | --exec=* | --exe=* | --ex=*) exec_prefix=$ac_optarg ;; -gas | --gas | --ga | --g) # Obsolete; use --with-gas. with_gas=yes ;; -help | --help | --hel | --he | -h) ac_init_help=long ;; -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) ac_init_help=recursive ;; -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) ac_init_help=short ;; -host | --host | --hos | --ho) ac_prev=host_alias ;; -host=* | --host=* | --hos=* | --ho=*) host_alias=$ac_optarg ;; -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) ac_prev=htmldir ;; -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ | --ht=*) htmldir=$ac_optarg ;; -includedir | --includedir | --includedi | --included | --include \ | --includ | --inclu | --incl | --inc) ac_prev=includedir ;; -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ | --includ=* | --inclu=* | --incl=* | --inc=*) includedir=$ac_optarg ;; -infodir | --infodir | --infodi | --infod | --info | --inf) ac_prev=infodir ;; -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) infodir=$ac_optarg ;; -libdir | --libdir | --libdi | --libd) ac_prev=libdir ;; -libdir=* | --libdir=* | --libdi=* | --libd=*) libdir=$ac_optarg ;; -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ | --libexe | --libex | --libe) ac_prev=libexecdir ;; -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ | --libexe=* | --libex=* | --libe=*) libexecdir=$ac_optarg ;; -localedir | --localedir | --localedi | --localed | --locale) ac_prev=localedir ;; -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) localedir=$ac_optarg ;; -localstatedir | --localstatedir | --localstatedi | --localstated \ | --localstate | --localstat | --localsta | --localst | --locals) ac_prev=localstatedir ;; -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) localstatedir=$ac_optarg ;; -mandir | --mandir | --mandi | --mand | --man | --ma | --m) ac_prev=mandir ;; -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) mandir=$ac_optarg ;; -nfp | --nfp | --nf) # Obsolete; use --without-fp. with_fp=no ;; -no-create | --no-create | --no-creat | --no-crea | --no-cre \ | --no-cr | --no-c | -n) no_create=yes ;; -no-recursion | --no-recursion | --no-recursio | --no-recursi \ | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) no_recursion=yes ;; -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ | --oldin | --oldi | --old | --ol | --o) ac_prev=oldincludedir ;; -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) oldincludedir=$ac_optarg ;; -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) ac_prev=prefix ;; -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) prefix=$ac_optarg ;; -program-prefix | --program-prefix | --program-prefi | --program-pref \ | --program-pre | --program-pr | --program-p) ac_prev=program_prefix ;; -program-prefix=* | --program-prefix=* | --program-prefi=* \ | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) program_prefix=$ac_optarg ;; -program-suffix | --program-suffix | --program-suffi | --program-suff \ | --program-suf | --program-su | --program-s) ac_prev=program_suffix ;; -program-suffix=* | --program-suffix=* | --program-suffi=* \ | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) program_suffix=$ac_optarg ;; -program-transform-name | --program-transform-name \ | --program-transform-nam | --program-transform-na \ | --program-transform-n | --program-transform- \ | --program-transform | --program-transfor \ | --program-transfo | --program-transf \ | --program-trans | --program-tran \ | --progr-tra | --program-tr | --program-t) ac_prev=program_transform_name ;; -program-transform-name=* | --program-transform-name=* \ | --program-transform-nam=* | --program-transform-na=* \ | --program-transform-n=* | --program-transform-=* \ | --program-transform=* | --program-transfor=* \ | --program-transfo=* | --program-transf=* \ | --program-trans=* | --program-tran=* \ | --progr-tra=* | --program-tr=* | --program-t=*) program_transform_name=$ac_optarg ;; -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) ac_prev=pdfdir ;; -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) pdfdir=$ac_optarg ;; -psdir | --psdir | --psdi | --psd | --ps) ac_prev=psdir ;; -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) psdir=$ac_optarg ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) silent=yes ;; -runstatedir | --runstatedir | --runstatedi | --runstated \ | --runstate | --runstat | --runsta | --runst | --runs \ | --run | --ru | --r) ac_prev=runstatedir ;; -runstatedir=* | --runstatedir=* | --runstatedi=* | --runstated=* \ | --runstate=* | --runstat=* | --runsta=* | --runst=* | --runs=* \ | --run=* | --ru=* | --r=*) runstatedir=$ac_optarg ;; -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ | --sbi=* | --sb=*) sbindir=$ac_optarg ;; -sharedstatedir | --sharedstatedir | --sharedstatedi \ | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ | --sharedst | --shareds | --shared | --share | --shar \ | --sha | --sh) ac_prev=sharedstatedir ;; -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ | --sha=* | --sh=*) sharedstatedir=$ac_optarg ;; -site | --site | --sit) ac_prev=site ;; -site=* | --site=* | --sit=*) site=$ac_optarg ;; -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) ac_prev=srcdir ;; -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) srcdir=$ac_optarg ;; -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ | --syscon | --sysco | --sysc | --sys | --sy) ac_prev=sysconfdir ;; -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) sysconfdir=$ac_optarg ;; -target | --target | --targe | --targ | --tar | --ta | --t) ac_prev=target_alias ;; -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) target_alias=$ac_optarg ;; -v | -verbose | --verbose | --verbos | --verbo | --verb) verbose=yes ;; -version | --version | --versio | --versi | --vers | -V) ac_init_version=: ;; -with-* | --with-*) ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=\$ac_optarg ;; -without-* | --without-*) ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=no ;; --x) # Obsolete; use --with-x. with_x=yes ;; -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ | --x-incl | --x-inc | --x-in | --x-i) ac_prev=x_includes ;; -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) x_includes=$ac_optarg ;; -x-libraries | --x-libraries | --x-librarie | --x-librari \ | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) ac_prev=x_libraries ;; -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) x_libraries=$ac_optarg ;; -*) as_fn_error $? "unrecognized option: \`$ac_option' Try \`$0 --help' for more information" ;; *=*) ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` # Reject names that are not valid shell variable names. case $ac_envvar in #( '' | [0-9]* | *[!_$as_cr_alnum]* ) as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; esac eval $ac_envvar=\$ac_optarg export $ac_envvar ;; *) # FIXME: should be removed in autoconf 3.0. $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" ;; esac done if test -n "$ac_prev"; then ac_option=--`echo $ac_prev | sed 's/_/-/g'` as_fn_error $? "missing argument to $ac_option" fi if test -n "$ac_unrecognized_opts"; then case $enable_option_checking in no) ;; fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; esac fi # Check all directory arguments for consistency. for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ datadir sysconfdir sharedstatedir localstatedir includedir \ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ libdir localedir mandir runstatedir do eval ac_val=\$$ac_var # Remove trailing slashes. case $ac_val in */ ) ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` eval $ac_var=\$ac_val;; esac # Be sure to have absolute directory names. case $ac_val in [\\/$]* | ?:[\\/]* ) continue;; NONE | '' ) case $ac_var in *prefix ) continue;; esac;; esac as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" done # There might be people who depend on the old broken behavior: `$host' # used to hold the argument of --host etc. # FIXME: To remove some day. build=$build_alias host=$host_alias target=$target_alias # FIXME: To remove some day. if test "x$host_alias" != x; then if test "x$build_alias" = x; then cross_compiling=maybe elif test "x$build_alias" != "x$host_alias"; then cross_compiling=yes fi fi ac_tool_prefix= test -n "$host_alias" && ac_tool_prefix=$host_alias- test "$silent" = yes && exec 6>/dev/null ac_pwd=`pwd` && test -n "$ac_pwd" && ac_ls_di=`ls -di .` && ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || as_fn_error $? "working directory cannot be determined" test "X$ac_ls_di" = "X$ac_pwd_ls_di" || as_fn_error $? "pwd does not report name of working directory" # Find the source files, if location was not specified. if test -z "$srcdir"; then ac_srcdir_defaulted=yes # Try the directory containing this script, then the parent directory. ac_confdir=`$as_dirname -- "$as_myself" || $as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_myself" : 'X\(//\)[^/]' \| \ X"$as_myself" : 'X\(//\)$' \| \ X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_myself" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` srcdir=$ac_confdir if test ! -r "$srcdir/$ac_unique_file"; then srcdir=.. fi else ac_srcdir_defaulted=no fi if test ! -r "$srcdir/$ac_unique_file"; then test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" fi ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" ac_abs_confdir=`( cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" pwd)` # When building in place, set srcdir=. if test "$ac_abs_confdir" = "$ac_pwd"; then srcdir=. fi # Remove unnecessary trailing slashes from srcdir. # Double slashes in file names in object file debugging info # mess up M-x gdb in Emacs. case $srcdir in */) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; esac for ac_var in $ac_precious_vars; do eval ac_env_${ac_var}_set=\${${ac_var}+set} eval ac_env_${ac_var}_value=\$${ac_var} eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} eval ac_cv_env_${ac_var}_value=\$${ac_var} done # # Report the --help message. # if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF \`configure' configures nyacc 1.00.2 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... To assign environment variables (e.g., CC, CFLAGS...), specify them as VAR=VALUE. See below for descriptions of some of the useful variables. Defaults for the options are specified in brackets. Configuration: -h, --help display this help and exit --help=short display options specific to this package --help=recursive display the short help of all the included packages -V, --version display version information and exit -q, --quiet, --silent do not print \`checking ...' messages --cache-file=FILE cache test results in FILE [disabled] -C, --config-cache alias for \`--cache-file=config.cache' -n, --no-create do not create output files --srcdir=DIR find the sources in DIR [configure dir or \`..'] Installation directories: --prefix=PREFIX install architecture-independent files in PREFIX [$ac_default_prefix] --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX [PREFIX] By default, \`make install' will install all the files in \`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify an installation prefix other than \`$ac_default_prefix' using \`--prefix', for instance \`--prefix=\$HOME'. For better control, use the options below. Fine tuning of the installation directories: --bindir=DIR user executables [EPREFIX/bin] --sbindir=DIR system admin executables [EPREFIX/sbin] --libexecdir=DIR program executables [EPREFIX/libexec] --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] --runstatedir=DIR modifiable per-process data [LOCALSTATEDIR/run] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] --datadir=DIR read-only architecture-independent data [DATAROOTDIR] --infodir=DIR info documentation [DATAROOTDIR/info] --localedir=DIR locale-dependent data [DATAROOTDIR/locale] --mandir=DIR man documentation [DATAROOTDIR/man] --docdir=DIR documentation root [DATAROOTDIR/doc/nyacc] --htmldir=DIR html documentation [DOCDIR] --dvidir=DIR dvi documentation [DOCDIR] --pdfdir=DIR pdf documentation [DOCDIR] --psdir=DIR ps documentation [DOCDIR] _ACEOF cat <<\_ACEOF _ACEOF fi if test -n "$ac_init_help"; then case $ac_init_help in short | recursive ) echo "Configuration of nyacc 1.00.2:";; esac cat <<\_ACEOF Some influential environment variables: GUILE path to guile binary PKG_CONFIG path to pkg-config utility PKG_CONFIG_PATH directories to add to pkg-config's search path PKG_CONFIG_LIBDIR path overriding pkg-config's built-in search path Use these variables to override the choices made by `configure' or to help it to find libraries and programs with nonstandard names/locations. Report bugs to the package provider. nyacc home page: . _ACEOF ac_status=$? fi if test "$ac_init_help" = "recursive"; then # If there are subdirs, report their specific --help. for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue test -d "$ac_dir" || { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } || continue ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix cd "$ac_dir" || { ac_status=$?; continue; } # Check for guested configure. if test -f "$ac_srcdir/configure.gnu"; then echo && $SHELL "$ac_srcdir/configure.gnu" --help=recursive elif test -f "$ac_srcdir/configure"; then echo && $SHELL "$ac_srcdir/configure" --help=recursive else $as_echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 fi || ac_status=$? cd "$ac_pwd" || { ac_status=$?; break; } done fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF nyacc configure 1.00.2 generated by GNU Autoconf 2.69 Copyright (C) 2012 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF exit fi ## ------------------------ ## ## Autoconf initialization. ## ## ------------------------ ## cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. It was created by nyacc $as_me 1.00.2, which was generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@ _ACEOF exec 5>>config.log { cat <<_ASUNAME ## --------- ## ## Platform. ## ## --------- ## hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` uname -m = `(uname -m) 2>/dev/null || echo unknown` uname -r = `(uname -r) 2>/dev/null || echo unknown` uname -s = `(uname -s) 2>/dev/null || echo unknown` uname -v = `(uname -v) 2>/dev/null || echo unknown` /usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` /bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` /bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` /usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` /bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` /bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` _ASUNAME as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. $as_echo "PATH: $as_dir" done IFS=$as_save_IFS } >&5 cat >&5 <<_ACEOF ## ----------- ## ## Core tests. ## ## ----------- ## _ACEOF # Keep a trace of the command line. # Strip out --no-create and --no-recursion so they do not pile up. # Strip out --silent because we don't want to record it for future runs. # Also quote any args containing shell meta-characters. # Make two passes to allow for proper duplicate-argument suppression. ac_configure_args= ac_configure_args0= ac_configure_args1= ac_must_keep_next=false for ac_pass in 1 2 do for ac_arg do case $ac_arg in -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) continue ;; *\'*) ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac case $ac_pass in 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; 2) as_fn_append ac_configure_args1 " '$ac_arg'" if test $ac_must_keep_next = true; then ac_must_keep_next=false # Got value, back to normal. else case $ac_arg in *=* | --config-cache | -C | -disable-* | --disable-* \ | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ | -with-* | --with-* | -without-* | --without-* | --x) case "$ac_configure_args0 " in "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; esac ;; -* ) ac_must_keep_next=true ;; esac fi as_fn_append ac_configure_args " '$ac_arg'" ;; esac done done { ac_configure_args0=; unset ac_configure_args0;} { ac_configure_args1=; unset ac_configure_args1;} # When interrupted or exit'd, cleanup temporary files, and complete # config.log. We remove comments because anyway the quotes in there # would cause problems or look ugly. # WARNING: Use '\'' to represent an apostrophe within the trap. # WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. trap 'exit_status=$? # Save into config.log some information that might help in debugging. { echo $as_echo "## ---------------- ## ## Cache variables. ## ## ---------------- ##" echo # The following way of writing the cache mishandles newlines in values, ( for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 $as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( *${as_nl}ac_space=\ *) sed -n \ "s/'\''/'\''\\\\'\'''\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" ;; #( *) sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) echo $as_echo "## ----------------- ## ## Output variables. ## ## ----------------- ##" echo for ac_var in $ac_subst_vars do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo if test -n "$ac_subst_files"; then $as_echo "## ------------------- ## ## File substitutions. ## ## ------------------- ##" echo for ac_var in $ac_subst_files do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo fi if test -s confdefs.h; then $as_echo "## ----------- ## ## confdefs.h. ## ## ----------- ##" echo cat confdefs.h echo fi test "$ac_signal" != 0 && $as_echo "$as_me: caught signal $ac_signal" $as_echo "$as_me: exit $exit_status" } >&5 rm -f core *.core core.conftest.* && rm -f -r conftest* confdefs* conf$$* $ac_clean_files && exit $exit_status ' 0 for ac_signal in 1 2 13 15; do trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal done ac_signal=0 # confdefs.h avoids OS command line length limits that DEFS can exceed. rm -f -r conftest* confdefs.h $as_echo "/* confdefs.h */" > confdefs.h # Predefined preprocessor variables. cat >>confdefs.h <<_ACEOF #define PACKAGE_NAME "$PACKAGE_NAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_TARNAME "$PACKAGE_TARNAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_VERSION "$PACKAGE_VERSION" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_STRING "$PACKAGE_STRING" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_URL "$PACKAGE_URL" _ACEOF # Let the site file select an alternate cache file if it wants to. # Prefer an explicitly selected file to automatically selected ones. ac_site_file1=NONE ac_site_file2=NONE if test -n "$CONFIG_SITE"; then # We do not want a PATH search for config.site. case $CONFIG_SITE in #(( -*) ac_site_file1=./$CONFIG_SITE;; */*) ac_site_file1=$CONFIG_SITE;; *) ac_site_file1=./$CONFIG_SITE;; esac elif test "x$prefix" != xNONE; then ac_site_file1=$prefix/share/config.site ac_site_file2=$prefix/etc/config.site else ac_site_file1=$ac_default_prefix/share/config.site ac_site_file2=$ac_default_prefix/etc/config.site fi for ac_site_file in "$ac_site_file1" "$ac_site_file2" do test "x$ac_site_file" = xNONE && continue if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 $as_echo "$as_me: loading site script $ac_site_file" >&6;} sed 's/^/| /' "$ac_site_file" >&5 . "$ac_site_file" \ || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "failed to load site script $ac_site_file See \`config.log' for more details" "$LINENO" 5; } fi done if test -r "$cache_file"; then # Some versions of bash will fail to source /dev/null (special files # actually), so we avoid doing that. DJGPP emulates it as a regular file. if test /dev/null != "$cache_file" && test -f "$cache_file"; then { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 $as_echo "$as_me: loading cache $cache_file" >&6;} case $cache_file in [\\/]* | ?:[\\/]* ) . "$cache_file";; *) . "./$cache_file";; esac fi else { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 $as_echo "$as_me: creating cache $cache_file" >&6;} >$cache_file fi # Check that the precious variables saved in the cache have kept the same # value. ac_cache_corrupted=false for ac_var in $ac_precious_vars; do eval ac_old_set=\$ac_cv_env_${ac_var}_set eval ac_new_set=\$ac_env_${ac_var}_set eval ac_old_val=\$ac_cv_env_${ac_var}_value eval ac_new_val=\$ac_env_${ac_var}_value case $ac_old_set,$ac_new_set in set,) { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} ac_cache_corrupted=: ;; ,);; *) if test "x$ac_old_val" != "x$ac_new_val"; then # differences in whitespace do not lead to failure. ac_old_val_w=`echo x $ac_old_val` ac_new_val_w=`echo x $ac_new_val` if test "$ac_old_val_w" != "$ac_new_val_w"; then { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 $as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} ac_cache_corrupted=: else { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 $as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} eval $ac_var=\$ac_old_val fi { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 $as_echo "$as_me: former value: \`$ac_old_val'" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 $as_echo "$as_me: current value: \`$ac_new_val'" >&2;} fi;; esac # Pass precious variables to config.status. if test "$ac_new_set" = set; then case $ac_new_val in *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; *) ac_arg=$ac_var=$ac_new_val ;; esac case " $ac_configure_args " in *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. *) as_fn_append ac_configure_args " '$ac_arg'" ;; esac fi done if $ac_cache_corrupted; then { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 $as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 fi ## -------------------- ## ## Main body of script. ## ## -------------------- ## ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu ac_aux_dir= for ac_dir in etc "$srcdir"/etc; do if test -f "$ac_dir/install-sh"; then ac_aux_dir=$ac_dir ac_install_sh="$ac_aux_dir/install-sh -c" break elif test -f "$ac_dir/install.sh"; then ac_aux_dir=$ac_dir ac_install_sh="$ac_aux_dir/install.sh -c" break elif test -f "$ac_dir/shtool"; then ac_aux_dir=$ac_dir ac_install_sh="$ac_aux_dir/shtool install -c" break fi done if test -z "$ac_aux_dir"; then as_fn_error $? "cannot find install-sh, install.sh, or shtool in etc \"$srcdir\"/etc" "$LINENO" 5 fi # These three variables are undocumented and unsupported, # and are intended to be withdrawn in a future Autoconf release. # They can cause serious problems if a builder's source tree is in a directory # whose full name contains unusual characters. ac_config_guess="$SHELL $ac_aux_dir/config.guess" # Please don't use this var. ac_config_sub="$SHELL $ac_aux_dir/config.sub" # Please don't use this var. ac_configure="$SHELL $ac_aux_dir/configure" # Please don't use this var. ## Autoconf macros for working with Guile. ## ## Copyright (C) 1998,2001, 2006, 2010, 2012, 2013, 2014 Free Software Foundation, Inc. ## ## This library is free software; you can redistribute it and/or ## modify it under the terms of the GNU Lesser General Public License ## as published by the Free Software Foundation; either version 3 of ## the License, or (at your option) any later version. ## ## This library is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ## Lesser General Public License for more details. ## ## You should have received a copy of the GNU Lesser General Public ## License along with this library; if not, write to the Free Software ## Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA ## 02110-1301 USA # serial 10 ## Index ## ----- ## ## GUILE_PKG -- find Guile development files ## GUILE_PROGS -- set paths to Guile interpreter, config and tool programs ## GUILE_FLAGS -- set flags for compiling and linking with Guile ## GUILE_SITE_DIR -- find path to Guile "site" directories ## GUILE_CHECK -- evaluate Guile Scheme code and capture the return value ## GUILE_MODULE_CHECK -- check feature of a Guile Scheme module ## GUILE_MODULE_AVAILABLE -- check availability of a Guile Scheme module ## GUILE_MODULE_REQUIRED -- fail if a Guile Scheme module is unavailable ## GUILE_MODULE_EXPORTS -- check if a module exports a variable ## GUILE_MODULE_REQUIRED_EXPORT -- fail if a module doesn't export a variable ## Code ## ---- ## NOTE: Comments preceding an AC_DEFUN (starting from "Usage:") are massaged ## into doc/ref/autoconf-macros.texi (see Makefile.am in that directory). # GUILE_PKG -- find Guile development files # # Usage: GUILE_PKG([VERSIONS]) # # This macro runs the @code{pkg-config} tool to find development files # for an available version of Guile. # # By default, this macro will search for the latest stable version of # Guile (e.g. 2.2), falling back to the previous stable version # (e.g. 2.0) if it is available. If no guile-@var{VERSION}.pc file is # found, an error is signalled. The found version is stored in # @var{GUILE_EFFECTIVE_VERSION}. # # If @code{GUILE_PROGS} was already invoked, this macro ensures that the # development files have the same effective version as the Guile # program. # # @var{GUILE_EFFECTIVE_VERSION} is marked for substitution, as by # @code{AC_SUBST}. # # GUILE_FLAGS -- set flags for compiling and linking with Guile # # Usage: GUILE_FLAGS # # This macro runs the @code{pkg-config} tool to find out how to compile # and link programs against Guile. It sets four variables: # @var{GUILE_CFLAGS}, @var{GUILE_LDFLAGS}, @var{GUILE_LIBS}, and # @var{GUILE_LTLIBS}. # # @var{GUILE_CFLAGS}: flags to pass to a C or C++ compiler to build code that # uses Guile header files. This is almost always just one or more @code{-I} # flags. # # @var{GUILE_LDFLAGS}: flags to pass to the compiler to link a program # against Guile. This includes @code{-lguile-@var{VERSION}} for the # Guile library itself, and may also include one or more @code{-L} flag # to tell the compiler where to find the libraries. But it does not # include flags that influence the program's runtime search path for # libraries, and will therefore lead to a program that fails to start, # unless all necessary libraries are installed in a standard location # such as @file{/usr/lib}. # # @var{GUILE_LIBS} and @var{GUILE_LTLIBS}: flags to pass to the compiler or to # libtool, respectively, to link a program against Guile. It includes flags # that augment the program's runtime search path for libraries, so that shared # libraries will be found at the location where they were during linking, even # in non-standard locations. @var{GUILE_LIBS} is to be used when linking the # program directly with the compiler, whereas @var{GUILE_LTLIBS} is to be used # when linking the program is done through libtool. # # The variables are marked for substitution, as by @code{AC_SUBST}. # # GUILE_SITE_DIR -- find path to Guile site directories # # Usage: GUILE_SITE_DIR # # This looks for Guile's "site" directories. The variable @var{GUILE_SITE} will # be set to Guile's "site" directory for Scheme source files (usually something # like PREFIX/share/guile/site). @var{GUILE_SITE_CCACHE} will be set to the # directory for compiled Scheme files also known as @code{.go} files # (usually something like # PREFIX/lib/guile/@var{GUILE_EFFECTIVE_VERSION}/site-ccache). # @var{GUILE_EXTENSION} will be set to the directory for compiled C extensions # (usually something like # PREFIX/lib/guile/@var{GUILE_EFFECTIVE_VERSION}/extensions). The latter two # are set to blank if the particular version of Guile does not support # them. Note that this macro will run the macros @code{GUILE_PKG} and # @code{GUILE_PROGS} if they have not already been run. # # The variables are marked for substitution, as by @code{AC_SUBST}. # # GUILE_PROGS -- set paths to Guile interpreter, config and tool programs # # Usage: GUILE_PROGS([VERSION]) # # This macro looks for programs @code{guile} and @code{guild}, setting # variables @var{GUILE} and @var{GUILD} to their paths, respectively. # The macro will attempt to find @code{guile} with the suffix of # @code{-X.Y}, followed by looking for it with the suffix @code{X.Y}, and # then fall back to looking for @code{guile} with no suffix. If # @code{guile} is still not found, signal an error. The suffix, if any, # that was required to find @code{guile} will be used for @code{guild} # as well. # # By default, this macro will search for the latest stable version of # Guile (e.g. 2.2). x.y or x.y.z versions can be specified. If an older # version is found, the macro will signal an error. # # The effective version of the found @code{guile} is set to # @var{GUILE_EFFECTIVE_VERSION}. This macro ensures that the effective # version is compatible with the result of a previous invocation of # @code{GUILE_FLAGS}, if any. # # As a legacy interface, it also looks for @code{guile-config} and # @code{guile-tools}, setting @var{GUILE_CONFIG} and @var{GUILE_TOOLS}. # # The variables are marked for substitution, as by @code{AC_SUBST}. # # GUILE_CHECK -- evaluate Guile Scheme code and capture the return value # # Usage: GUILE_CHECK_RETVAL(var,check) # # @var{var} is a shell variable name to be set to the return value. # @var{check} is a Guile Scheme expression, evaluated with "$GUILE -c", and # returning either 0 or non-#f to indicate the check passed. # Non-0 number or #f indicates failure. # Avoid using the character "#" since that confuses autoconf. # # GUILE_MODULE_CHECK -- check feature of a Guile Scheme module # # Usage: GUILE_MODULE_CHECK(var,module,featuretest,description) # # @var{var} is a shell variable name to be set to "yes" or "no". # @var{module} is a list of symbols, like: (ice-9 common-list). # @var{featuretest} is an expression acceptable to GUILE_CHECK, q.v. # @var{description} is a present-tense verb phrase (passed to AC_MSG_CHECKING). # # GUILE_MODULE_AVAILABLE -- check availability of a Guile Scheme module # # Usage: GUILE_MODULE_AVAILABLE(var,module) # # @var{var} is a shell variable name to be set to "yes" or "no". # @var{module} is a list of symbols, like: (ice-9 common-list). # # GUILE_MODULE_REQUIRED -- fail if a Guile Scheme module is unavailable # # Usage: GUILE_MODULE_REQUIRED(symlist) # # @var{symlist} is a list of symbols, WITHOUT surrounding parens, # like: ice-9 common-list. # # GUILE_MODULE_EXPORTS -- check if a module exports a variable # # Usage: GUILE_MODULE_EXPORTS(var,module,modvar) # # @var{var} is a shell variable to be set to "yes" or "no". # @var{module} is a list of symbols, like: (ice-9 common-list). # @var{modvar} is the Guile Scheme variable to check. # # GUILE_MODULE_REQUIRED_EXPORT -- fail if a module doesn't export a variable # # Usage: GUILE_MODULE_REQUIRED_EXPORT(module,modvar) # # @var{module} is a list of symbols, like: (ice-9 common-list). # @var{modvar} is the Guile Scheme variable to check. # ## guile.m4 ends here # --- last line --- if test "x$ac_env_GUILE_set" = "xset"; then GUILE_EFFECTIVE_VERSION=`$GUILE -c "(display (effective-version))"` guile_libdir=`$GUILE -c "(display (assq-ref %guile-build-info 'libdir))"` if test "x$ac_cv_env_PKG_CONFIG_set" != "xset"; then if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}pkg-config", so it can be a program name with args. set dummy ${ac_tool_prefix}pkg-config; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_path_PKG_CONFIG+:} false; then : $as_echo_n "(cached) " >&6 else case $PKG_CONFIG in [\\/]* | ?:[\\/]*) ac_cv_path_PKG_CONFIG="$PKG_CONFIG" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_path_PKG_CONFIG="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS ;; esac fi PKG_CONFIG=$ac_cv_path_PKG_CONFIG if test -n "$PKG_CONFIG"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $PKG_CONFIG" >&5 $as_echo "$PKG_CONFIG" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_path_PKG_CONFIG"; then ac_pt_PKG_CONFIG=$PKG_CONFIG # Extract the first word of "pkg-config", so it can be a program name with args. set dummy pkg-config; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_path_ac_pt_PKG_CONFIG+:} false; then : $as_echo_n "(cached) " >&6 else case $ac_pt_PKG_CONFIG in [\\/]* | ?:[\\/]*) ac_cv_path_ac_pt_PKG_CONFIG="$ac_pt_PKG_CONFIG" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_path_ac_pt_PKG_CONFIG="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS ;; esac fi ac_pt_PKG_CONFIG=$ac_cv_path_ac_pt_PKG_CONFIG if test -n "$ac_pt_PKG_CONFIG"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_pt_PKG_CONFIG" >&5 $as_echo "$ac_pt_PKG_CONFIG" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_pt_PKG_CONFIG" = x; then PKG_CONFIG="" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac PKG_CONFIG=$ac_pt_PKG_CONFIG fi else PKG_CONFIG="$ac_cv_path_PKG_CONFIG" fi fi if test -n "$PKG_CONFIG"; then _pkg_min_version=0.9.0 { $as_echo "$as_me:${as_lineno-$LINENO}: checking pkg-config is at least version $_pkg_min_version" >&5 $as_echo_n "checking pkg-config is at least version $_pkg_min_version... " >&6; } if $PKG_CONFIG --atleast-pkgconfig-version $_pkg_min_version; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } PKG_CONFIG="" fi fi PKG_CONFIG_LIBDIR=$guile_libdir/pkgconfig export PKG_CONFIG_LIBDIR else if test "x$ac_cv_env_PKG_CONFIG_set" != "xset"; then if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}pkg-config", so it can be a program name with args. set dummy ${ac_tool_prefix}pkg-config; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_path_PKG_CONFIG+:} false; then : $as_echo_n "(cached) " >&6 else case $PKG_CONFIG in [\\/]* | ?:[\\/]*) ac_cv_path_PKG_CONFIG="$PKG_CONFIG" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_path_PKG_CONFIG="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS ;; esac fi PKG_CONFIG=$ac_cv_path_PKG_CONFIG if test -n "$PKG_CONFIG"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $PKG_CONFIG" >&5 $as_echo "$PKG_CONFIG" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_path_PKG_CONFIG"; then ac_pt_PKG_CONFIG=$PKG_CONFIG # Extract the first word of "pkg-config", so it can be a program name with args. set dummy pkg-config; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_path_ac_pt_PKG_CONFIG+:} false; then : $as_echo_n "(cached) " >&6 else case $ac_pt_PKG_CONFIG in [\\/]* | ?:[\\/]*) ac_cv_path_ac_pt_PKG_CONFIG="$ac_pt_PKG_CONFIG" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_path_ac_pt_PKG_CONFIG="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS ;; esac fi ac_pt_PKG_CONFIG=$ac_cv_path_ac_pt_PKG_CONFIG if test -n "$ac_pt_PKG_CONFIG"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_pt_PKG_CONFIG" >&5 $as_echo "$ac_pt_PKG_CONFIG" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_pt_PKG_CONFIG" = x; then PKG_CONFIG="" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac PKG_CONFIG=$ac_pt_PKG_CONFIG fi else PKG_CONFIG="$ac_cv_path_PKG_CONFIG" fi fi if test -n "$PKG_CONFIG"; then _pkg_min_version=0.9.0 { $as_echo "$as_me:${as_lineno-$LINENO}: checking pkg-config is at least version $_pkg_min_version" >&5 $as_echo_n "checking pkg-config is at least version $_pkg_min_version... " >&6; } if $PKG_CONFIG --atleast-pkgconfig-version $_pkg_min_version; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } PKG_CONFIG="" fi fi _guile_versions_to_search="3.0 2.9 2.2 2.0" if test -n "$GUILE_EFFECTIVE_VERSION"; then _guile_tmp="" for v in $_guile_versions_to_search; do if test "$v" = "$GUILE_EFFECTIVE_VERSION"; then _guile_tmp=$v fi done if test -z "$_guile_tmp"; then { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "searching for guile development files for versions $_guile_versions_to_search, but previously found $GUILE version $GUILE_EFFECTIVE_VERSION See \`config.log' for more details" "$LINENO" 5; } fi _guile_versions_to_search=$GUILE_EFFECTIVE_VERSION fi GUILE_EFFECTIVE_VERSION="" _guile_errors="" for v in $_guile_versions_to_search; do if test -z "$GUILE_EFFECTIVE_VERSION"; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking for guile $v" >&5 $as_echo "$as_me: checking for guile $v" >&6;} if test -n "$PKG_CONFIG" && \ { { $as_echo "$as_me:${as_lineno-$LINENO}: \$PKG_CONFIG --exists --print-errors \"guile-\$v\""; } >&5 ($PKG_CONFIG --exists --print-errors "guile-$v") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then GUILE_EFFECTIVE_VERSION=$v fi fi done if test -z "$GUILE_EFFECTIVE_VERSION"; then as_fn_error $? " No Guile development packages were found. Please verify that you have Guile installed. If you installed Guile from a binary distribution, please verify that you have also installed the development packages. If you installed it yourself, you might need to adjust your PKG_CONFIG_PATH; see the pkg-config man page for more. " "$LINENO" 5 fi { $as_echo "$as_me:${as_lineno-$LINENO}: found guile $GUILE_EFFECTIVE_VERSION" >&5 $as_echo "$as_me: found guile $GUILE_EFFECTIVE_VERSION" >&6;} _guile_required_version="$GUILE_EFFECTIVE_VERSION" if test -z "$_guile_required_version"; then _guile_required_version=2.2 fi _guile_candidates=guile _tmp= for v in `echo "$_guile_required_version" | tr . ' '`; do if test -n "$_tmp"; then _tmp=$_tmp.; fi _tmp=$_tmp$v _guile_candidates="guile-$_tmp guile$_tmp $_guile_candidates" done for ac_prog in $_guile_candidates do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_path_GUILE+:} false; then : $as_echo_n "(cached) " >&6 else case $GUILE in [\\/]* | ?:[\\/]*) ac_cv_path_GUILE="$GUILE" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_path_GUILE="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS ;; esac fi GUILE=$ac_cv_path_GUILE if test -n "$GUILE"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $GUILE" >&5 $as_echo "$GUILE" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$GUILE" && break done if test -z "$GUILE"; then as_fn_error $? "guile required but not found" "$LINENO" 5 fi _guile_suffix=`echo "$GUILE" | sed -e 's,^.*/guile\(.*\)$,\1,'` _guile_effective_version=`$GUILE -c "(display (effective-version))"` if test -z "$GUILE_EFFECTIVE_VERSION"; then GUILE_EFFECTIVE_VERSION=$_guile_effective_version elif test "$GUILE_EFFECTIVE_VERSION" != "$_guile_effective_version"; then as_fn_error $? "found development files for Guile $GUILE_EFFECTIVE_VERSION, but $GUILE has effective version $_guile_effective_version" "$LINENO" 5 fi _guile_major_version=`$GUILE -c "(display (major-version))"` _guile_minor_version=`$GUILE -c "(display (minor-version))"` _guile_micro_version=`$GUILE -c "(display (micro-version))"` _guile_prog_version="$_guile_major_version.$_guile_minor_version.$_guile_micro_version" { $as_echo "$as_me:${as_lineno-$LINENO}: checking for Guile version >= $_guile_required_version" >&5 $as_echo_n "checking for Guile version >= $_guile_required_version... " >&6; } _major_version=`echo $_guile_required_version | cut -d . -f 1` _minor_version=`echo $_guile_required_version | cut -d . -f 2` _micro_version=`echo $_guile_required_version | cut -d . -f 3` if test "$_guile_major_version" -gt "$_major_version"; then true elif test "$_guile_major_version" -eq "$_major_version"; then if test "$_guile_minor_version" -gt "$_minor_version"; then true elif test "$_guile_minor_version" -eq "$_minor_version"; then if test -n "$_micro_version"; then if test "$_guile_micro_version" -lt "$_micro_version"; then as_fn_error $? "Guile $_guile_required_version required, but $_guile_prog_version found" "$LINENO" 5 fi fi elif test "$GUILE_EFFECTIVE_VERSION" = "$_major_version.$_minor_version" -a -z "$_micro_version"; then # Allow prereleases that have the right effective version. true else as_fn_error $? "Guile $_guile_required_version required, but $_guile_prog_version found" "$LINENO" 5 fi elif test "$GUILE_EFFECTIVE_VERSION" = "$_major_version.$_minor_version" -a -z "$_micro_version"; then # Allow prereleases that have the right effective version. true else as_fn_error $? "Guile $_guile_required_version required, but $_guile_prog_version found" "$LINENO" 5 fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $_guile_prog_version" >&5 $as_echo "$_guile_prog_version" >&6; } # Extract the first word of "guild$_guile_suffix", so it can be a program name with args. set dummy guild$_guile_suffix; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_path_GUILD+:} false; then : $as_echo_n "(cached) " >&6 else case $GUILD in [\\/]* | ?:[\\/]*) ac_cv_path_GUILD="$GUILD" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_path_GUILD="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS ;; esac fi GUILD=$ac_cv_path_GUILD if test -n "$GUILD"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $GUILD" >&5 $as_echo "$GUILD" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi # Extract the first word of "guile-config$_guile_suffix", so it can be a program name with args. set dummy guile-config$_guile_suffix; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_path_GUILE_CONFIG+:} false; then : $as_echo_n "(cached) " >&6 else case $GUILE_CONFIG in [\\/]* | ?:[\\/]*) ac_cv_path_GUILE_CONFIG="$GUILE_CONFIG" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_path_GUILE_CONFIG="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS ;; esac fi GUILE_CONFIG=$ac_cv_path_GUILE_CONFIG if test -n "$GUILE_CONFIG"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $GUILE_CONFIG" >&5 $as_echo "$GUILE_CONFIG" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test -n "$GUILD"; then GUILE_TOOLS=$GUILD else # Extract the first word of "guile-tools$_guile_suffix", so it can be a program name with args. set dummy guile-tools$_guile_suffix; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_path_GUILE_TOOLS+:} false; then : $as_echo_n "(cached) " >&6 else case $GUILE_TOOLS in [\\/]* | ?:[\\/]*) ac_cv_path_GUILE_TOOLS="$GUILE_TOOLS" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_path_GUILE_TOOLS="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS ;; esac fi GUILE_TOOLS=$ac_cv_path_GUILE_TOOLS if test -n "$GUILE_TOOLS"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $GUILE_TOOLS" >&5 $as_echo "$GUILE_TOOLS" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for Guile site directory" >&5 $as_echo_n "checking for Guile site directory... " >&6; } GUILE_SITE=`$PKG_CONFIG --print-errors --variable=sitedir guile-$GUILE_EFFECTIVE_VERSION` { $as_echo "$as_me:${as_lineno-$LINENO}: result: $GUILE_SITE" >&5 $as_echo "$GUILE_SITE" >&6; } if test "$GUILE_SITE" = ""; then { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "sitedir not found See \`config.log' for more details" "$LINENO" 5; } fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for Guile site-ccache directory using pkgconfig" >&5 $as_echo_n "checking for Guile site-ccache directory using pkgconfig... " >&6; } GUILE_SITE_CCACHE=`$PKG_CONFIG --variable=siteccachedir guile-$GUILE_EFFECTIVE_VERSION` if test "$GUILE_SITE_CCACHE" = ""; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: checking for Guile site-ccache directory using interpreter" >&5 $as_echo_n "checking for Guile site-ccache directory using interpreter... " >&6; } GUILE_SITE_CCACHE=`$GUILE -c "(display (if (defined? '%site-ccache-dir) (%site-ccache-dir) \"\"))"` if test $? != "0" -o "$GUILE_SITE_CCACHE" = ""; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } GUILE_SITE_CCACHE="" { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: siteccachedir not found" >&5 $as_echo "$as_me: WARNING: siteccachedir not found" >&2;} fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $GUILE_SITE_CCACHE" >&5 $as_echo "$GUILE_SITE_CCACHE" >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: checking for Guile extensions directory" >&5 $as_echo_n "checking for Guile extensions directory... " >&6; } GUILE_EXTENSION=`$PKG_CONFIG --print-errors --variable=extensiondir guile-$GUILE_EFFECTIVE_VERSION` { $as_echo "$as_me:${as_lineno-$LINENO}: result: $GUILE_EXTENSION" >&5 $as_echo "$GUILE_EXTENSION" >&6; } if test "$GUILE_EXTENSION" = ""; then GUILE_EXTENSION="" { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: extensiondir not found" >&5 $as_echo "$as_me: WARNING: extensiondir not found" >&2;} fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for Guile site directory" >&5 $as_echo_n "checking for Guile site directory... " >&6; } GUILE_SITE_GO=`$GUILE -c '(display (%site-ccache-dir))'` { $as_echo "$as_me:${as_lineno-$LINENO}: result: $GUILE_SITE_GO" >&5 $as_echo "$GUILE_SITE_GO" >&6; } if test "$GUILE_SITE_GO" = ""; then { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "sitedir not found See \`config.log' for more details" "$LINENO" 5; } fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for Guile data directory" >&5 $as_echo_n "checking for Guile data directory... " >&6; } GUILE_DATA=`$GUILE -c "(display (assq-ref %guile-build-info 'datadir))"` { $as_echo "$as_me:${as_lineno-$LINENO}: result: $GUILE_DATA" >&5 $as_echo "$GUILE_DATA" >&6; } if test "$GUILE_DATA" = ""; then { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "datadir not found See \`config.log' for more details" "$LINENO" 5; } fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking if (bytestructures guile) is available" >&5 $as_echo_n "checking if (bytestructures guile) is available... " >&6; } $GUILE -c "(use-modules (bytestructures guile)) (exit ((lambda () 0)))" > /dev/null 2>&1 have_bytestructures=$? if test "$have_bytestructures" = "0" ; then have_bytestructures=yes ; else have_bytestructures=no ; fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $have_bytestructures" >&5 $as_echo "$have_bytestructures" >&6; } if test $have_bytestructures = "yes"; then NYACC_FH_BINS='$(NYACC_FH_BINS)' else NYACC_FH_BINS='' fi ac_config_files="$ac_config_files Makefile module/Makefile doc/nyacc/Makefile test-suite/Makefile examples/Makefile" installed_guile=$GUILE ac_config_files="$ac_config_files etc/guild" cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure # scripts and configure runs, see configure's option --config-cache. # It is not useful on other systems. If it contains results you don't # want to keep, you may remove or edit it. # # config.status only pays attention to the cache file if you give it # the --recheck option to rerun configure. # # `ac_cv_env_foo' variables (set or unset) will be overridden when # loading this file, other *unset* `ac_cv_foo' will be assigned the # following values. _ACEOF # The following way of writing the cache mishandles newlines in values, # but we know of no workaround that is simple, portable, and efficient. # So, we kill variables containing newlines. # Ultrix sh set writes to stderr and can't be redirected directly, # and sets the high bit in the cache file unless we assign to the vars. ( for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 $as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space=' '; set) 2>&1` in #( *${as_nl}ac_space=\ *) # `set' does not quote correctly, so add quotes: double-quote # substitution turns \\\\ into \\, and sed turns \\ into \. sed -n \ "s/'/'\\\\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" ;; #( *) # `set' quotes correctly as required by POSIX, so do not add quotes. sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) | sed ' /^ac_cv_env_/b end t clear :clear s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ t end s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ :end' >>confcache if diff "$cache_file" confcache >/dev/null 2>&1; then :; else if test -w "$cache_file"; then if test "x$cache_file" != "x/dev/null"; then { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 $as_echo "$as_me: updating cache $cache_file" >&6;} if test ! -f "$cache_file" || test -h "$cache_file"; then cat confcache >"$cache_file" else case $cache_file in #( */* | ?:*) mv -f confcache "$cache_file"$$ && mv -f "$cache_file"$$ "$cache_file" ;; #( *) mv -f confcache "$cache_file" ;; esac fi fi else { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 $as_echo "$as_me: not updating unwritable cache $cache_file" >&6;} fi fi rm -f confcache test "x$prefix" = xNONE && prefix=$ac_default_prefix # Let make expand exec_prefix. test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' # Transform confdefs.h into DEFS. # Protect against shell expansion while executing Makefile rules. # Protect against Makefile macro expansion. # # If the first sed substitution is executed (which looks for macros that # take arguments), then branch to the quote section. Otherwise, # look for a macro that doesn't take arguments. ac_script=' :mline /\\$/{ N s,\\\n,, b mline } t clear :clear s/^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\)/-D\1=\2/g t quote s/^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\)/-D\1=\2/g t quote b any :quote s/[ `~#$^&*(){}\\|;'\''"<>?]/\\&/g s/\[/\\&/g s/\]/\\&/g s/\$/$$/g H :any ${ g s/^\n// s/\n/ /g p } ' DEFS=`sed -n "$ac_script" confdefs.h` ac_libobjs= ac_ltlibobjs= U= for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue # 1. Remove the extension, and $U if already installed. ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' ac_i=`$as_echo "$ac_i" | sed "$ac_script"` # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR # will be set to the directory where LIBOBJS objects are built. as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' done LIBOBJS=$ac_libobjs LTLIBOBJS=$ac_ltlibobjs : "${CONFIG_STATUS=./config.status}" ac_write_fail=0 ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files $CONFIG_STATUS" { $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 $as_echo "$as_me: creating $CONFIG_STATUS" >&6;} as_write_fail=0 cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 #! $SHELL # Generated by $as_me. # Run this file to recreate the current configuration. # Compiler output produced by configure, useful for debugging # configure, is in config.log if it exists. debug=false ac_cs_recheck=false ac_cs_silent=false SHELL=\${CONFIG_SHELL-$SHELL} export SHELL _ASEOF cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo # Prefer a ksh shell builtin over an external printf program on Solaris, # but without wasting forks for bash or zsh. if test -z "$BASH_VERSION$ZSH_VERSION" \ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='print -r --' as_echo_n='print -rn --' elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in #( *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Unset variables that we do not need and which cause bugs (e.g. in # pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" # suppresses any "Segmentation fault" message there. '((' could # trigger a bug in pdksh 5.2.14. for as_var in BASH_ENV ENV MAIL MAILPATH do eval test x\${$as_var+set} = xset \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi $as_echo "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : eval 'as_fn_append () { eval $1+=\$2 }' else as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : eval 'as_fn_arith () { as_val=$(( $* )) }' else as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -pR' fi else as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi # as_fn_executable_p FILE # ----------------------- # Test if FILE is an executable regular file. as_fn_executable_p () { test -f "$1" && test -x "$1" } # as_fn_executable_p as_test_x='test -x' as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" exec 6>&1 ## ----------------------------------- ## ## Main body of $CONFIG_STATUS script. ## ## ----------------------------------- ## _ASEOF test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Save the log message, to keep $0 and so on meaningful, and to # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" This file was extended by nyacc $as_me 1.00.2, which was generated by GNU Autoconf 2.69. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS CONFIG_COMMANDS = $CONFIG_COMMANDS $ $0 $@ on `(hostname || uname -n) 2>/dev/null | sed 1q` " _ACEOF case $ac_config_files in *" "*) set x $ac_config_files; shift; ac_config_files=$*;; esac cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 # Files that config.status was made for. config_files="$ac_config_files" _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 ac_cs_usage="\ \`$as_me' instantiates files and other configuration actions from templates according to the current configuration. Unless the files and actions are specified as TAGs, all are instantiated by default. Usage: $0 [OPTION]... [TAG]... -h, --help print this help, then exit -V, --version print version number and configuration settings, then exit --config print configuration, then exit -q, --quiet, --silent do not print progress messages -d, --debug don't remove temporary files --recheck update $as_me by reconfiguring in the same conditions --file=FILE[:TEMPLATE] instantiate the configuration file FILE Configuration files: $config_files Report bugs to the package provider. nyacc home page: ." _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ nyacc config.status 1.00.2 configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\" Copyright (C) 2012 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." ac_pwd='$ac_pwd' srcdir='$srcdir' test -n "\$AWK" || AWK=awk _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # The default lists apply if the user does not specify any file. ac_need_defaults=: while test $# != 0 do case $1 in --*=?*) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` ac_shift=: ;; --*=) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg= ac_shift=: ;; *) ac_option=$1 ac_optarg=$2 ac_shift=shift ;; esac case $ac_option in # Handling of the options. -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) ac_cs_recheck=: ;; --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) $as_echo "$ac_cs_version"; exit ;; --config | --confi | --conf | --con | --co | --c ) $as_echo "$ac_cs_config"; exit ;; --debug | --debu | --deb | --de | --d | -d ) debug=: ;; --file | --fil | --fi | --f ) $ac_shift case $ac_optarg in *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; '') as_fn_error $? "missing file argument" ;; esac as_fn_append CONFIG_FILES " '$ac_optarg'" ac_need_defaults=false;; --he | --h | --help | --hel | -h ) $as_echo "$ac_cs_usage"; exit ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil | --si | --s) ac_cs_silent=: ;; # This is an error. -*) as_fn_error $? "unrecognized option: \`$1' Try \`$0 --help' for more information." ;; *) as_fn_append ac_config_targets " $1" ac_need_defaults=false ;; esac shift done ac_configure_extra_args= if $ac_cs_silent; then exec 6>/dev/null ac_configure_extra_args="$ac_configure_extra_args --silent" fi _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 if \$ac_cs_recheck; then set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion shift \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6 CONFIG_SHELL='$SHELL' export CONFIG_SHELL exec "\$@" fi _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 exec 5>>config.log { echo sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX ## Running $as_me. ## _ASBOX $as_echo "$ac_log" } >&5 _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Handling of arguments. for ac_config_target in $ac_config_targets do case $ac_config_target in "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;; "module/Makefile") CONFIG_FILES="$CONFIG_FILES module/Makefile" ;; "doc/nyacc/Makefile") CONFIG_FILES="$CONFIG_FILES doc/nyacc/Makefile" ;; "test-suite/Makefile") CONFIG_FILES="$CONFIG_FILES test-suite/Makefile" ;; "examples/Makefile") CONFIG_FILES="$CONFIG_FILES examples/Makefile" ;; "etc/guild") CONFIG_FILES="$CONFIG_FILES etc/guild" ;; *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; esac done # If the user did not use the arguments to specify the items to instantiate, # then the envvar interface is used. Set only those that are not. # We use the long form for the default assignment because of an extremely # bizarre bug on SunOS 4.1.3. if $ac_need_defaults; then test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files fi # Have a temporary directory for convenience. Make it in the build tree # simply because there is no reason against having it here, and in addition, # creating and moving files from /tmp can sometimes cause problems. # Hook for its removal unless debugging. # Note that there is a small window in which the directory will not be cleaned: # after its creation but before its name has been assigned to `$tmp'. $debug || { tmp= ac_tmp= trap 'exit_status=$? : "${ac_tmp:=$tmp}" { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status ' 0 trap 'as_fn_exit 1' 1 2 13 15 } # Create a (secure) tmp directory for tmp files. { tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && test -d "$tmp" } || { tmp=./conf$$-$RANDOM (umask 077 && mkdir "$tmp") } || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 ac_tmp=$tmp # Set up the scripts for CONFIG_FILES section. # No need to generate them if there are no CONFIG_FILES. # This happens for instance with `./config.status config.h'. if test -n "$CONFIG_FILES"; then ac_cr=`echo X | tr X '\015'` # On cygwin, bash can eat \r inside `` if the user requested igncr. # But we know of no other shell where ac_cr would be empty at this # point, so we can use a bashism as a fallback. if test "x$ac_cr" = x; then eval ac_cr=\$\'\\r\' fi ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then ac_cs_awk_cr='\\r' else ac_cs_awk_cr=$ac_cr fi echo 'BEGIN {' >"$ac_tmp/subs1.awk" && _ACEOF { echo "cat >conf$$subs.awk <<_ACEOF" && echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && echo "_ACEOF" } >conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` ac_delim='%!_!# ' for ac_last_try in false false false false false :; do . ./conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` if test $ac_delim_n = $ac_delim_num; then break elif $ac_last_try; then as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 else ac_delim="$ac_delim!$ac_delim _$ac_delim!! " fi done rm -f conf$$subs.sh cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && _ACEOF sed -n ' h s/^/S["/; s/!.*/"]=/ p g s/^[^!]*!// :repl t repl s/'"$ac_delim"'$// t delim :nl h s/\(.\{148\}\)..*/\1/ t more1 s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ p n b repl :more1 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t nl :delim h s/\(.\{148\}\)..*/\1/ t more2 s/["\\]/\\&/g; s/^/"/; s/$/"/ p b :more2 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t delim ' >$CONFIG_STATUS || ac_write_fail=1 rm -f conf$$subs.awk cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACAWK cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && for (key in S) S_is_set[key] = 1 FS = "" } { line = $ 0 nfields = split(line, field, "@") substed = 0 len = length(field[1]) for (i = 2; i < nfields; i++) { key = field[i] keylen = length(key) if (S_is_set[key]) { value = S[key] line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) len += length(value) + length(field[++i]) substed = 1 } else len += 1 + keylen } print line } _ACAWK _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" else cat fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 _ACEOF # VPATH may cause trouble with some makes, so we remove sole $(srcdir), # ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and # trailing colons and then remove the whole line if VPATH becomes empty # (actually we leave an empty line to preserve line numbers). if test "x$srcdir" = x.; then ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ h s/// s/^/:/ s/[ ]*$/:/ s/:\$(srcdir):/:/g s/:\${srcdir}:/:/g s/:@srcdir@:/:/g s/^:*// s/:*$// x s/\(=[ ]*\).*/\1/ G s/\n// s/^[^=]*=[ ]*$// }' fi cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 fi # test -n "$CONFIG_FILES" eval set X " :F $CONFIG_FILES " shift for ac_tag do case $ac_tag in :[FHLC]) ac_mode=$ac_tag; continue;; esac case $ac_mode$ac_tag in :[FHL]*:*);; :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; :[FH]-) ac_tag=-:-;; :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; esac ac_save_IFS=$IFS IFS=: set x $ac_tag IFS=$ac_save_IFS shift ac_file=$1 shift case $ac_mode in :L) ac_source=$1;; :[FH]) ac_file_inputs= for ac_f do case $ac_f in -) ac_f="$ac_tmp/stdin";; *) # Look for the file first in the build tree, then in the source tree # (if the path is not absolute). The absolute path cannot be DOS-style, # because $ac_f cannot contain `:'. test -f "$ac_f" || case $ac_f in [\\/$]*) false;; *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; esac || as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; esac case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac as_fn_append ac_file_inputs " '$ac_f'" done # Let's still pretend it is `configure' which instantiates (i.e., don't # use $as_me), people would be surprised to read: # /* config.h. Generated by config.status. */ configure_input='Generated from '` $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' `' by configure.' if test x"$ac_file" != x-; then configure_input="$ac_file. $configure_input" { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 $as_echo "$as_me: creating $ac_file" >&6;} fi # Neutralize special characters interpreted by sed in replacement strings. case $configure_input in #( *\&* | *\|* | *\\* ) ac_sed_conf_input=`$as_echo "$configure_input" | sed 's/[\\\\&|]/\\\\&/g'`;; #( *) ac_sed_conf_input=$configure_input;; esac case $ac_tag in *:-:* | *:-) cat >"$ac_tmp/stdin" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; esac ;; esac ac_dir=`$as_dirname -- "$ac_file" || $as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$ac_file" : 'X\(//\)[^/]' \| \ X"$ac_file" : 'X\(//\)$' \| \ X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$ac_file" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` as_dir="$ac_dir"; as_fn_mkdir_p ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix case $ac_mode in :F) # # CONFIG_FILE # _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # If the template does not know about datarootdir, expand it. # FIXME: This hack should be removed a few years after 2.60. ac_datarootdir_hack=; ac_datarootdir_seen= ac_sed_dataroot=' /datarootdir/ { p q } /@datadir@/p /@docdir@/p /@infodir@/p /@localedir@/p /@mandir@/p' case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in *datarootdir*) ac_datarootdir_seen=yes;; *@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 $as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_datarootdir_hack=' s&@datadir@&$datadir&g s&@docdir@&$docdir&g s&@infodir@&$infodir&g s&@localedir@&$localedir&g s&@mandir@&$mandir&g s&\\\${datarootdir}&$datarootdir&g' ;; esac _ACEOF # Neutralize VPATH when `$srcdir' = `.'. # Shell code in configure.ac might set extrasub. # FIXME: do we really want to maintain this feature? cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_sed_extra="$ac_vpsub $extrasub _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 :t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b s|@configure_input@|$ac_sed_conf_input|;t t s&@top_builddir@&$ac_top_builddir_sub&;t t s&@top_build_prefix@&$ac_top_build_prefix&;t t s&@srcdir@&$ac_srcdir&;t t s&@abs_srcdir@&$ac_abs_srcdir&;t t s&@top_srcdir@&$ac_top_srcdir&;t t s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t s&@builddir@&$ac_builddir&;t t s&@abs_builddir@&$ac_abs_builddir&;t t s&@abs_top_builddir@&$ac_abs_top_builddir&;t t $ac_datarootdir_hack " eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ "$ac_tmp/out"`; test -z "$ac_out"; } && { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined" >&5 $as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined" >&2;} rm -f "$ac_tmp/stdin" case $ac_file in -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; esac \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; esac case $ac_file$ac_mode in "etc/guild":F) chmod +x etc/guild ;; esac done # for ac_tag as_fn_exit 0 _ACEOF ac_clean_files=$ac_clean_files_save test $ac_write_fail = 0 || as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 # configure is writing to config.log, and then calls config.status. # config.status does its own redirection, appending to config.log. # Unfortunately, on DOS this fails, as config.log is still kept open # by configure, so config.status won't be able to write to it; its # output is simply discarded. So we exec the FD to /dev/null, # effectively closing config.log, so it can be properly (re)opened and # appended to by config.status. When coming back to configure, we # need to make the FD available again. if test "$no_create" != yes; then ac_cs_success=: ac_config_status_args= test "$silent" = yes && ac_config_status_args="$ac_config_status_args --quiet" exec 5>/dev/null $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false exec 5>>config.log # Use ||, not &&, to avoid exiting from the if with $? = 1, which # would make configure fail if this is the last instruction. $ac_cs_success || as_fn_exit 1 fi if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} fi nyacc-1.00.2/INSTALL0000644000175100000240000000271513605250515013451 0ustar mwettedialoutInstall instructions for NYACC Copyright (C) 2015-2020 Matthew R. Wette Copying and distribution of this file, with or without modification, are permitted in any medium without royalty provided the copyright notice and this notice are preserved. This file is offered as-is, without any warranty. This package depends on having GNU Guile version 2.0.13 or later. See https://www.gnu.org/software/guile/download/#releases Use of the optional FFI Helper requires scheme-bytestructures. See https://github.com/TaylanUB/scheme-bytestructures/releases To configure: $ cd nyacc-0.00.0 $ ./configure [options] Type ./configure --help to see the options. Common options are --prefix=/path/to/root GUILE=/path/to/guile To build in a separate directory: $ mkdir build; cd build $ ../nyacc-0.00.0/configure [options] Build the binaries: $ make ... Run the tests: $ make check ... PASS: nyacc/lex-01: C char literals PASS: nyacc/lex-01: C strings ... To install the parser generator, the c99 parser and the FFI helper $ make install ... or $ make DESTDIR=/path/to/tmpdir install ... To install only sources in /path/to/dest: $ ./configure --site_scm_dir=/path/to/dest --site_scm_go_dir=/dummy $ make install-srcs You must specify site_scm_go_dir to avoid use of `guile'. To install the infant nx-languages (javascript, octave, tcl) type $ make install-nx-languages The file HACKING has hints for modifying and trying code. nyacc-1.00.2/examples/0000755000175100000240000000000013605250515014231 5ustar mwettedialoutnyacc-1.00.2/examples/system/0000755000175100000240000000000013605250515015555 5ustar mwettedialoutnyacc-1.00.2/examples/system/dbus.scm0000644000175100000240000005330113605250515017220 0ustar mwettedialout;;; system/dbus.scm - dbus module, on top of (ffi dbus) ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see ;;; Notes: ;; This is a work in progress for Guile dbus based on libdbus. ;; See: ;; https://lists.freedesktop.org/archives/dbus/2007-October/008859.html ;; https://stackoverflow.com/questions/9378593/ ;; dbuswatch-and-dbustimeout-examples ;; Marshalling and de-marshalling strings requires pointer. ;; char *str_recv, *str_send = "hello"; ;; dbus_message_iter_get_basic(&iter, DBUS_TYPE_STRING, &str_recv); ;; dbus_message_iter_append_basic(&iter, DBUS_TYPE_STRING, &str_send); ;; Variables names starting with `&' represent pointers to allocated ;; memory as in ;; char *str = "hello"; ;; foo(&str); ;;; Code: (define-module (system dbus) #:export (spawn-dbus-mainloop TRUE FALSE dbus-version dbus-bus-get-unique-name dbus-message-get-sender dbus-error ;; utils: read-dbus-val get-dbus-message-args nonzero? TRUE FALSE ;; make-DBusMessageIter& ;; dbus-message-type dbus-request-name-reply make-dbus-string make-dbus-pointer ) #:use-module (ffi epoll) #:use-module (ffi dbus) #:use-module (bytestructures guile) #:use-module (system ffi-help-rt) #:use-module ((system foreign) #:prefix ffi:) #:use-module (ice-9 threads) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-43) ;; dbus00 ;;#:use-module ((ice-9 iconv) #:select (string->bytevector)) ;;#:use-module (rnrs bytevectors) ) (use-modules (ice-9 format)) (define (ff fmt . args) (apply format #t fmt args)) (define (sf fmt . args) (apply simple-format #t fmt args)) ;; ==================================== (define TRUE 1) (define FALSE 0) (define (dbus-version) (let ((maj (make-int)) (min (make-int)) (mic (make-int))) (dbus_get_version (pointer-to maj) (pointer-to min) (pointer-to mic)) (simple-format #f "~A.~A.~A" (fh-object-ref maj) (fh-object-ref min) (fh-object-ref mic)))) (define (dbus-bus-get-unique-name conn) (ffi:pointer->string (dbus_bus_get_unique_name conn))) (define (dbus-message-get-sender conn) (ffi:pointer->string (dbus_message_get_sender conn))) ;; @deffn {Procedure} dbus-error error => #f|string ;; If @var{error} (a @code{DBusError} value) represents an error return ;; the error string. Otherwise return @code{#f}. ;; @end deffn (define (dbus-error error) (and (!0 (dbus_error_is_set (pointer-to error))) (ffi:pointer->string (ffi:make-pointer (fh-object-ref error 'message))))) (define (get-bval &iter key) (let* ((bval (make-DBusBasicValue))) (dbus_message_iter_get_basic &iter (pointer-to bval)) (fh-object-ref bval key))) (define (read-dbus-val &iter) (case (dbus_message_iter_get_arg_type &iter) ;;((0) (if #f #f)) ; 0 - invalid ((0) '()) ; 0 - invalid ((121) (get-bval &iter 'byt)) ; y - byte ((98) (not (zero? (get-bval &iter 'bool_val)))) ; b - boolean ((110) (get-bval &iter 'i16)) ; n - int16 ((113) (get-bval &iter 'u16)) ; q - uint16 ((105) (get-bval &iter 'i32)) ; i - int32 ((117) (get-bval &iter 'u32)) ; u - uint32 ((120) (get-bval &iter 'i64)) ; x - int64 ((116) (get-bval &iter 'u32)) ; t - uint64 ((100) (get-bval &iter 'dbl)) ; d - double ((115 111 103) ; s, o, g (ffi:pointer->string (ffi:make-pointer (get-bval &iter 'str)))) ((104) (get-bval &iter 'fd)) ; h - unix fd ((97) ; a - array (let* ((sub-iter (make-DBusMessageIter)) (&sub-iter (pointer-to sub-iter))) (dbus_message_iter_recurse &iter &sub-iter) (let loop () (cons (read-dbus-val &sub-iter) (if (zero? (dbus_message_iter_next &sub-iter)) '() (loop)))))) ((118) ; v - variant (boxed value) (let* ((sub-iter (make-DBusMessageIter)) (&sub-iter (pointer-to sub-iter))) (dbus_message_iter_recurse &iter &sub-iter) (read-dbus-val &sub-iter))) ((114) (error "not defined: r")) ; r - struct ((101) ; e - dict entry (let* ((sub-iter (make-DBusMessageIter)) (&sub-iter (pointer-to sub-iter))) (dbus_message_iter_recurse &iter &sub-iter) (cons (read-dbus-val &sub-iter) (begin (dbus_message_iter_next &sub-iter) (read-dbus-val &sub-iter))))) (else (error "not defined")))) ;; Given a message (or message) reply return the list of args. (define (get-dbus-message-args msg) (let* ((iter (make-DBusMessageIter)) (&iter (pointer-to iter))) (dbus_message_iter_init msg &iter) (let loop ((arg (read-dbus-val &iter))) (cond ((null? arg) '()) (else (dbus_message_iter_next &iter) (cons arg (loop (read-dbus-val &iter)))))))) (define dbus-message-type (if (and (= 0 (dbus-symval 'DBUS_MESSAGE_TYPE_INVALID)) (= 1 (dbus-symval 'DBUS_MESSAGE_TYPE_METHOD_CALL)) (= 2 (dbus-symval 'DBUS_MESSAGE_TYPE_METHOD_RETURN)) (= 3 (dbus-symval 'DBUS_MESSAGE_TYPE_ERROR)) (= 4 (dbus-symval 'DBUS_MESSAGE_TYPE_SIGNAL))) (lambda (ival) (case ival ((0) 'INVALID) ((1) 'METHOD_CALL) ((2) 'METHOD_RETURN) ((3) 'ERROR) ((4) 'SIGNAL) (else #f))) (lambda (ival) ival))) (define dbus-request-name-reply (if (and (= 1 (dbus-symval 'DBUS_REQUEST_NAME_REPLY_PRIMARY_OWNER)) (= 2 (dbus-symval 'DBUS_REQUEST_NAME_REPLY_IN_QUEUE)) (= 3 (dbus-symval 'DBUS_REQUEST_NAME_REPLY_EXISTS)) (= 4 (dbus-symval 'DBUS_REQUEST_NAME_REPLY_ALREADY_OWNER))) (lambda (ival) (case ival ((1) 'PRIMARY_OWNER) ((2) 'IN_QUEUE) ((3) 'REPLY_EXISTS) ((4) 'ALREADY_OWNER) (else #f))) (lambda (ival) ival))) (define (make-DBusMessageIter&) (pointer-to (make-DBusMessageIter))) ;; === scheduler ====================== ;; time is pair: (sec . usec) (define-record-type bus-event (make-bus-event next prev time proc data) bus-evt? (next bus-ev-next set-bus-ev-next!) (prev bus-ev-prev set-bus-ev-prev!) (time bus-ev-time set-bus-ev-time!) (proc bus-ev-proc set-bus-ev-proc!) (data bus-ev-data set-bus-ev-data!)) (set-record-type-printer! bus-event (lambda (evt port) (let ((evt-addr (object-address evt)) (nxt-addr (object-address (bus-ev-next evt))) (prv-addr (object-address (bus-ev-prev evt)))) (display "#" port)))) (define-record-type bus-sched (make-sched todo free lock) sched? (todo sched-todo set-sched-todo!) ; pending events (free sched-free set-sched-free!) ; free list (lock sched-lock)) ; lock (define *fence* '(1999999999 . 999999)) ;; @deffn {Procedure} make-scheduler [size] ;; Create a scheduler. The optional size is the initial number of events ;; on the free list. Events are reused to avoid heavy GC action. Not sure ;; that is needed. Scheduling events and execution are protected by a ;; mutex. ;; @end deffn (define* (make-scheduler #:optional (size 5)) (if (negative? size) (error "size too small")) (let* ((todo (make-bus-event #f #f *fence* #f #f)) (free (make-bus-event #f #f #f #f size)) (lock (make-mutex))) (let iter ((prev free) (n (1- size))) (set-bus-ev-next! prev (make-bus-event #f prev #f #f n)) (if (zero? n) prev (iter (bus-ev-next prev) (1- n)))) (make-sched todo free lock))) (define (t> a b) (cond ((> (car a) (car b)) #t) ((< (car a) (car b)) #f) ((> (cdr a) (cdr b)) #t) (else #f))) (define (t< a b) (t> b a)) ;; @deffn {Procedure} schedule-event sched time proc data ;; Schedule an event. Manipulation of the schedule is protected by ;; lock and unlock. The argument @var{time} is a pair of seconds ;; and micro-seconds as returned by @code{gettimeofday}. ;; @end deffn (define (schedule-event sch time proc data) (and=> (sched-lock sch) lock-mutex) (let ((ev (sched-free sch)) (todo (sched-todo sch))) (if (not ev) (error "free list exhausted")) (set-sched-free! sch (bus-ev-next ev)) (set-bus-ev-time! ev time) (set-bus-ev-proc! ev proc) (set-bus-ev-data! ev data) (let iter ((prev #f) (next (sched-todo sch))) (cond ((t> time (bus-ev-time next)) (iter next (bus-ev-next next))) (else (set-bus-ev-next! ev next) (set-bus-ev-prev! ev prev) (if (not prev) (set-sched-todo! sch ev))))) (and=> (sched-lock sch) unlock-mutex) ev)) ;; @deffn {Procedure} cancel-events/data sch data ;; Cancel all events with handle @var{data}. ;; @end deffn (define (cancel-events/data sch data) (and=> (sched-lock sch) lock-mutex) (let iter ((evt (sched-todo sch))) (when (and (bus-ev-next evt) (equal? data (bus-ev-data evt))) (let ((next (bus-ev-next evt)) (prev (bus-ev-prev evt))) ;; remove the event from the todo list (if next (set-bus-ev-prev! next prev)) (if prev (set-bus-ev-next! prev next) (set-sched-todo! sch next)) ;; add to free list and clean up (set-bus-ev-next! evt (sched-free sch)) (set-sched-free! sch evt) (set-bus-ev-time! evt #f) (set-bus-ev-prev! evt #f) (set-bus-ev-proc! evt #f) (set-bus-ev-data! evt #f) (iter next)))) (and=> (sched-lock sch) unlock-mutex) (if #f #f)) ;; @deffn {Procedure} earliest-event-time sched => time ;; return the earliest event time ;; @end deffn (define (earliest-event-time sch) (and=> (sched-lock sch) lock-mutex) (let ((time (bus-ev-time (sched-todo sch)))) (and=> (sched-lock sch) unlock-mutex) time)) ;; @deffn {Procedure} exec-schedule sched time ;; Execute events scheduled up to and including @var{time}. ;; The schedule is unlocked during each event execution so that ;; new events can be scheduled. ;; @end deffn (define (exec-schedule sch time) (let ((lock (sched-lock sch))) (and=> lock lock-mutex) (let iter ((evt (sched-todo sch))) (when (t> time (bus-ev-time evt)) (let ((next (bus-ev-next evt))) ;; remove the event from the todo list (set-sched-todo! sch next) ;; execute the event (when (bus-ev-proc evt) (and=> lock unlock-mutex) ((bus-ev-proc evt) sch (bus-ev-data evt)) (and=> lock lock-mutex)) ;; update the todo and free list, cleaning the event just executed (set-bus-ev-prev! (sched-free sch) evt) (set-bus-ev-time! evt #f) (set-bus-ev-next! evt (sched-free sch)) (set-bus-ev-prev! evt #f) (set-bus-ev-proc! evt #f) (set-bus-ev-data! evt #f) (set-sched-free! sch evt) (iter next)))) (and=> lock unlock-mutex)) (if #f #f)) (define (t+us time us) (let* ((us (+ (cdr time) us)) (t (cons (car time) us))) (if (> us 999999) (cons (1+ (car t)) (- (cdr t) 1000000)) t))) (define (sch-print sch) (sf " todo:\n") (let iter ((evt (sched-todo sch))) (when evt (sf " ~S ~S ~S\n" (bus-ev-time evt) (bus-ev-proc evt) (bus-ev-data evt)) (iter (bus-ev-next evt)))) (sf " free:\n") (let iter ((evt (sched-free sch))) (when evt (sf " ~S ~S ~S\n" (bus-ev-time evt) (bus-ev-proc evt) (bus-ev-data evt)) (iter (bus-ev-next evt)))) ) (define (test) (define (hello sch data) (sf "hello ~S\n" data)) (let* ((t0 (gettimeofday)) (t1 (t+us t0 1000)) (t2 (t+us t0 10000)) (t3 (t+us t0 100000)) (sch1 (make-scheduler))) (sf "t0=~S\n" t0) (sf "t0=~S\n" t1) (sf "t0=~S\n" t2) (sf "t0=~S\n" t3) ;;(sch-print sch1) (sf "schedule event\n") (schedule-event sch1 t2 hello "world") (sch-print sch1) (sf "exec t1\n") (exec-schedule sch1 t1) (sch-print sch1) (sf "exec t3\n") (exec-schedule sch1 t3) (sch-print sch1))) ;; === DBus mainloop ================== ;; notes ;; 1) One can call epoll_ctl while epoll_wait is blocked in another thread. ;; ref: epoll_wait man page ;; 2) It is safe to use scm->pointer and pointer->scm as long as the pointed ;; object was allocated with scm_gc_malloc(). (Ludo answer to Q on list) ;; Convert mask of DBUS_WATCH to enum EPOLL_EVENTS. (define (dbus-watch-flags->epoll-events dbus-flags) (fold (lambda (dbus-flag epoll-types) (if (not (zero? (logand dbus-flag dbus-flags))) (case dbus-flag ((1) (logior epoll-types 1)) ; readable ((2) (logior epoll-types 4)) ; writable ((4) (logior epoll-types 8)) ; error ((8) (logior epoll-types 16)) ; hangup (else (error "unhandled case"))) epoll-types)) 0 '(1 2 4 8))) (define (epoll-events->dbus-watch-flags epoll-events) (fold (lambda (epoll-event dbus-flags) (if (not (zero? (logand epoll-event epoll-events))) (case epoll-event ((1) (logior dbus-flags 1)) ; readable ((4) (logior dbus-flags 2)) ; writable ((8) (logior dbus-flags 4)) ; error ((16) (logior dbus-flags 8)) ; hangup (else (error "unhandled case"))) dbus-flags)) 0 '(1 4 8 16))) (define (scm->addr scm) (ffi:pointer-address (ffi:scm->pointer scm))) (define (addr->scm addr) (ffi:pointer->scm (ffi:make-pointer addr))) ;; This is the user-data associated with a watch, i.e., an FD to be monitored. ;; Guile needs something equivalent to epoll-OR-kevent. (define-record-type dbus-data (make-dbus-data fd ev wv) dbus-data? (fd dbus-data-fd) ; epoll fd, if in epoll set (ev dbus-data-ev) ; epoll event or kevent ??? (wv dbus-data-wv set-dbus-data-wv!)) ; watch vector (define *dbus-maxw* 3) (define *dbus-fd-dict* (make-hash-table 31)) ;; Lookup the fd in the dbus-data dictionary. If not found add a blank entry. (define (dbus-lookup-fd fd) (or (hashv-ref *dbus-fd-dict* fd) (let* ((event (make-struct-epoll_event)) (ddent (make-dbus-data fd event (make-vector *dbus-maxw* #f)))) (hashv-set! *dbus-fd-dict* fd ddent) (fh-object-set! event 'data 'ptr (scm->addr ddent)) ddent))) ;; Find an available slot in the watch-vector. (define (find-wv-slot wv) (let iter ((i 0) (n (vector-length wv))) (cond ((= i n) -1) ((vector-ref wv i) (iter (1+ i) n)) (else i)))) ;; Is the fd in the dbus-data object being watched? ;; This implmenetation is a kludge. (define (dbus-data-watched? ddent) (= 0 (find-wv-slot (dbus-data-wv ddent)))) (define (dbus-data-watchless? ddent) (not (dbus-data-watched? ddent))) (define (dbus-fd-watchless? fd) (not (and=> (hashv-ref *dbus-fd-dict* fd) dbus-data-watched?))) ;; De-allocate the dbus data entry. (define (dbus-data-free ddent) (if #f #f)) ;; no need implement this with use of the get_dispatch_status/dispatch loop (define (dispatch-status connection ~status data) ;;(display "dispatch-status called\n") (if #f #f)) ;; @deffn {Procedure} add-watch watch data ;; @end deffn (define (add-watch ~watch data) (let* ((watch (make-DBusWatch* ~watch)) (muxfd (ffi:pointer-address data)) (addfd (dbus_watch_get_unix_fd watch)) (flags (dbus_watch_get_flags watch)) (ddent (dbus-lookup-fd muxfd)) (event (dbus-data-ev ddent))) (dbus_watch_set_data watch (ffi:scm->pointer ddent) dbus-data-free) ;; Set up the indended set of epoll events. (if (!0 (dbus_watch_get_enabled watch)) (fh-object-set! event 'events (logior (fh-object-ref event 'events) (dbus-watch-flags->epoll-events flags)))) ;; If this is the use of this fd, then initialize the ev and add to epoll. (if (dbus-data-watchless? ddent) (epoll_ctl muxfd (EPOLL '_CTL_ADD) addfd (pointer-to event))) ;; Set watches based on flags. (let* ((wv (dbus-data-wv ddent)) (wx (find-wv-slot wv))) (if (negative? wx) (error "max exceeded") (vector-set! wv wx watch))) TRUE)) ;; @deffn {Procedure} remove-watch watch data ;; @end deffn (define (remove-watch ~watch data) (let* ((watch (make-DBusWatch* ~watch)) (muxfd (ffi:pointer-address data)) (delfd (dbus_watch_get_unix_fd watch)) ;;(ddent (dbus_watch_get_data watch)) (ddent (hashv *dbus-fd-dict* delfd)) (event (dbus-data-ev ddent)) (events (fh-object-ref event 'events)) ) (when #f (sf "\nrem-watch ~S ~S\n" watch data) ) ;; remove watch from ddent and fix events mask. ;; if no watches left then remove fd from epoll ;;(if (no more watches on this fd) ;; (epoll_ctl muxfd (EPOLL '_CTL_DEL) delfd (ffi:scm->pointer ddent))) (if #f #f))) ;; @deffn {Procedure} watch-toggled watch data ;; @end deffn (define (watch-toggled ~watch data) (let* ((watch (make-DBusWatch* ~watch)) (muxfd (ffi:pointer-address data)) (flags (dbus_watch_get_flags watch)) ) (when #f (sf "watch-tog ~S ~S ...\n" watch data) (sf " enabled: ~S\n" (dbus_watch_get_enabled watch))) (if #f #f))) (use-modules (sched)) (define *dbus-sched* (make-scheduler)) (define (dbus-timeout-handler sch timeout) (sf "\ntimeout handler called\n") (dbus_timeout_handle timeout)) ;; timeout is DBusTimeout (define (add-timeout ~timeout data) (let* ((tod (gettimeofday)) (timeout (make-DBusWatch* ~timeout)) (interval (dbus_timeout_get_interval timeout)) (exp (t+us tod interval))) (schedule-event *dbus-sched* exp dbus-timeout-handler timeout) (write #\x (ffi:pointer->scm data)) ; wake up mainloop TRUE)) (define (remove-timeout ~timeout data) (let* ((timeout (make-DBusWatch* ~timeout))) (cancel-events/data *dbus-sched* timeout) (if #f #f))) (define (timeout-toggled timeout data) (let () (display "tmout-tog called (to be completed!)\n") (if #f #f))) ;; This sets up capability to make runtime-sized vectors and use ;; @code{pointer-to} cast for function args. See @code{epoll_wait} below. (define-fh-vector-type struct-epoll_event-vec struct-epoll_event-desc struct-epoll_event-vec? make-struct-epoll_event-vec) (fh-ref<->deref! struct-epoll_event* make-struct-epoll_event* struct-epoll_event-vec make-struct-epoll_event-vec) (export make-struct-epoll_event-vec) (define (filter-func c m data) (when #f (sf "filter-func called ...\n iface : ~S\n member: ~S\n path : ~S\n" (ffi:pointer->string (dbus_message_get_interface m)) (ffi:pointer->string (dbus_message_get_member m)) (ffi:pointer->string (dbus_message_get_path m)))) (DBUS 'HANDLER_RESULT_NOT_YET_HANDLED) ;;(DBUS 'HANDLER_RESULT_HANDLED) ) (define (set-nonblocking! port) (fcntl port F_SETFL (logior O_NONBLOCK (fcntl port F_GETFL)))) (define* (my-main-loop connection #:key (max-events 5)) (define (dispatch-em) (while (eq? 'DBUS_DISPATCH_DATA_REMAINS (dbus_connection_get_dispatch_status connection)) (dbus_connection_dispatch connection))) (define (handle-watch watch flags) (let ((flags (logand flags (dbus_watch_get_flags watch)))) ;; This loop-sleeps while out of memory. (while (equal? FALSE (dbus_watch_handle watch flags)) (sf "SLEEP 1\n") (sleep 1)))) (let* ((muxfd (epoll_create 1)) (muxpt (ffi:make-pointer muxfd)) (wpipe (pipe)) (wiport (car wpipe)) (woport (cdr wpipe)) (~woport (ffi:scm->pointer woport)) (eventv (make-struct-epoll_event-vec max-events)) (eventp (pointer-to eventv))) ;; Set up wakeup, initiated from handlers. (setvbuf woport 'none) (set-nonblocking! woport) (set-nonblocking! wiport) ;; needed? (let ((event (make-struct-epoll_event))) (fh-object-set! event 'events (EPOLL 'IN)) (epoll_ctl muxfd (EPOLL '_CTL_ADD) (port->fdes wiport) (pointer-to event))) ;; Set up DBus MT locks, and mainloop hook functions. (dbus_threads_init_default) (dbus_connection_set_dispatch_status_function connection dispatch-status muxpt dbus-data-free) (dbus_connection_set_watch_functions connection add-watch remove-watch watch-toggled muxpt dbus-data-free) (dbus_connection_set_timeout_functions connection add-timeout remove-timeout timeout-toggled ~woport NULL) ;; These are in dbus list archive 008859.html. (dbus_connection_add_filter connection filter-func NULL NULL) ;;(dbus_bus_add_match connection "type='signal'" NULL) (dbus_bus_add_match connection "type='method_call'" NULL) (let loop () (let iter ((i 0) (n (epoll_wait muxfd eventp max-events -1))) ;; timeouts use (pair (gettimeofday)) => (sec . usec) (let iter ((tod (gettimeofday)) (nxt (earliest-event-time *dbus-sched*))) (when (t< tod nxt) (exec-schedule *dbus-sched* tod) (iter (gettimeofday) (earliest-event-time *dbus-sched*)))) ;; events: wake-up or watches (unless (= i n) (let* ((event (fh-object-ref eventv i)) (events (bytestructure-ref event 'events)) (data-ptr (bytestructure-ref event 'data 'ptr))) (cond ((zero? data-ptr) (read-char wiport)) (else (let* ((flags (epoll-events->dbus-watch-flags events)) (ddent (addr->scm data-ptr))) (vector-for-each (lambda (ix watch) (when watch (handle-watch watch flags) (dbus_connection_ref connection) (dispatch-em) (dbus_connection_unref connection))) (dbus-data-wv ddent)))))) (iter (1+ i) n))) (loop)) ;; (close-fdes muxfd))) (define (spawn-dbus-mainloop service) (let* ((bus-id (case service ((session) 'DBUS_BUS_SESSION) ((system) 'DBUS_BUS_SYSTEM) (else (error "bad bus id")))) (error (let ((error (make-DBusError))) (dbus_error_init (pointer-to error)) error)) (conn (let ((conn (dbus_bus_get bus-id (pointer-to error)))) (dbus-error error) conn))) (call-with-new-thread (lambda () (my-main-loop conn))) (sleep 1) conn)) ;; --- last line --- nyacc-1.00.2/examples/env.sh0000644000175100000240000000047513605250515015363 0ustar mwettedialout#!/bin/sh # source this file: $ . env.sh topdir=`(cd ..; pwd)` if [ "X$GUILE_LOAD_PATH" = "X" ]; then GUILE_LOAD_PATH=$topdir/module else GUILE_LOAD_PATH=$topdir/module:$GUILE_LOAD_PATH fi; GUILE_LOAD_PATH=$topdir/examples:$GUILE_LOAD_PATH GUILE_LOAD_PATH=$topdir/test-suite:$GUILE_LOAD_PATH export GUILE_LOAD_PATH nyacc-1.00.2/examples/language/0000755000175100000240000000000013605250515016014 5ustar mwettedialoutnyacc-1.00.2/examples/language/nx-tcl/0000755000175100000240000000000013605250515017221 5ustar mwettedialoutnyacc-1.00.2/examples/language/nx-tcl/spec.scm0000644000175100000240000000274613605250515020670 0ustar mwettedialout;;; language/nx-tcl/spec.scm - NYACC extension for Tcl ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see . ;;; Code: (define-module (language nx-tcl spec) #:export (nx-tcl) #:use-module (nyacc lang tcl parser) #:use-module (nyacc lang tcl compile-tree-il) #:use-module (system base language)) (define-language nx-tcl #:title "nx-tcl" #:reader (lambda (p e) (cond ((and (file-port? p) (string? (port-filename p)) (not (string-prefix? "/dev/" (port-filename p)))) (read-tcl-file p e)) (else (read-tcl-stmt p e)))) #:compilers `((tree-il . ,compile-tree-il)) #:evaluator (lambda (exp mod) (primitive-eval exp)) #:printer write #:make-default-environment (lambda () (let ((env (make-fresh-user-module))) (module-define! env 'current-reader (make-fluid)) env)) ) ;; --- last line --- nyacc-1.00.2/examples/language/nx-javascript/0000755000175100000240000000000013605250515020605 5ustar mwettedialoutnyacc-1.00.2/examples/language/nx-javascript/spec.scm0000644000175100000240000000320613605250515022244 0ustar mwettedialout;; language/nx-javascript/spec.scm - NYACC extension for JavaScript ;; Copyright (C) 2015,2017-2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see . ;;; Code: (define-module (language nx-javascript spec) #:export (nx-javascript) #:use-module (nyacc lang javascript parser) #:use-module (nyacc lang javascript compile-tree-il) #:use-module (nyacc lang javascript pprint) #:use-module (system base language)) (define-language nx-javascript #:title "nx-javascript" #:reader (lambda (p e) (cond ((and (file-port? p) (string? (port-filename p)) (not (string-prefix? "/dev/" (port-filename p)))) (read-js-file p e)) (else (read-js-stmt p e)))) #:compilers `((tree-il . ,compile-tree-il)) #:evaluator (lambda (exp mod) (primitive-eval exp)) #:printer pretty-print-js #:make-default-environment (lambda () ;; ripoff from language/scheme/spec.scm (let ((env (make-fresh-user-module))) (module-define! env 'current-reader (make-fluid)) env))) ;; --- last line --- nyacc-1.00.2/examples/language/nx-octave/0000755000175100000240000000000013605250515017720 5ustar mwettedialoutnyacc-1.00.2/examples/language/nx-octave/spec.scm0000644000175100000240000000306113605250515021356 0ustar mwettedialout;; language/nx-octave/spec.scm - NYACC extension for Octave ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see . ;;; Code: (define-module (language nx-octave spec) #:export (nx-octave) #:use-module (nyacc lang octave parser) #:use-module (nyacc lang octave compile-tree-il) #:use-module (nyacc lang octave pprint) #:use-module (system base language)) (define-language nx-octave #:title "nx-octave" #:reader (lambda (p e) (cond ((and (file-port? p) (string? (port-filename p)) (not (string-prefix? "/dev/" (port-filename p)))) (read-oct-file p e)) (else (read-oct-stmt p e)))) #:compilers `((tree-il . ,compile-tree-il)) #:evaluator (lambda (exp mod) (primitive-eval exp)) #:printer pretty-print-ml #:make-default-environment (lambda () (let ((env (make-fresh-user-module))) (module-define! env 'current-reader (make-fluid)) env)) ) ;; --- last line --- nyacc-1.00.2/examples/language/calc/0000755000175100000240000000000013605250515016716 5ustar mwettedialoutnyacc-1.00.2/examples/language/calc/spec.scm0000644000175100000240000000217213605250515020356 0ustar mwettedialout;;; language/spec.scm - NYACC's calculator demo ;; Copyright (C) 2015,2018,2019 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see . ;;; Code: (define-module (language calc spec) #:export (calc) #:use-module (system base language) #:use-module (nyacc lang calc parser) #:use-module (nyacc lang calc compiler)) (define-language calc #:title "calc" #:reader read-calc #:compilers `((tree-il . ,compile-tree-il)) ;;#:compilers `((cps . ,compile-cps)) #:printer write) ;; --- last line --- nyacc-1.00.2/examples/ffi/0000755000175100000240000000000013605250515014775 5ustar mwettedialoutnyacc-1.00.2/examples/ffi/clang.ffi0000644000175100000240000000110113605250515016540 0ustar mwettedialout;; clang.ffi -*- Scheme -*- ;; Copyright (C) 2018 Matthew R. Wette ;; ;; Copying and distribution of this file, with or without modification, ;; are permitted in any medium without royalty provided the copyright ;; notice and this notice are preserved. This file is offered as-is, ;; without any warranty. (define-ffi-module (ffi clang) #:inc-dirs '("/usr/lib/llvm-6.0/include") #:include '("clang-c/Index.h") #:inc-filter (lambda (file-spec path-spec) (string-contains path-spec "clang-c/" 0)) #:library '("libclang") ) ;; --- last line --- nyacc-1.00.2/examples/ffi/gobject.ffi0000644000175100000240000000277713605250515017115 0ustar mwettedialout;; gobject.ffi -*- Scheme -*- ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see (define-ffi-module (ffi gobject) #:pkg-config "gobject-2.0" #:include '("glib-object.h") #:inc-filter (lambda (f p) (string-contains p "gobject/" 0)) #:use-ffi-module (ffi glib) ;;#:use-module ((system foreign) #:prefix ffi: #:select(%null-pointer)) ) (define-public (g_signal_connect instance detailed_signal c_handler data) (g_signal_connect_data instance detailed_signal c_handler data NULL 0)) (define-public (g_signal_connect_after instance detailed_signal c_handler data) (g_signal_connect_data instance detailed_signal c_handler data NULL 'G_CONNECT_AFTER)) (define-public (g_signal_connect_swapped instance detailed_signal c_handler data) (g_signal_connect_data instance detailed_signal c_handler data NULL 'G_CONNECT_SWAPPED)) ;; --- last line --- nyacc-1.00.2/examples/ffi/gtkglext1.ffi0000644000175100000240000000272213605250515017400 0ustar mwettedialout;; gtkglext1.ffi -*- Scheme -*- ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see (define-ffi-module (ffi gtkglext1) #:use-ffi-module (ffi gdk2) #:use-ffi-module (ffi gtk2) #:use-ffi-module (ffi glugl) #:pkg-config "gtkglext-1.0" #:include '("gtk/gtkgl.h") #:inc-filter (lambda (f p) (string-contains p "gtkglext-1.0/" 0))) (define-public gtkgl-symval ffi-gtkglext1-symbol-val) (define-public (gtk_widget_get_gl_drawable widget) (make-GdkGLDrawable* (fh-unwrap GdkGLWindow* (gtk_widget_get_gl_window widget)))) ;;#define GDK_TYPE_GL_DRAWABLE (gdk_gl_drawable_get_type ()) ;;#define GDK_GL_DRAWABLE(inst) (G_TYPE_CHECK_INSTANCE_CAST ((inst), GDK_TYPE_GL_DRAWABLE, GdkGLDrawable)) ;;#define GDK_GL_DRAWABLE_CLASS(vtable) (G_TYPE_CHECK_CLASS_CAST ((vtable), GD ;; --- last line --- nyacc-1.00.2/examples/ffi/libssh.ffi0000644000175100000240000000404613605250515016753 0ustar mwettedialout;; libssh.ffi -*- Scheme -*- ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see (define-ffi-module (ffi libssh) #:pkg-config "libssh" #:include '("libssh/libssh.h") #:inc-filter (lambda (file-spec path-spec) (string-contains path-spec "libssh/" 0))) (define-public libssh-symval ffi-libssh-symbol-val) (define-public ssh_channel*-desc (bs:pointer ssh_channel-desc)) (define-fh-pointer-type ssh_channel* ssh_channel*-desc ssh_channel*? make-ssh_channel*) (export ssh_channel* ssh_channel*? make-ssh_channel*) (ref<->deref! ssh_channel* make-ssh_channel* ssh_channel make-ssh_channel) (define-public ssh_key*-desc (bs:pointer ssh_key-desc)) (define-fh-pointer-type ssh_key* ssh_key*-desc ssh_key*? make-ssh_key*) (export ssh_key* ssh_key*? make-ssh_key*) (ref<->deref! ssh_key* make-ssh_key* ssh_key make-ssh_key) (define-public ssh_session*-desc (bs:pointer ssh_session-desc)) (define-fh-pointer-type ssh_session* ssh_session*-desc ssh_session*? make-ssh_session*) (export ssh_session* ssh_session*? make-ssh_session*) (ref<->deref! ssh_session* make-ssh_session* ssh_session make-ssh_session) (define-public ssh_string*-desc (bs:pointer ssh_string-desc)) (define-fh-pointer-type ssh_string* ssh_string*-desc ssh_string*? make-ssh_string*) (export ssh_string* ssh_string*? make-ssh_string*) (ref<->deref! ssh_string* make-ssh_string* ssh_string make-ssh_string) ;; --- last line --- nyacc-1.00.2/examples/ffi/uuid.ffi0000644000175100000240000000063313605250515016433 0ustar mwettedialout;; uuid.ffi -*- Scheme -*- ;; Copyright (C) 2019 Matthew R. Wette ;; ;; Copying and distribution of this file, with or without modification, ;; are permitted in any medium without royalty provided the copyright ;; notice and this notice are preserved. This file is offered as-is, ;; without any warranty. (define-ffi-module (ffi uuid) #:pkg-config "uuid" #:include '("uuid.h")) ;; --- last line --- nyacc-1.00.2/examples/ffi/sqlite3.ffi0000644000175100000240000000215213605250515017047 0ustar mwettedialout;; sqlite3.ffi -*- Scheme -*- ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see (define-ffi-module (ffi sqlite3) #:pkg-config "sqlite3" #:include '("sqlite3.h")) ;; Items the FFI helper is not currently generating. (define-fh-pointer-type sqlite3_int64* (bs:pointer sqlite_int64-desc) sqlite3_int64*? make-sqlite_int64*) (define-fh-pointer-type sqlite3_rtree_dbl (bs:pointer sqlite3_rtree_dbl) sqlite3_rtree_dbl? make-sqlite3_rtree_dbl) ;; --- last line --- nyacc-1.00.2/examples/ffi/gio.ffi0000644000175100000240000000164313605250515016245 0ustar mwettedialout;; gio.ffi -*- Scheme -*- ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see (define-ffi-module (ffi gio) #:use-ffi-module (ffi glib) #:pkg-config "gio-2.0" #:include '("gio/gio.h") #:inc-filter (lambda (f p) (string-contains p "gio/" 0))) ;; --- last line --- nyacc-1.00.2/examples/ffi/glib.ffi0000644000175100000240000000351513605250515016404 0ustar mwettedialout;; glib.ffi -*- Scheme -*- ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see (define-ffi-module (ffi glib) #:pkg-config "glib-2.0" #:include '("glib.h") #:inc-filter (lambda (file-spec path-spec) (or (string-contains path-spec "glib/" 0) (string=? file-spec ""))) ) (define-public G_PI (ffi-glib-symbol-val 'G_PI)) (define-public G_PI_2 (ffi-glib-symbol-val 'G_PI_2)) (define-public G_PI_4 (ffi-glib-symbol-val 'G_PI_4)) (define-public gpointer*-desc (bs:pointer gpointer-desc)) (define-fh-pointer-type gpointer* gpointer*-desc gpointer*? make-gpointer*) (export gpointer* gpointer*? make-gpointer*) (define-public gdouble*-desc (bs:pointer double)) (define-fh-pointer-type gdouble* gdouble*-desc gdouble*? make-gdouble*) (export gdouble* gdouble*? make-gdouble*) (define-public GDestroyNotify*-desc (bs:pointer GDestroyNotify-desc)) (define-fh-pointer-type GDestroyNotify* GDestroyNotify*-desc GDestroyNtify*? make-GDestroyNotify*) (export GDestroyNotify* GDestroyNotify*? make-GDestroyNotify*) #;(set! ffi-glib-types (cons* '(pointer . "gpointer") '(pointer . "gdouble") '(pointer . "GDestroyNotify") ffi-glib-types)) ;; --- last line --- nyacc-1.00.2/examples/ffi/cairo.ffi0000644000175100000240000000505313605250515016563 0ustar mwettedialout;; cairo.ffi -*- Scheme -*- ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see (define-ffi-module (ffi cairo) #:pkg-config "cairo" #:include '("cairo.h" ;;"cairo-ft.h" ;;"cairo-gobject.h" "cairo-pdf.h" ;;"cairo-ps.h" ;;"cairo-quartz-image.h" ;;"cairo-quartz.h" "cairo-svg.h" ;;"cairo-tee.h" ;;"cairo-xml.h" ) ;;#:renamer (lambda (name) ;; (string-map (lambda (c) (if (char=? c #\_) #\- c)) name)) #:export (M_PI M_2PI make-cairo-unit-matrix) ) (define-public cairo_raster_source_acquire_func_t*-desc (bs:pointer cairo_raster_source_acquire_func_t-desc)) (define-fh-pointer-type cairo_raster_source_acquire_func_t* cairo_raster_source_acquire_func_t*-desc cairo_raster_source_acquire_func_t*? make-cairo_raster_source_acquire_func_t*) (export cairo_raster_source_acquire_func_t* cairo_raster_source_acquire_func_t*? make-cairo_raster_source_acquire_func_t*) (ref<->deref! cairo_raster_source_acquire_func_t* make-cairo_raster_source_acquire_func_t* cairo_raster_source_acquire_func_t make-cairo_raster_source_acquire_func_t) (define-public cairo_raster_source_release_func_t*-desc (bs:pointer cairo_raster_source_release_func_t-desc)) (define-fh-pointer-type cairo_raster_source_release_func_t* cairo_raster_source_release_func_t*-desc cairo_raster_source_release_func_t*? make-cairo_raster_source_release_func_t*) (export cairo_raster_source_release_func_t* cairo_raster_source_release_func_t*? make-cairo_raster_source_release_func_t*) (ref<->deref! cairo_raster_source_release_func_t* make-cairo_raster_source_release_func_t* cairo_raster_source_release_func_t make-cairo_raster_source_release_func_t) (define M_PI 3.14159265358979323846) (define M_2PI 6.283185307179586) (define (make-cairo-unit-matrix) (make-cairo_matrix_t #(1.0 0.0 0.0 1.0 0.0 0.0))) ;; --- last line --- nyacc-1.00.2/examples/ffi/x11-xcb.ffi0000644000175100000240000000166713605250515016660 0ustar mwettedialout;; x11-xcb.ffi -*- Scheme -*- ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see (define-ffi-module (ffi x11-xcb) #:pkg-config "x11-xcb" #:include '("xcb/xcb.h") #:inc-filter (lambda (file-spec path-spec) (string-contains path-spec "/xcb/" 0))) ;; --- last line --- nyacc-1.00.2/examples/ffi/librsvg.ffi0000644000175100000240000000157413605250515017142 0ustar mwettedialout;; librsvg.ffi -*- Scheme -*- ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see (define-ffi-module (ffi librsvg) #:use-ffi-module (ffi gobject) #:pkg-config "librsvg-2.0" #:include '("librsvg/rsvg.h")) ;; --- last line --- nyacc-1.00.2/examples/ffi/libgit2.ffi0000644000175100000240000000315213605250515017020 0ustar mwettedialout;; libgit2.ffi -*- Scheme -*- ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see (define-ffi-module (ffi libgit2) #:include '("git2.h") #:inc-filter (lambda (file-spec path-spec) (string-contains path-spec "git2/" 0)) #:library '("libgit2")) (define git_commit**-desc (bs:pointer git_commit*-desc)) (define-fh-pointer-type git_commit** git_commit**-desc git_commit**? make-git_commit**) (ref<->deref! git_commit** make-git_commit** git_commit* make-git_commit*) (define git_repository**-desc (bs:pointer git_repository*-desc)) (define-fh-pointer-type git_repository** git_repository**-desc git_repository**? make-git_repository**) (ref<->deref! git_repository** make-git_repository** git_repository* make-git_repository*) (define unwrap-git_branch_t* (fht-unwrap int*)) (define unwrap-git_merge_analysis_t* (fht-unwrap int*)) (define unwrap-git_merge_preference_t* (fht-unwrap int*)) (define unwrap-git_otype* (fht-unwrap int*)) ;; --- last line --- nyacc-1.00.2/examples/ffi/gtk2.ffi0000644000175100000240000000351313605250515016334 0ustar mwettedialout;; gtk2.ffi -*- Scheme -*- ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see (define-ffi-module (ffi gtk2) #:pkg-config "gtk+-2.0" #:include '("gtk/gtk.h") #:inc-filter (lambda (f p) (string-contains p "gtk/" 0)) #:use-ffi-module (ffi gdk2) #:use-ffi-module (ffi pango) #:use-ffi-module (ffi gobject) #:use-ffi-module (ffi glib)) (define-fh-pointer-type GtkEnumValue* int*-desc GtkEnumValue*? make-GtkEnumValue*) (export GtkEnumValue* GtkEnumValue*? make-GtkEnumValue*) (define-public gtk-symval ffi-gtk2-symbol-val) ;; OK, some gtk programs use (lambda (widget event arg) ...) and Gtk etc does ;; not provide it so I hacek it here (define-public GtkEventCallback-desc (bs:pointer (fh:function 'void (list (bs:pointer 'void) (bs:pointer 'void) (bs:pointer 'void))))) (define-fh-function*-type GtkEventCallback GtkEventCallback-desc GtkEventCallback? make-GtkEventCallback) (export GtkEventCallback GtkEventCallback? make-GtkEventCallback) ;; This is the c function. (define-public ~gtk_widget_destroy (fh-find-symbol-addr "gtk_widget_destroy" ffi-gtk2-llibs)) (define-public ~gtk_main_quit (fh-find-symbol-addr "gtk_main_quit" ffi-gtk2-llibs)) ;; --- last line --- nyacc-1.00.2/examples/ffi/epoll.ffi0000644000175100000240000000210713605250515016576 0ustar mwettedialout;; epoll.ffi -*- Scheme -*- ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see ;; Epoll has a packed structure that should be translated properly to ;; bytestructure definition. (define-ffi-module (ffi epoll) #:include '("sys/epoll.h")) (define-public EPOLL (make-symtab-function ffi-epoll-symbol-tab "EPOLL")) (define-public (make-epoll-event . args) (apply logand (map unwrap-enum-EPOLL_EVENTS args))) ;; --- last line --- nyacc-1.00.2/examples/ffi/gintrospect.ffi0000644000175100000240000000306313605250515020026 0ustar mwettedialout;; gintrospec.ffi -*- Scheme -*- ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see ;; This is not working because ... ;; typedef struct _GIBaseInfoStub GIBaseInfo; ;; => def GIBaseInfo-desc, but not GIBaseInfo ! ;; FX def GIBaseInfo fh-void ;; typedef GIBaseInfo SomeBaseInfo; ;; => ref GIBaseInfo via type-alias ;; struct _GIBaseInfoStub { ... }; ;; => At this point we can assign pointer dereference ;; FX def GIBaseInfo .... ;; int foo1(SomeBaseInfo *a); ;; => ref unwrap-SomeBaseInfo (define-ffi-module (ffi gintrospect) #:pkg-config "gobject-introspection-1.0" #:include '("girepository.h") #:inc-filter (lambda (f p) (string-contains p "gobject-introspection-1.0/" 0)) ;;#:inc-filter (lambda (f p) (string-prefix? " ;; library source: ;; from https://github.com/jmcnamara/libxlsxwriter (define-ffi-module (ffi xlsxwriter) #:include '("xlsxwriter.h") #:library '("libxlsxwriter") ;;#:library '("libxlsxwriter" "libzlib") ??? #:inc-filter (lambda (f p) (string-contains p "xlsxwriter" 0)) #:inc-dirs '("/usr/local/include")) ;; --- last line --- nyacc-1.00.2/examples/ffi/cblas.ffi0000644000175100000240000000064413605250515016553 0ustar mwettedialout;; cblas.ffi -*- Scheme -*- ;; Copyright (C) 2018 Matthew R. Wette ;; ;; Copying and distribution of this file, with or without modification, ;; are permitted in any medium without royalty provided the copyright ;; notice and this notice are preserved. This file is offered as-is, ;; without any warranty. (define-ffi-module (ffi cblas) #:include '("cblas.h") #:library '("libblas") ) ;; --- last line --- nyacc-1.00.2/examples/ffi/dbus.ffi0000644000175100000240000000712013605250515016420 0ustar mwettedialout;; dbus.ffi -*- Scheme -*- ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see ;; See ;; https://dbus.freedesktop.org/doc/api/html/modules.html ;; https://dbus.freedesktop.org/doc/api/html/group__DBus.html ;; bus=> https://dbus.freedesktop.org/doc/api/html/group__DBusBus.html (define-ffi-module (ffi dbus) #:pkg-config "dbus-1" #:include '("dbus/dbus.h") #:inc-filter (lambda (file path) (string-contains path "dbus/" 0)) ) (define-public dbus-symval ffi-dbus-symbol-val) ;; (DBUS 'SERVICE_BUS) => "org.freedesktop.DBus" (define-public DBUS (let* ((cnvt (lambda (pair seed) (let* ((k (car pair)) (v (cdr pair)) (n (symbol->string k))) (if (string-prefix? "DBUS_" n) (acons (string->symbol (substring n 5)) v seed) seed)))) (symtab (let iter ((o '()) (i ffi-dbus-symbol-tab)) (if (null? i) o (iter (cnvt (car i) o) (cdr i)))))) (lambda (key) (assq-ref symtab key)))) ;; dbus_message_append_vals with extra help (define dbus_message_append_args/xh (let ((t_INVALID (dbus-symval 'DBUS_TYPE_INVALID)) (t_BYTE (dbus-symval 'DBUS_TYPE_BYTE)) (t_BOOLEAN (dbus-symval 'DBUS_TYPE_BOOLEAN)) (t_INT16 (dbus-symval 'DBUS_TYPE_INT16)) (t_UINT16 (dbus-symval 'DBUS_TYPE_UINT16)) (t_INT32 (dbus-symval 'DBUS_TYPE_INT32)) (t_UINT32 (dbus-symval 'DBUS_TYPE_UINT32)) (t_INT64 (dbus-symval 'DBUS_TYPE_INT64)) (t_UINT64 (dbus-symval 'DBUS_TYPE_UINT64)) (t_DOUBLE (dbus-symval 'DBUS_TYPE_DOUBLE)) (t_STRING (dbus-symval 'DBUS_TYPE_STRING)) (t_OBJECT_PATH (dbus-symval 'DBUS_TYPE_OBJECT_PATH)) (t_SIGNATURE (dbus-symval 'DBUS_TYPE_SIGNATURE)) (t_UNIX_FD (dbus-symval 'DBUS_TYPE_UNIX_FD)) (t_ARRAY (dbus-symval 'DBUS_TYPE_ARRAY)) (t_VARIANT (dbus-symval 'DBUS_TYPE_VARIANT)) (t_STRUCT (dbus-symval 'DBUS_TYPE_STRUCT)) (t_DICT_ENTRY (dbus-symval 'DBUS_TYPE_DICT_ENTRY))) (define (dbus->ffi-type dbus-type) (case dbus-type ((t_INVALID DBUS_TYPE_INVALID) 'INVALID) ((t_BYTE DBUS_TYPE_BYTE) ffi:uint8) ((t_BOOLEAN DBUS_TYPE_BOOLEAN) ffi:unsigned-int) ((t_INT16 DBUS_TYPE_INT16) ffi:int16) ((t_UINT16 DBUS_TYPE_UINT16) ffi:uint16) ((t_INT32 DBUS_TYPE_INT32) ffi:int32) ((t_UINT32 DBUS_TYPE_UINT32) ffi:uint32) ((t_INT64 DBUS_TYPE_INT64) ffi:int64) ((t_UINT64 DBUS_TYPE_UINT64) ffi:uint64) ((t_DOUBLE DBUS_TYPE_DOUBLE) ffi:double) ((t_STRING DBUS_TYPE_STRING) '*) ((t_ARRAY DBUS_TYPE_ARRAY) '*) ((t_VARIANT DBUS_TYPE_VARIANT) '*) ((t_STRUCT DBUS_TYPE_STRUCT) '*) ((t_DICT_ENTRY DBUS_TYPE_DICT_ENTRY) '*) (else (error "yuck")))) (lambda (message . args) (apply dbus_message_append_args message (let loop ((args args)) (cond ((null? args) #t) ((eq? (dbus->ffi-type (car args)) 'INVALID) (cons 'int t_INVALID)) ((null? (cdr args)) (error "bad call")) (else (let* ((dbus-type (car args)) (ffi-type (dbus->ffi-type dbus-type)) (arg-value (cadr args))) (cons* (cons ffi:int (unwrap-enum dbus-type)) (cons ffi-type arg-value) (loop (cddr args))))))))))) ;; --- last line --- nyacc-1.00.2/examples/ffi/hack1.ffi0000644000175100000240000000460413605250515016456 0ustar mwettedialout;; hack1.ffi -*- Scheme -*- ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see ;; This illustrates use of `#:api-code' option which allows user to generate ;; the equivalent of a custom include file. (define-ffi-module (ffi hack1) #:pkg-config "gtk+-2.0" ;;#:def-types '("GtkWidget" "GtkContainer") #| #:api-code " #include void gtk_init(int *argc, char ***argv); gulong g_signal_connect_data(gpointer instance, const gchar *detailed_signal, GCallback c_handler, gpointer data, GClosureNotify destroy_data, GConnectFlags connect_flags); void gtk_container_set_border_width(GtkContainer *container, guint border_width); void gtk_container_add(GtkContainer *container, GtkWidget *widget); void gtk_widget_show(GtkWidget *widget); void gtk_widget_destroy(GtkWidget *widget); void gtk_main(void); void gtk_main_quit(void); " |# #:include '("gtk/gtk.h" "glib-object.h") #:inc-filter (lambda (file-spec path-spec) (or (string=? file-spec "") (string-contains path-spec "glib/" 0) (string-contains path-spec "gobject/" 0) ;;(string-contains path-spec "pango/" 0) ;;(string-contains path-spec "gdk/" 0) (string-contains path-spec "gtk/" 0) )) #:decl-filter (lambda (name) (member name '("gtk_init" "gtk_main" "gtk_main_quit" "g_signal_connect_data" "gtk_container_add" "gtk_container_set_border" "gtk_widget_show" "gtk_widget_destroy" ))) ) (define-public (g_signal_connect instance detailed_signal c_handler data) (g_signal_connect_data instance detailed_signal c_handler data NULL 0)) ;; --- last line --- nyacc-1.00.2/examples/ffi/gettext-po.ffi0000644000175100000240000000657713605250515017602 0ustar mwettedialout;; ffi/gettext-po.ffi -*- scheme -*- ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see ;; initiated by Florian Pelz (define-ffi-module (ffi gettext-po) #:include '("gettext-po.h") #:library '("libgettextpo")) (define-public std-po-error-handler (let* ((error (lambda (status errnum format) (simple-format #t "~A\n" (ffi:pointer->string format)))) (error-p (ffi:procedure->pointer ffi:void error (list ffi:int ffi:int '*))) ;; (error_at_line (lambda (status errnum filename lineno format) (simple-format #t "~A\n" (ffi:pointer->string format)))) (error_at_line-p (ffi:procedure->pointer ffi:void error_at_line (list ffi:int ffi:int '* ffi:int '*))) ;; (multiline_warning (lambda (prefix message) (simple-format #t "~A ~A\n" (ffi:pointer->string prefix) (ffi:pointer->string message)))) (multiline_warning-p (ffi:procedure->pointer ffi:void multiline_warning (list '* '*))) ;; (multiline_error (lambda (prefix message) (simple-format #t "~A ~A\n" prefix message))) (multiline_error-p (ffi:procedure->pointer ffi:void multiline_error (list '* '*))) ;; (eh-struct (make-struct-po_error_handler))) (fh-object-set! eh-struct 'error error-p) (fh-object-set! eh-struct 'error_at_line error_at_line-p) (fh-object-set! eh-struct 'multiline_warning multiline_warning-p) (fh-object-set! eh-struct 'multiline_error multiline_error-p) ;; ;; The ffi helper needs help to make this easier: (make-po_error_handler_t (ffi:pointer-address ((fht-unwrap struct-po_error_handler*) (pointer-to eh-struct)))))) (define-public std-po-xerror-handler (let* ( (xerror (lambda (severity message filename lineno column multiline_p message_text) (simple-format #t "~A\n" (ffi:pointer->string message_text)))) (xerror-p (ffi:procedure->pointer ffi:void xerror (list ffi:int '* '* ffi:size_t ffi:size_t ffi:int '*))) (xerror2 (lambda (severity message1 filename1 lineno1 column1 multiline_p1 message_text1 message2 filename2 lineno2 column2 multiline_p2 message_text2 ) (simple-format #t "~A\n" (ffi:pointer->string message_text1)))) (xerror2-p (ffi:procedure->pointer ffi:void xerror2 (list ffi:int '* '* ffi:size_t ffi:size_t ffi:int '* ffi:int '* '* ffi:size_t ffi:size_t ffi:int '*))) ;; (eh-struct (make-struct-po_xerror_handler))) (fh-object-set! eh-struct 'xerror (ffi:pointer-address xerror-p)) (fh-object-set! eh-struct 'xerror2 (ffi:pointer-address xerror2-p)) ;; ;; The ffi helper needs help to make this easier: (make-po_xerror_handler_t (ffi:pointer-address ((fht-unwrap struct-po_xerror_handler*) (pointer-to eh-struct)))))) ;; --- last line --- nyacc-1.00.2/examples/ffi/zlib.ffi0000644000175100000240000000150613605250515016425 0ustar mwettedialout;; zlib.ffi -*- Scheme -*- ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see (define-ffi-module (ffi zlib) #:pkg-config "zlib" #:include '("zlib.h")) ;; --- last line --- nyacc-1.00.2/examples/ffi/lightning.ffi0000644000175100000240000001242613605250515017453 0ustar mwettedialout;; lightning.ffi -*- Scheme -*- ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see (define-ffi-module (ffi lightning) #:include '("lightning.h" "lightning/jit_x86.h") #:inc-filter (lambda (file path) (or (string-contains file "lightning") (string-contains path "lightning/"))) #:library '("liblightning")) (define-public jitsym ffi-lightning-symbol-val) ;;; Generated from examples/nyacc/lang/c99/mkjit.scm (define (jit_get_note n u v w) (_jit_get_note _jit n u v w)) (define (jit_pointer_p u) (_jit_pointer_p _jit u)) (define (jit_callee_save_p u) (_jit_callee_save_p _jit u)) (define (jit_arg_register_p u) (_jit_arg_register_p _jit u)) (define (jit_new_node_pwd c u v w) (_jit_new_node_pwd _jit c u v w)) (define (jit_new_node_pwf c u v w) (_jit_new_node_pwf _jit c u v w)) (define (jit_new_node_pww c u v w) (_jit_new_node_pww _jit c u v w)) (define (jit_new_node_wwd c u v w) (_jit_new_node_wwd _jit c u v w)) (define (jit_new_node_wwf c u v w) (_jit_new_node_wwf _jit c u v w)) (define (jit_new_node_qww c l h v w) (_jit_new_node_qww _jit c l h v w)) (define (jit_new_node_www c u v w) (_jit_new_node_www _jit c u v w)) (define (jit_new_node_wd c u v) (_jit_new_node_wd _jit c u v)) (define (jit_new_node_wf c u v) (_jit_new_node_wf _jit c u v)) (define (jit_new_node_pw c u v) (_jit_new_node_pw _jit c u v)) (define (jit_new_node_dp c u v) (_jit_new_node_dp _jit c u v)) (define (jit_new_node_fp c u v) (_jit_new_node_fp _jit c u v)) (define (jit_new_node_wp c u v) (_jit_new_node_wp _jit c u v)) (define (jit_new_node_ww c u v) (_jit_new_node_ww _jit c u v)) (define (jit_new_node_p c u) (_jit_new_node_p _jit c u)) (define (jit_new_node_d c u) (_jit_new_node_d _jit c u)) (define (jit_new_node_f c u) (_jit_new_node_f _jit c u)) (define (jit_new_node_w c u) (_jit_new_node_w _jit c u)) (define (jit_new_node c) (_jit_new_node _jit c)) (define (jit_tramp u) (_jit_tramp _jit u)) (define (jit_frame u) (_jit_frame _jit u)) (define (jit_set_data u v w) (_jit_set_data _jit u v w)) (define (jit_get_data u v) (_jit_get_data _jit u v)) (define (jit_set_code u v) (_jit_set_code _jit u v)) (define (jit_get_code u) (_jit_get_code _jit u)) (define (jit_patch_abs u v) (_jit_patch_abs _jit u v)) (define (jit_patch_at u v) (_jit_patch_at _jit u v)) (define (jit_patch u) (_jit_patch _jit u)) (define (jit_target_p u) (_jit_target_p _jit u)) (define (jit_indirect_p u) (_jit_indirect_p _jit u)) (define (jit_forward_p u) (_jit_forward_p _jit u)) (define (jit_address node) (_jit_address _jit node)) (define (jit_regno reg) (logand reg #x00007fff)) (define (jit_class reg) (logand reg #xffff0000)) (define (JIT_F index) (jit_f index)) (define (JIT_V index) (jit_v index)) (define (JIT_R index) (jit_r index)) (define (jit_x87_reg_p reg) (and (>= reg _ST0) (<= reg _ST6))) ;;; Extract from jit_x86.h (define jit_r (lambda (i) (error "undefined"))) (define jit_r_num (lambda () (error "undefined"))) (define jit_v (lambda (i) (error "undefined"))) (define jit_v_num (lambda () (error "undefined"))) (define jit_f (lambda (i) (error "undefined"))) (define jit_f_num (lambda () (error "undefined"))) (define JIT_R0 (if #f #f)) (define JIT_R1 (if #f #f)) (define JIT_R2 (if #f #f)) (define JIT_R3 (if #f #f)) (define JIT_V0 (if #f #f)) (define JIT_V1 (if #f #f)) (define JIT_V2 (if #f #f)) (define JIT_V3 (if #f #f)) (define JIT_F0 (if #f #f)) (define JIT_F1 (if #f #f)) (define JIT_F2 (if #f #f)) (define JIT_F3 (if #f #f)) (define JIT_F4 (if #f #f)) (define JIT_F5 (if #f #f)) (define JIT_F6 (if #f #f)) (define JIT_F7 (if #f #f)) (define jit_se_reg_p (lambda (reg) (error "undefined"))) (cond ((string=? %host-type "x86_64-pc-linux-gnu") (set! jit_r (lambda (i) (+ (jitsym '_RAX) i))) (set! jit_r_num (lambda () 4)) (set! jit_v (lambda (i) (+ (jitsym '_RBX) i))) (set! jit_v_num (lambda () 4)) (set! jit_f (lambda (index) (+ (jitsym '_XMM8) index))) (set! jit_f_num (lambda () 8)) (set! jit_R0 (jitsym '_RAX)) (set! jit_R1 (jitsym '_R10)) (set! jit_R2 (jitsym '_R11)) (set! jit_R3 (jitsym '_R12)) (set! jit_V0 (jitsym '_RBX)) (set! jit_V1 (jitsym '_R13)) (set! jit_V2 (jitsym '_R14)) (set! jit_V3 (jitsym '_R15)) (set! jit_F0 (jitsym '_XMM8)) (set! jit_F1 (jitsym '_XMM9)) (set! jit_F2 (jitsym '_XMM10)) (set! jit_F3 (jitsym '_XMM11)) (set! jit_F4 (jitsym '_XMM12)) (set! jit_F5 (jitsym '_XMM13)) (set! jit_F6 (jitsym '_XMM14)) (set! jit_F7 (jitsym '_XMM15)) (set! jit_sse_reg_p (lambda (reg) (and (>= reg (jitsym '_XMM8)) (<= reg (jitsym '_XMM0)))))) (else (display "(ffi lightning): host-type not handled\n" (current-error-port)))) ;; --- last line --- nyacc-1.00.2/examples/ffi/TMPL.ffi0000644000175100000240000000100713605250515016235 0ustar mwettedialout;; TMPL.ffi -*- Scheme -*- ;; Copyright (C) 2018 Matthew R. Wette ;; ;; Copying and distribution of this file, with or without modification, ;; are permitted in any medium without royalty provided the copyright ;; notice and this notice are preserved. This file is offered as-is, ;; without any warranty. (define-ffi-module (ffi TMPL) #:pkg-config "TMPL" #:include '("TMPL.h") ;;#:inc-filter (lambda (file-spec path-spec) ;; (string-contains path-spec "TMPL/" 0)) ) ;; --- last line --- nyacc-1.00.2/examples/ffi/NOTES0000644000175100000240000000231413605250515015610 0ustar mwettedialoutTo generate a scm from ffi, using cairo.ffi as example: $ guild compile-ffi ffi/cairo.ffi wrote `ffi/cairo.scm' MISSING: 1) Guile does not have some types. Need the following: long long, unsigned long long, intptr_t, uintptr_t, long double (glib) 2) Guile does not handle varargs ffi. I have thoughts on this. 3) bytestructures does not support function declarations. 4) arrays as function args done yet? 5) patterns for in/out semantics; see http://www.swig.org/article_cpp.html BROKEN: 1) struct { char *name; } => (bs:struct `((name (bs:pointer int)))) vs (bs:struct `((name (bs:pointer uint8)))) 2) use of @193 instead of arg-0 for args TODO: 2) move enum comments to ffi.scm comments (currently removed) 3) recheck (pointer-to x) <=> (object-at y) 5) allow suck-in of #defines (e.g., M_PI, HUGE_VAL from math.h) but may not work cause '#define HUGE_VAL __builtin_huge_val()' NOTES: To compile a cairo.ffi file execute the following shell command: $ guild compile-ffi cairo.ffi cairo.ffi working gdbm.ffi working? libgit2.ffi working librsvg.ffi working sqlite3.ffi working glib.ffi long double gobject.ffi working gio.ffi working gtk2+.ffi working IN WORK: nyacc-1.00.2/examples/ffi/gdk2.ffi0000644000175100000240000000240713605250515016315 0ustar mwettedialout;; gdk2.ffi -*- Scheme -*- ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see (define-ffi-module (ffi gdk2) #:pkg-config "gdk-2.0" #:include '("gdk/gdk.h") #:inc-filter (lambda (file-spec path-spec) (or (string-contains path-spec "gdk/" 0) (string=? file-spec ""))) #:use-ffi-module (ffi glib) #:use-ffi-module (ffi gobject) #:use-ffi-module (ffi pango)) (define-public GdkAtom*-desc (bs:pointer GdkAtom)) (define-fh-pointer-type GdkAtom* GdkAtom*-desc GdkAtom*? make-GdkAtom*) (export GdkAtom* GdkAtom*? make-GdkAtom*) (define-public gdk-symval ffi-gdk2-symbol-val) ;; --- last line --- nyacc-1.00.2/examples/ffi/glugl.ffi0000644000175100000240000000204113605250515016572 0ustar mwettedialout;; glugl.ffi -*- Scheme -*- ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see (define-ffi-module (ffi glugl) #:include '("GL/gl.h" "GL/glu.h") #:library '("libGLU" "libGL") #:inc-filter (lambda (spec path) (string-contains path "GL/" 0)) #:decl-filter (lambda (n) (not (and (string? n) (string-prefix? "PF" n))))) (define-public glugl-symval ffi-glugl-symbol-val) ;; --- last line --- nyacc-1.00.2/examples/ffi/libevent.ffi0000644000175100000240000000173713605250515017303 0ustar mwettedialout;; libevent.ffi -*- Scheme -*- ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see (define-ffi-module (ffi libevent) ;;#:pkg-config "libevent" #:include '("event2/event.h") #:inc-filter (lambda (file-spec path-spec) (string-contains path-spec "event2/" 0)) #:library '(libevent_core)) ;; --- last line --- nyacc-1.00.2/examples/ffi/htslib.ffi0000644000175100000240000000167113605250515016755 0ustar mwettedialout;; htslib.ffi -*- Scheme -*- ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see (define-ffi-module (ffi htslib) #:pkg-config "htslib" #:include '("htslib/hts.h") #:inc-filter (lambda (file-spec path-spec) (string-contains path-spec "htslib/" 0))) ;; --- last line --- nyacc-1.00.2/examples/ffi/pango.ffi0000644000175100000240000000211113605250515016562 0ustar mwettedialout;; pango.ffi -*- Scheme -*- ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see (define-ffi-module (ffi pango) #:pkg-config "pango" #:include '("pango/pango.h") #:inc-filter (lambda (f p) (string-contains p "pango/" 0)) #:use-ffi-module (ffi glib) #:use-ffi-module (ffi gobject)) ;; PangoScript is an enum. Some routines return pointer to int for this. (define-public wrap-PangoScript* (fht-wrap int*)) ;; --- last line --- nyacc-1.00.2/examples/ffi/pangocairo.ffi0000644000175100000240000000216713605250515017613 0ustar mwettedialout;; pango.ffi -*- Scheme -*- ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see (define-ffi-module (ffi pangocairo) #:pkg-config "pangocairo" #:include '("pango/pangocairo.h") #:inc-filter (lambda (f p) (string-contains p "pango/" 0)) #:use-ffi-module (ffi glib) #:use-ffi-module (ffi gobject) #:use-ffi-module (ffi cairo)) ;; PangoScript is an enum. Some routines return pointer to int for this. (define-public wrap-PangoScript* (fht-wrap int*)) ;; --- last line --- nyacc-1.00.2/examples/ffi/hdf5.ffi0000644000175100000240000000241013605250515016306 0ustar mwettedialout;; hdf5.ffi - -*- Scheme -*- ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see ;;; Notes: ;; HDF5 is "diverse" in declarations and a challenge to the FH. ;; On my Ubuntu pkg-config says shared lib is in ;; /usr/lib/x86_64-linux-gnu/hdf5/serial ;; but there is ;; /usr/lib/x86_64-linux-gnu/libhdf5_serial.so ;; so things are broken unless we add that. ;;; Code: (define-ffi-module (ffi hdf5) #:pkg-config "hdf5" #:include '("hdf5.h" "hdf5_hl.h") #:inc-filter (lambda (file-spec path-spec) (string-prefix? "\"H5" file-spec)) #:library '("libhdf5_serial") ; HDF5 pkg-config broken ) ;; --- last line --- nyacc-1.00.2/examples/ffi/gdbm.ffi0000644000175100000240000000252613605250515016401 0ustar mwettedialout;; gdbm.ffi -*- Scheme -*- ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see (define-ffi-module (ffi gdbm) #:include '("gdbm.h") #:library '("libgdbm")) ;; I think GDBM_FILE are not defined and used consistently. (define-fh-pointer-type GDBM_FILE* GDBM_FILE*-desc GDBM_FILE*? make-GDBM_FILE*) (export GDBM_FILE* GDBM_FILE*? make-GDBM_FILE*) ;; This is needed but not generated by default by compile-ffi. ;; needed on my mac (version?) but not on ubuntu 16.04 ;; so we may need to deal with versions : ugh #| (define-fh-pointer-type gdbm_count_t* (bs:pointer gdbm_count_t-desc) gdbm_count_t*? make-gdbm_count_t*) (export gdbm_count_t* gdbm_count_t*? make-gdbm_count_t*) |# ;; --- last line --- nyacc-1.00.2/examples/ffi/eina.ffi0000644000175100000240000000165513605250515016406 0ustar mwettedialout;; eina.ffi -*- Scheme -*- ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see (define-ffi-module (ffi eina) #:pkg-config "eina" #:include '("Eina.h") #:inc-filter (lambda (file-spec path-spec) (string-contains file-spec "eina" 0)) ) ;; --- last line --- nyacc-1.00.2/examples/ffi/liblinear.ffi0000644000175100000240000000246613605250515017434 0ustar mwettedialout;; liblinear.ffi -*- Scheme -*- ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see ;; see https://github.com/cjlin1/liblinear (define-ffi-module (ffi liblinear) #:include '("linear.h") #:library '("liblinear") #:export (linear-symval)) #| (define-public struct-feature_node**-desc (bs:pointer struct-feature_node*-desc)) (define-fh-pointer-type struct-feature_node** struct-feature_node**-desc struct-feature_node**? make-struct-feature_node**) (ref<->deref! struct-feature_node** make-struct-feature_node** struct-feature_node* make-struct-feature_node*) ;;(define linear-INF +inf.0) (define linear-symval ffi-linear-symbol-val) |# ;; --- last line --- nyacc-1.00.2/examples/ffi/zziplib.ffi0000644000175100000240000000152413605250515017150 0ustar mwettedialout;; zziplib.ffi -*- Scheme -*- ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see (define-ffi-module (ffi zziplib) #:pkg-config "zziplib" #:include '("zzip/zzip.h")) ;; --- last line --- nyacc-1.00.2/examples/ffi/libelf.ffi0000644000175100000240000000207613605250515016725 0ustar mwettedialout;; libelf.ffi -*- Scheme -*- ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see ;; Epoll has a packed structure that should be translated properly to ;; bytestructure definition. (define-ffi-module (ffi libelf) #:pkg-config "libelf" #:include '("libelf.h" "gelf.h") #:inc-filter (lambda (file-spec path-spec) (string-contains file-spec "elf.h" 0))) (define elf-symval ffi-libelf-symbol-val) ;; --- last line --- nyacc-1.00.2/examples/nyacc/0000755000175100000240000000000013605250515015326 5ustar mwettedialoutnyacc-1.00.2/examples/nyacc/impl/0000755000175100000240000000000013605250515016267 5ustar mwettedialoutnyacc-1.00.2/examples/nyacc/impl/python/0000755000175100000240000000000013605250515017610 5ustar mwettedialoutnyacc-1.00.2/examples/nyacc/impl/python/lex.py0000644000175100000240000001323113605250515020752 0ustar mwettedialout#!/usr/bin/env python # # Copyright (C) 2015 - Matthew R.Wette # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Lesser General Public # License as published by the Free Software Foundation; either # version 3 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser General Public # License along with this library; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA import string id_f = string.letters + "$_" id_r = cf + string.digits def esc_char(c): if c == 'r': return '\r' elif c == 'n': return '\n' elif c == 't': return '\t' elif c == 'b': return '\b' else: return c # This is not pretty, being a translation of the scheme version, but I don't # want to get into clean design in all the target languages. -- Matt class Lexer: def __init__(self, mtab): self.spaces = " \t\r\n" self.id_f = id_f self.id_r = id_r self.s_st = '"' self.s_nd = '"' def set_input(self, f0): self.f0 = f0 def read(self): self.f0.read(1) def unread(self, ch): self.f0.seek(-1,1) def read_ident(self, ch): if ch not in self.id_f: return false chl = [ch] ch = self.read() while ch in self.id_r: chl.append(ch) f0. return ('$ident', chl) def read_num(self, ch): chl = "" tt = '$fixed' st = 0 while True: if st == 0: if len(ch) == 0: st = 5 elif isdigit(ch): chl.append(ch) st = 1 else: return false elif st == 1: if len(ch) == 0: st = 5 elif isdigit(ch): chl.append(ch) elif ch == '.': chl.append(ch) tt = '$float' st = 2 else: st = 5 elif st == 2: if len(ch) == 0: st = 5 elif isdigit(ch): chl.append(ch) elif ch in 'eEdD': #if chl[-1] == '.': chl.append('0') chl.append(ch) st = 3 else: #if chl[-1] == '.': chl.append('0') st = 5 elif st == 3: if len(ch) == 0: st = 5 elif ch in '+-': chl.append(ch) st = 4 elif isdigit(ch): chl.append(ch) st = 4 else: raise Exception, "syntax error" elif st == 4: if len(ch) == 0: st = 5 elif isdigit(ch): chl.append(ch) else: st = 5 elif st == 5: self.unread(ch) return (tt, chl) ch = self.read() def read_string(self, ch): if ch != self.s_st: return false chl = [ch] while True: ch = self.read() if ch == '\\': chl.append(esc_char(self.read())) elif ch == '"': break else: chl.append(ch) return ('$string', buf) def read_chlit(self, ch): if ch != self.c_st: return false ch = self.read() if ch == '\\': ch = esc_char(self.read()) self.read() return ('$chlit', ch) def read_comm(self, ch): if ch != '/': return false st = [ch, self.read()] if st == "//": nd = "\n" elif st == "/*": nd = "*/" else: self.unread(st[1]) self.unread('/') return false chl = "" ix = 0 while True: ch = self.read() if ix == len(nd): return ('$comm', chl) elif ch == nd[ix]: ix = ix + 1 continue else: ix = 0 chl.append(ch) pass def skip_comm(self, ch): return self.read_comm(ch) def read_chseq(self, ch): return false #ident-like def gettok(self, ): ch = self.read_char() while True: if ch == eof: sys.exit(0) elif ch.isspace(): ch = self.read_char() continue p = self.read_comm(ch) if p: return p p = self.skip_comm(ch) if p: ch = self.read_char() continue p = self.read_ident(ch) if p: return p p = self.read_num(ch) if p: return p p = self.read_string(ch) if p: return p p = self.read_chlit(ch) if p: return p p = self.read_chseq(ch) if p: return p p = self.assq_ref_chrtab(ch) if p: return p print "*** ERROR" sys.exit(0) # --- last line --- nyacc-1.00.2/examples/nyacc/impl/python/act.py0000644000175100000240000000207613605250515020736 0ustar mwettedialout# act.py # # Copyright (C) 2015 - Matthew R.Wette # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Lesser General Public # License as published by the Free Software Foundation; either # version 3 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser General Public # License along with this library; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA def aDEF(*rest): if len(rest) > 0: return rest[0] else: return [] def a001(S1, *rest): return tl2list(S1) def a011(S1, *rest): return S1 def find_act(name): d = globals() if d.has_key(name): return d[name] else: return aDEF # --- last line --- nyacc-1.00.2/examples/nyacc/README0000644000175100000240000000130113605250515016201 0ustar mwettedialoutmodule/nyacc/README Copyright (C) 2015 Matthew R. Wette Copying and distribution of this file, with or without modification, are permitted in any medium without royalty provided the copyright notice and this notice are preserved. This file is offered as-is, without any warranty. lang The directory lang has example parsers for several languages. See lang/README. oops To run the examples you will need .../module and .../examples in your GUILE_LOAD_PATH. usage $ cd lang/c99; ./cxp -Iexam.d exam.d/ex1.c or $ cd lang/c99; guile Tlangc.scm or $ cd lang/javascript; guile Tlangjs.scm or $ cd lang/matlab; guile Tlangm.scm or $ cd lang/modelica; guile Tlangmo.scm nyacc-1.00.2/examples/nyacc/ChangeLog0000644000175100000240000000115113605250515017076 0ustar mwettedialout2017-09-16 Matt Wette * lang/c99/ffi-help.scm (cnvt-field-list): for bitfields was generating `(name ,type ,size), now generates `(name ,type size) 2017-05-28 Matt Wette * lang/javascript/mach.scm (js-spec): finally got full javascript grammar by adding precedence to lalr rr-conflict! Copyright (C) 2017 Matthew R. Wette Copying and distribution of this file, with or without modification, are permitted in any medium without royalty provided the copyright notice and this notice are preserved. This file is offered as-is, without any warranty. nyacc-1.00.2/examples/nyacc/lang/0000755000175100000240000000000013605250515016247 5ustar mwettedialoutnyacc-1.00.2/examples/nyacc/lang/ffi-help/0000755000175100000240000000000013605250515017741 5ustar mwettedialoutnyacc-1.00.2/examples/nyacc/lang/ffi-help/dbus-02.scm0000644000175100000240000000614513605250515021627 0ustar mwettedialout;;; examples/nyacc/lang/ffi-help/dbus-02.scm - mainloop example ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see ;;; Description: ;; you can do ;; $ guile dbus-02.scm ;; or ;; $ guile -l dbus-02.scm ;; to send more ;;; Code: (add-to-load-path (getcwd)) (use-modules (system dbus)) (use-modules (ffi dbus)) (use-modules (system ffi-help-rt)) (use-modules ((system foreign) #:prefix ffi:)) (define (sf fmt . args) (apply simple-format #t fmt args)) (use-modules (ice-9 pretty-print)) (define pp pretty-print) (define (send-msg conn msg) (let ((pending (make-DBusPendingCall*))) (if (eqv? FALSE (dbus_connection_send_with_reply conn msg (pointer-to pending) -1)) (error "*** send_with_reply FAILED\n")) (dbus_message_unref msg) pending)) (define (send-sig conn sig) (let ((serial (make-uint32))) (if (eqv? FALSE (dbus_connection_send conn sig (pointer-to serial))) (error "*** send FAILED\n")) (dbus_message_unref sig) serial)) (define (there-yet? pending) (eqv? TRUE (dbus_pending_call_get_completed pending))) (define (handle-it pending) (let ((msg (dbus_pending_call_steal_reply pending)) (msg-iter (make-DBusMessageIter))) (if (zero? (fh-object-ref msg)) (error "*** reply message NULL\n")) (dbus_pending_call_unref pending) (dbus_message_iter_init msg (pointer-to msg-iter)) (sf "result:\n") (pretty-print (read-dbus-val (pointer-to msg-iter)) #:per-line-prefix " ") (dbus_message_unref msg))) (define (block-and-handle-it pending) (dbus_pending_call_block pending) (handle-it pending)) ;; ========================================================================== ;; d-feet is GUI to check dictionary ;; https://pythonhosted.org/txdbus/dbus_overview.html ;; http://git.0pointer.net/rtkit.git/tree/README (define msg02/ses ; works (dbus_message_new_method_call "org.freedesktop.DBus" ; bus name "/org/freedesktop/DBus" ; object path "org.freedesktop.DBus.Debug.Stats" ; interface name "GetStats")) ; method (define msg03/all ; works (dbus_message_new_method_call "org.freedesktop.DBus" ; bus name "/org/freedesktop/DBus" ; object path "org.freedesktop.DBus" ; interface name "GetId")) ; method (define conn (spawn-dbus-mainloop 'session)) (define pending (send-msg conn msg02/ses)) (let loop ((got-it? (there-yet? pending))) (sf "there-yet? => ~S\n" got-it?) (cond (got-it? (handle-it pending)) (else (sleep 1) (loop (there-yet? pending))))) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/ffi-help/gdbus-03.scm0000644000175100000240000001104513605250515021772 0ustar mwettedialout;; gdbus03.scm - dbus stats w/ type printing (include-from-path "nyacc/lang/c99/ffi-exam/gdbus00.scm") ;; (sv) => GVariant* (define (make-gv-type spec) #f) ;; "s" => GVariantType* (define (make-gv-base-type str) (let* ((code (string-copy str)) (ptr (ffi:string->pointer code)) (addr (ffi:pointer-address ptr))) (glib-guardian code) (make-GVariantType* addr))) (define gv-uint8-type (make-gv-base-type "y")) (define gv-bool-type (make-gv-base-type "b")) (define gv-int16-type (make-gv-base-type "n")) (define gv-uint16-type (make-gv-base-type "q")) (define gv-int32-type (make-gv-base-type "i")) (define gv-uint32-type (make-gv-base-type "u")) (define gv-int64-type (make-gv-base-type "x")) (define gv-uint64-type (make-gv-base-type "t")) (define gv-double-type (make-gv-base-type "d")) (define gv-string-type (make-gv-base-type "s")) (define (nonzero? v) (not (zero? v))) ;; simple variant -> scm (define (simple-gv->scm variant) (cond ;;((nonzero? (g_variant_type_is_of_type variant gv-uint8-type)) #f) ((nonzero? (g_variant_is_of_type variant gv-bool-type)) (not (zero? (g_variant_get_boolean variant)))) ((nonzero? (g_variant_is_of_type variant gv-int16-type)) (g_variant_get_int16 variant)) ((nonzero? (g_variant_is_of_type variant gv-uint16-type)) (g_variant_get_uint16 variant)) ((nonzero? (g_variant_is_of_type variant gv-int32-type)) (g_variant_get_int32 variant)) ((nonzero? (g_variant_is_of_type variant gv-uint32-type)) (g_variant_get_uint32 variant)) ((nonzero? (g_variant_is_of_type variant gv-int64-type)) (g_variant_get_int64 variant)) ((nonzero? (g_variant_is_of_type variant gv-uint64-type)) (g_variant_get_uint64 variant)) ((nonzero? (g_variant_is_of_type variant gv-double-type)) (g_variant_get_double variant)) (else (error "not handled")))) ;; GVariant* => scm (define (gv->scm variant) (let* ((type (g_variant_get_type_string variant)) (type (ffi:pointer->string type)) ) (cond ((< 1 (string-length type)) ;; compound type #f) ((member (string-ref type 0) '(#\v)) (gv->scm (g_variant_get_variant variant))) (else (simple-gv->scm variant))))) ;; (array-of dict ;; === main ============================ ;; @deffn {Procedure} for-each-variant proc coll ;; iterate over the variants with @var{proc} using @code{(proc elt)}. ;; @end deffn (define (for-each-variant proc coll) (let ((gviter (g_variant_iter_new coll))) (let iter () (let ((gv (g_variant_iter_next_value gviter))) (unless (gv-null? gv) ;; we should pass a scheme value maybe (proc gv) (iter)))))) (define (for-each-gv-dict-entry proc coll) (for-each-variant (lambda (elt) ;; should get {sv} (let* ((~key (g_variant_get_child_value elt 0)) (~val (g_variant_get_child_value elt 1)) (key (ffi:pointer->string (g_variant_get_string ~key NULL))) (val ~val) ) (proc key val))) coll)) (use-modules (sxml simple)) (use-modules (sxml xpath)) (define loop (g_main_loop_new NULL FALSE)) (define error (make-GError*)) (define conn (g_bus_get_sync 'G_BUS_TYPE_SESSION NULL (pointer-to error))) (define return-type (g_variant_type_new "(a{sv})")) (define (check-rez rez) ; rez: GVariant* (let* ((type (ffi:pointer->string (g_variant_get_type_string rez))) (elt0 (g_variant_get_child_value rez 0)) ) ;; needs work (glib-guardian elt0) (for-each-gv-dict-entry (lambda (key val) (let* ((vv (g_variant_get_variant val)) (vt (g_variant_get_type_string vv)) (v (g_variant_get_uint32 vv)) ) ;;(sf "~S:\n" key) ;;(sf " ~S: ~S\n" (ffi:pointer->string vt) v) (sf "~A: ~S\n" key (gv->scm vv)) )) elt0))) (define callback (make-GAsyncReadyCallback (lambda (~src ~res user_data) (let* ((src (make-GObject* ~src)) (res (make-GAsyncResult* ~res)) (err (make-GError*)) (rez (g_dbus_connection_call_finish conn res (pointer-to err))) ) (if (got-error? err) (sf "~A\n" (g-error-message err)) (check-rez rez)) (g_main_loop_quit loop) (if #f #f))))) (g_dbus_connection_call conn ; connection "org.freedesktop.DBus" ; bus name (was NULL) "/org/freedesktop/DBus" ; object path "org.freedesktop.DBus.Debug.Stats" ; interface name "GetStats" ; method NULL ; parameters return-type ; GVariantType* 'G_DBUS_CALL_FLAGS_NONE ; GDBusCallFlags 1000 ; timeout_msec NULL ; GCancellable* callback ; GAsyncReadyCallback NULL ; user_data ) (g_variant_type_free return-type) (g_main_loop_run loop) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/ffi-help/gdbus-02.scm0000644000175100000240000000311013605250515021763 0ustar mwettedialout;; dbus02.scm (include-from-path "nyacc/lang/c99/ffi-exam/dbus00.scm") ;; === main ============================ (use-modules (sxml simple)) (use-modules (sxml xpath)) (define loop (g_main_loop_new NULL FALSE)) (define error (make-GError*)) (define conn (g_bus_get_sync 'G_BUS_TYPE_SESSION NULL (pointer-to error))) (define (check-rez rez) ; rez: GVariant* (let* ((type (ffi:pointer->string (g_variant_get_type_string rez))) (elt0 (g_variant_get_child_value rez 0)) (strp (g_variant_get_string elt0 NULL)) (strv (ffi:pointer->string strp)) (sx0 (xml->sxml strv #:trim-whitespace? #t)) (sxi ((sxpath '(// interface)) sx0)) ; interfaces ) ;; needs work (glib-guardian elt0) ;;(display strv) (pp sxi) )) (define callback (make-GAsyncReadyCallback (lambda (~src ~res user_data) (let* ((src (make-GObject* ~src)) (res (make-GAsyncResult* ~res)) (err (make-GError*)) (rez (g_dbus_connection_call_finish conn res (pointer-to err))) ) (if (got-error? err) (sf "~A\n" (g-error-message err)) (check-rez rez)) (g_main_loop_quit loop) (if #f #f))))) (g_dbus_connection_call conn ; connection "org.freedesktop.DBus" ; bus name (was NULL) "/" ; object path "org.freedesktop.DBus.Introspectable" ; interface name "Introspect" ; method NULL ; parameters gv-string-singleton-type ; GVariantType* 'G_DBUS_CALL_FLAGS_NONE ; GDBusCallFlags 1000 ; timeout_msec NULL ; GCancellable* callback ; GAsyncReadyCallback NULL ; user_data ) (g_main_loop_run loop) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/ffi-help/libgit2-02.scm0000644000175100000240000000416613605250515022227 0ustar mwettedialout;; libgit2-demo2.scm - not working - libgit2 seems incomplete ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see (define repo-path "/home/mwette/repo/github.com/pycparser") (use-modules (ffi libgit2)) (use-modules (system ffi-help-rt)) (use-modules ((system foreign) #:prefix ffi:)) (define (sf fmt . args) (apply simple-format #t fmt args)) (git_libgit2_init) (define repo (make-git_repository*)) (let ((res (git_repository_open (pointer-to repo) repo-path))) (unless (zero? res) (error "repo_open failed"))) (if (zero? (git_repository_is_empty repo)) (display "The repo is not empty.\n") (display "The repo is empty.\n")) (define (demo1) (define (name-cb name payld) (sf "~S\n" (ffi:pointer->string name)) 1) ;; terminate on non-zero (define (ref-cb ref data) ;;(sf "ref-cb called w/ ~S\n" ref) (let* ((ref (make-git_reference* ref)) (name (make-char*)) (res (git_branch_name (pointer-to name) ref))) (sf "~S\n" (char*->string name)) 1)) (sf "repo=~S\n" repo) (git_reference_foreach_name repo name-cb repo) (git_reference_foreach repo ref-cb NULL) ) (define (demo2) (define walker (make-git_revwalk*)) (define oid (make-git_oid)) (define commit (make-git_commit*)) ;;(git_commit_id ;;(git_revwalk_next (pointer-to oid) walker) ;;(git_commit_lookup (pointer-to commit) repo oid) ;; ... ;;(git_commit_free commit) ;;(git_commit_lookup (pointer-to commit) repo ) ;;(demo1) (git_libgit2_shutdown) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/ffi-help/libelf-01.scm0000644000175100000240000000112313605250515022115 0ustar mwettedialout;; libelf-01.scm ;; https://bitbucket.org/developer2developer/elfcodegenerator/ ;; downloads/libelf-by-example.pdf (use-modules (ffi libelf)) (use-modules (system ffi-help-rt)) ;;(use-modules (bytestructures guile)) (use-modules ((system foreign) #:prefix ffi:)) (define (sf fmt . args) (apply simple-format #t fmt args)) (define go-port (open-input-file "/usr/local/lib/guile/2.2/ccache/texinfo.go")) (define go-fd (fileno go-port)) (define elf (elf_begin go-fd 'ELF_C_READ NULL)) (define kind (elf_kind elf)) (sf "kind = ~S\n" kind) (elf_end elf) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/ffi-help/gtk2-01.scm0000644000175100000240000000374713605250515021545 0ustar mwettedialout;; gtk2-01.scm ;; https://developer.gnome.org/gtk-tutorial/stable/c39.html#SEC-HELLOWORLD ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or modify it under ;; the terms of the GNU Lesser General Public License as published by the Free ;; Software Foundation; either version 3 of the License, or (at your option) any ;; later version. ;; ;; This library is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS ;; FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more ;; details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see . (use-modules (system ffi-help-rt)) (use-modules (bytestructures guile)) (use-modules (ffi glib)) ; ffi:31 scm:31889 (use-modules (ffi gobject)) ; ffi:26 scm:12044 (use-modules (ffi gtk2)) ; ffi:26 scm:92964 ;; This will generate a FFI code wrapper around the lambda. Then below ;; we use (fh-cast GCallback hello) to match the argument signature. (define hello (make-GtkCallback (lambda (widget data) (display "Hello world!\n")))) (define (delete-event widget event data) (display "delete event occurred\n") 1) (define (main) (define window #f) (define button #f) (define argc (bytestructure int 0)) (gtk_init (pointer-to argc) NULL) (set! window (gtk_window_new 'GTK_WINDOW_TOPLEVEL)) (g_signal_connect window "delete-event" delete-event NULL) (g_signal_connect window "destroy" ~gtk_main_quit NULL) (gtk_container_set_border_width window 10) (set! button (gtk_button_new_with_label "Hello World")) (g_signal_connect button "clicked" (fh-cast GCallback hello) NULL) (g_signal_connect_swapped button "clicked" ~gtk_widget_destroy window) (gtk_container_add window button) (gtk_widget_show button) (gtk_widget_show window) (gtk_main)) (main) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/ffi-help/cairo-01.scm0000644000175100000240000000135713605250515021766 0ustar mwettedialout;; nyacc/lang/ffi-help/cairo-01.scm - simple square ;; Copyright (C) 2017-2018 Matthew R. Wette ;; Copying and distribution of this file, with or without modification, ;; are permitted in any medium without royalty provided the copyright ;; notice and this notice are preserved. This file is offered as-is, ;; without any warranty. (use-modules (ffi cairo)) (define srf (cairo_image_surface_create 'CAIRO_FORMAT_ARGB32 200 200)) (define cr (cairo_create srf)) (cairo_move_to cr 10.0 10.0) (cairo_line_to cr 190.0 10.0) (cairo_line_to cr 190.0 190.0) (cairo_line_to cr 10.0 190.0) (cairo_line_to cr 10.0 10.0) (cairo_stroke cr) (cairo_surface_write_to_png srf "cairo-01.png") (cairo_destroy cr) (cairo_surface_destroy srf) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/ffi-help/cairo-02.scm0000644000175100000240000000233313605250515021762 0ustar mwettedialout;; cairo-02.scm - try key ;; Copyright (C) 2017 Matthew R. Wette ;; Copying and distribution of this file, with or without modification, ;; are permitted in any medium without royalty provided the copyright ;; notice and this notice are preserved. This file is offered as-is, ;; without any warranty. (use-modules (ffi cairo)) ; auto-generated from cairo.h etc (use-modules (system ffi-help-rt)) ; pointer-to (use-modules (system foreign)) ; pointer<->scm (define srf (cairo_image_surface_create 'CAIRO_FORMAT_ARGB32 200 200)) (define cr (cairo_create srf)) ;; typedef struct _cairo_user_data_key { ;; int unused; ;; } cairo_user_data_key_t; ;; ;; typedef void (*cairo_destroy_func_t)(void *data); ;; ;; cairo_status_t cairo_set_user_data(cairo_t *cr, const cairo_user_data_key_t ;; *key, void *user_data, cairo_destroy_func_t destroy); (define k1 (make-cairo_user_data_key_t)) ; make a key (define v1 '((abc . 123) (def . 456))) ; make some data (define (d1 data) ; callback (simple-format #t "d1 called with ~S\n" (pointer->scm data))) (cairo_set_user_data cr (pointer-to k1) (scm->pointer v1) d1) (cairo_surface_write_to_png srf "cairo-02.png") (cairo_destroy cr) (cairo_surface_destroy srf) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/ffi-help/cairo-04.scm0000644000175100000240000000267213605250515021772 0ustar mwettedialout;; cairo-04.scm - text demo from cairographics.org: ;; https://www.cairographics.org/samples/text_align_center/ ;; Copyright (C) 2017 Matthew R. Wette ;; ;; Copying and distribution of this file, with or without modification, ;; are permitted in any medium without royalty provided the copyright ;; notice and this notice are preserved. This file is offered as-is, ;; without any warranty. (use-modules (ffi cairo)) (use-modules (system ffi-help-rt)) (define srf (cairo_image_surface_create 'CAIRO_FORMAT_ARGB32 256 256)) (define cr (cairo_create srf)) (define extents (make-cairo_text_extents_t)) (define text "cairo") (cairo_select_font_face cr "Sans" 'CAIRO_FONT_SLANT_NORMAL 'CAIRO_FONT_WEIGHT_NORMAL) (cairo_set_font_size cr 52.0) (cairo_text_extents cr text (pointer-to extents)) (define x (- 128.0 (+ (/ (fh-object-ref extents 'width) 2.0) (fh-object-ref extents 'x_bearing)))) (define y (- 128.0 (+ (/ (fh-object-ref extents 'height) 2.0) (fh-object-ref extents 'y_bearing)))) (cairo_move_to cr x y) (cairo_show_text cr text) ;; draw helping lines (cairo_set_source_rgba cr 1 0.2 0.2 0.6) (cairo_set_line_width cr 6.0) (cairo_arc cr x y 10.0 0 (* 2 M_PI)) (cairo_fill cr) (cairo_move_to cr 128.0 0) (cairo_rel_line_to cr 0 256) (cairo_move_to cr 0 128.0) (cairo_rel_line_to cr 256 0) (cairo_stroke cr) (cairo_surface_write_to_png srf "cairo-04.png") (cairo_destroy cr) (cairo_surface_destroy srf) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/ffi-help/gdbus-00.scm0000644000175100000240000000254113605250515021770 0ustar mwettedialout;; dbus00.scm -- common items (use-modules (system ffi-help-rt)) (use-modules ((system foreign) #:prefix ffi:)) (use-modules (bytestructures guile)) (use-modules (ffi glib)) (use-modules (ffi gobject)) (use-modules (ffi gio)) (define (sf fmt . args) (apply simple-format #t fmt args)) (use-modules (ice-9 pretty-print)) (define pp pretty-print) (define FALSE 0) (define (got-error? error) (not (zero? (bytestructure-ref (fh-object-val error))))) (define (gv-null? error) (zero? (bytestructure-ref (fh-object-val error)))) (define (g-error-message error) (let* ((eval (fh-object-ref error '* 'message)) (pval (ffi:make-pointer eval)) (sval (ffi:pointer->string pval))) sval)) (define glib-guardian (make-guardian)) (define gv-string-singleton-type ; gen. variant type "(s)" (let* ((code "s") (cptr (ffi:string->pointer code)) ; GVariantType* for "s" (cadr (ffi:pointer-address cptr)) (cvec (bytestructure (bs:vector 1 (bs:pointer int8)) (vector cadr))) (cptr (ffi:make-pointer (bs-addr cvec))) (gvar (g_variant_type_new_tuple cptr 1))) (glib-guardian code) ; guard "s" from collection gvar)) ;; y uint8 ;; b bool ;; n int16 ;; q uint16 ;; i int32 ;; u uint32 ;; x int64 ;; t uint64 ;; d double ;; s utf-8 string ;; o Dbus object path ;; g Dbus sig string ;; a array ;; ( struct beg ;; ) struct end ;; v variant ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/ffi-help/clang-01.scm0000644000175100000240000000253013605250515021747 0ustar mwettedialout;; clang01.scm - NOT WORKING ;; http://bastian.rieck.ru/blog/posts/2015/baby_steps_libclang_ast/ ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see (use-modules (ffi clang)) (define file "clang-01a.cc") (define astf "clang-01a.ast") (with-output-to-file file (lambda () (display "int foo(int bar) { return 0; }\n") )) (system (string-append "/usr/lib/llvm-6.0/bin/clang++ -emit-ast " file)) (let* ((index (clang_createIndex 0 1)) (tunit (clang_createTranslationUnit index astf)) (tcurs (clang_getTranslationUnitCursor tunit)) ) (clang_disposeTranslationUnit tunit) (clang_disposeIndex index) #f) (system (string-append "rm -f " file " " astf)) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/ffi-help/ldemo.scm0000644000175100000240000000126413605250515021550 0ustar mwettedialout;; (use-modules (ffi lightning)) (use-modules (system ffi-help-rt)) (define _jit (make-jit_state_t*)) (init_jit "ldemo.scm") (fh-object-set! _jit '* (jit_new_state)) (define start (jit_note "ldemo.scm" 10)) (jit_prolog) (define in (jit_arg)) (jit_getarg JIT_R1 in) (jit_pushargi "generated %d bytes\n") ;; ??? (jit_ellipsis) (jit_pushargr JIT_R1) (jit_finishi (dynamic-func "printf" (dynamic-link))) (jit_ret) (jit_epilog) (define end (jit_note "ldemo.scm" 22)) (define myFunction (jit_emit)) ;; Call the generated code. ;;TODO: myFunction((char*)jit_address(end) - (char*)jit_address(start)); (jit_clear_state) (jit_disassemble) (jit_destroy_state) (finish_jit) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/ffi-help/dbus-01.scm0000644000175100000240000000541213605250515021622 0ustar mwettedialout;; dbus-01.scm - dbus ;; see http://www.matthew.ath.cx/misc/dbus ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see (use-modules (system dbus)) (use-modules (ffi dbus)) (use-modules (system ffi-help-rt)) (use-modules ((system foreign) #:prefix ffi:)) (use-modules (bytestructures guile)) (define (sf fmt . args) (apply simple-format #t fmt args)) (use-modules (ice-9 pretty-print)) (define pp pretty-print) (define (check-error error) (let ((err (dbus-error error))) (if err (sf "~A\n" err)))) ;; ==================================== (define error (make-DBusError)) (dbus_error_init (pointer-to error)) (define conn (dbus_bus_get 'DBUS_BUS_SESSION (pointer-to error))) (check-error error) (sf "conn: ~S = ~S\n" conn (ffi:pointer->string (dbus_bus_get_unique_name conn))) (define msg (dbus_message_new_method_call "org.freedesktop.DBus" ; bus name (was NULL) "/org/freedesktop/DBus" ; object path "org.freedesktop.DBus.Debug.Stats" ; interface name "GetStats")) ; method (define pending (make-DBusPendingCall*)) (or (dbus_connection_send_with_reply conn msg (pointer-to pending) -1) (error "*** send_with_reply FAILED\n")) (if (zero? (fh-object-ref pending)) (display "*** pending NULL\n")) (dbus_connection_flush conn) (dbus_message_unref msg) (dbus_pending_call_block pending) (set! msg (dbus_pending_call_steal_reply pending)) (if (zero? (fh-object-ref msg)) (error "*** reply message NULL\n")) (sf "msg reply: ~S, serial: ~S, type: ~A\n" msg (dbus_message_get_serial msg) (let ((msg-type (dbus_message_get_type msg))) (cond ((eq? (DBUS 'MESSAGE_TYPE_INVALID) msg-type) "invalid") ((eq? (DBUS 'MESSAGE_TYPE_METHOD_CALL) msg-type) "method call") ((eq? (DBUS 'MESSAGE_TYPE_METHOD_RETURN) msg-type) "method return") ((eq? (DBUS 'MESSAGE_TYPE_ERROR) msg-type) "error") ((eq? (DBUS 'MESSAGE_TYPE_SIGNAL) msg-type) "signal")))) (define &iter (make-DBusMessageIter&)) (dbus_pending_call_unref pending) (sf "iter_init => ~S\n" (dbus_message_iter_init msg &iter)) (sf "result:\n") (pp (read-dbus-val &iter) #:per-line-prefix " ") (dbus_message_unref msg) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/ffi-help/cairo-03.scm0000644000175100000240000000155213605250515021765 0ustar mwettedialout;; cairo-03.scm -- cairo matrix ;; Copyright (C) 2017 Matthew R. Wette ;; ;; Copying and distribution of this file, with or without modification, ;; are permitted in any medium without royalty provided the copyright ;; notice and this notice are preserved. This file is offered as-is, ;; without any warranty. (use-modules (ffi cairo)) ; auto-generated from cairo.h etc (use-modules (system ffi-help-rt)) ; pointer-to (define srf (cairo_image_surface_create 'CAIRO_FORMAT_ARGB32 120 120)) (define cr (cairo_create srf)) (define mx (make-cairo_matrix_t)) (cairo_matrix_init (pointer-to mx) 100 0 0 100 10 10) (cairo_set_matrix cr (pointer-to mx)) (cairo_set_line_width cr 0.02) (cairo_move_to cr 0.0 0.0) (cairo_line_to cr 1.0 1.0) (cairo_stroke cr) (cairo_surface_write_to_png srf "cairo-03.png") (cairo_destroy cr) (cairo_surface_destroy srf) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/ffi-help/libgit2-01.scm0000644000175100000240000000235313605250515022222 0ustar mwettedialout;; libgit2-demo1.scm ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see (define repo-path "/home/mwette/repo/github.com/pycparser") (use-modules (ffi libgit2)) (use-modules (system ffi-help-rt)) ;; Must initialize, then shutdown after use. (git_libgit2_init) (define repo (make-git_repository* 0)) (let ((res (git_repository_open (pointer-to repo) repo-path))) (unless (zero? res) (error "repo_open failed"))) (let ((res (git_repository_is_empty repo))) (if (zero? res) (display "repo is not empty.\n") (display "repo is empty.\n"))) (git_libgit2_shutdown) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/ffi-help/libssh-01.scm0000644000175100000240000000525213605250515022153 0ustar mwettedialout;; nyacc/lang/ffi-help/libssh-01.scm - not finished (i.e., not working) ;; Copyright (C) 2018 Matthew R. Wette ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see ;;; Notes: ;; see http://api.libssh.org/stable/libssh_tutorial.html ;; or http://api.libssh.org/stable/libssh_tutor_guided_tour.html ;; I have version 0.6.3, so the tutorial does not work as it is for v0.8.X. ;; (And why does Ubuntu not upgrade this for 16.04?) ;;; Code: (use-modules (ffi libssh)) (use-modules (system ffi-help-rt)) (use-modules (rnrs bytevectors)) (use-modules ((system foreign) #:prefix ffi:)) (define (sf fmt . args) (apply simple-format #t fmt args)) (define sess (ssh_new)) (define hash (make-char*)) (define hlen (make-size_t)) (define key (make-ssh_key)) (ssh_options_set sess 'SSH_OPTIONS_HOST "bluefin") ;;(ssh_options_set sess 'SSH_OPTIONS_USER "root") (define conn (ssh_connect sess)) (let* ((state (ssh_is_server_known sess)) (state (wrap-enum-ssh_server_known_e state)) (hlen (ssh_get_pubkey_hash sess (pointer-to hash)))) (if (negative? hlen) (error "no hash")) (sf "state=~S\n" state) (case state ((SSH_SERVER_KNOWN_OK) #t) ((SSH_SERVER_KNOWN_CHANGED) #t) ((SSH_SERVER_FOUND_OTHER) #t) ((SSH_SERVER_FILE_NOT_FOUND) #f) ((SSH_SERVER_NOT_KNOWN) #f) ((SSH_SERVER_ERROR) #f) (else (error "nope"))) ;;(free hash) #t) (define chan (ssh_channel_new sess)) (if (zero? (fh-object-ref chan)) (error "nope")) (sf "chan=~S\n" chan) ;; This hangs w/ v0.6.3, apparently due to bug: ;; https://www.libssh.org/archive/libssh/2014-11/0000010.html (define cmd "ps aux") (let ((rc (ssh_channel_request_exec chan cmd))) (sf "rc=~S\n" rc) #t) #;(let* ((buffer (make-bytevector 128)) (&buffer (ffi:bytevector->pointer buffer)) ) (let loop ((n (ssh_channel_read chan &buffer 128 0))) (when (positive? n) ;; write buffer (loop (ssh_channel_read chan &buffer 128 0)))) #f) (ssh_channel_close chan) (ssh_channel_free chan) (ssh_disconnect sess) (ssh_free sess) ;; (foo k) ;; (bar k) ;; (baz k) ;; (foo ((bar) z)) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/ffi-help/dbus-03.scm0000644000175100000240000001207213605250515021624 0ustar mwettedialout;; nyacc/lang/ffi-help/dbus-03.scm - peer-to-peer over the session bus ;; Copyright (C) 2018 Matthew R. Wette ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see ;;; Notes: ;; In two separate terminals execute: ;; --------------------------------- ;; $ guile dbus-03.scm worker ;; --------------------------------- ;; $ guile dbus-03.scm monitor ;;; Code: (add-to-load-path (getcwd)) (use-modules (dbus00)) (use-modules (ffi dbus)) (use-modules (system ffi-help-rt)) (use-modules ((system foreign) #:prefix ffi:)) (define (sf fmt . args) (apply simple-format #t fmt args)) (define iface "local.Neighbor") (define iface-pat "interface='local.Neighbor'") (define workers '()) (define monitors '()) (define (add-role role name) (cond ((string=? role "worker") (unless (member name workers) (set! workers (cons name workers)))) ((string=? role "monitor") (unless (member name monitors) (set! monitors (cons name monitors)))) (else (sf "*** unknown role: ~A\n" role)))) (define (send-ping conn role) (let* ((&role (pointer-to (make-char* role))) (sig (dbus_message_new_signal "/" iface "Ping")) (&iter (make-DBusMessageIter&)) (serial (make-uint32))) (sf "\nsending ping with ~S\n" role) (dbus_message_iter_init_append sig &iter) (dbus_message_iter_append_basic &iter (DBUS 'TYPE_STRING) &role) (dbus_connection_send conn sig (pointer-to serial)) serial)) (define (send-pong conn rem role) (let ((&role (pointer-to (make-char* role))) (loc (make-char* (dbus_bus_get_unique_name conn))) (rpl (dbus_message_new_method_call rem "/" iface "Pong")) (&iter (make-DBusMessageIter&)) (serial (make-uint32))) (sf "\nsending pong to ~S with ~S\n" rem role) (dbus_message_iter_init_append rpl &iter) (dbus_message_iter_append_basic &iter (DBUS 'TYPE_STRING) &role) (dbus_connection_send conn rpl (pointer-to serial)) serial)) (define (rply-pong conn msg) (let ((rpl (dbus_message_new_method_return msg)) (&iter (make-DBusMessageIter&)) (bval (make-uint32 (dbus-symval 'TRUE))) (serial (make-uint32))) (dbus_message_iter_init msg &iter) (sf "\nreply OK to pong from ~S, a ~S\n" (dbus-message-get-sender msg) (car (get-dbus-message-args msg))) (dbus_message_iter_init_append rpl &iter) (dbus_message_iter_append_basic &iter (DBUS 'TYPE_BOOLEAN) (pointer-to bval)) (dbus_connection_send conn rpl (pointer-to serial)) serial)) ;;; (define (send-update conn data) #f) (define conn #f) (define (p2s p) (if (zero? (ffi:pointer-address p)) "" (ffi:pointer->string p))) (define (show msg) (sf "\n got message ~S\n" msg) (sf " type = ~S\n" (dbus-message-type (dbus_message_get_type msg))) (sf " path = ~S\n" (p2s (dbus_message_get_path msg))) (sf " iface = ~S\n" (p2s (dbus_message_get_interface msg))) (sf " member = ~S\n" (p2s (dbus_message_get_member msg)))) ;; worker listens for ping, sends pong (define (run-peer role) (let ((error (make-DBusError))) (set! conn (dbus_bus_get 'DBUS_BUS_SESSION NULL)) (sf "\nbus=~S\n" (dbus-bus-get-unique-name conn)) (dbus_bus_add_match conn iface-pat NULL) (send-ping conn role) (let loop ((clk 0)) (dbus_connection_read_write conn 0) (let ((msg (dbus_connection_pop_message conn))) (unless (zero? (fh-object-ref msg)) (show msg) (cond ((= (dbus_message_get_type msg) (DBUS 'MESSAGE_TYPE_ERROR)) (dbus_set_error_from_message (pointer-to error) msg) (sf "error: ~S\n" (ffi:pointer->string (ffi:make-pointer (fh-object-ref error 'message)))) #f) ((and (!0 (dbus_message_has_member msg "Ping")) (not (string=? (dbus-bus-get-unique-name conn) (dbus-message-get-sender msg)))) (let ((r-name (dbus-message-get-sender msg)) (r-role (list-ref (get-dbus-message-args msg) 0))) (sf "\nping from ~S, a ~S\n" r-name r-role) (add-role r-role r-name) (send-pong conn r-name role))) ((!0 (dbus_message_has_member msg "Pong")) (let ((r-name (dbus-message-get-sender msg)) (l-name (dbus-bus-get-unique-name conn)) (r-role (list-ref (get-dbus-message-args msg) 0))) (unless (string=? r-name l-name) (add-role r-role r-name) (rply-pong conn msg)))) (else #t)) (sf "\n") (sf " workers : ~S\n" workers) (sf " monitors: ~S\n" monitors) (dbus_message_unref msg)) (sleep 1) (loop (1+ clk)))) #t)) (let ((args (cdr (program-arguments)))) (if (null? args) (run-peer "worker") (run-peer (car args)))) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/ffi-help/README0000644000175100000240000000233313605250515020622 0ustar mwettedialoutexamples/nyacc/lang/ffi-help/README Copyright (C) 2018 Matthew R. Wette Copying and distribution of this file, with or without modification, are permitted in any medium without royalty provided the copyright notice and this notice are preserved. This file is offered as-is, without any warranty. NOTES: To play with the ffi-helper you need scheme-bytestructures, from https://github.com/TaylanUB/scheme-bytestructures or ??? https://github.com/TaylanUB/scheme-bytestructures/releases Then go up three levels from here, in nyacc-0.00.0/examples and execute $ cd ../../.. $ . env.sh Then, in the same directory, execute $ guild compile-ffi ffi.d/cairo.ffi Now back in examples/nyacc/lang/ffi-help, execute $ guile cairo-01.scm $ guile cairo-02.scm $ guile cairo-03.scm $ guile cairo-04.scm The above should generate .png files. Look at the sources. For more fun, go back to examples and compile all the gtk stuff: $ guild compile-ffi ffi/glib.scm $ guild compile-ffi ffi/gio.scm $ guild compile-ffi ffi/gobject.scm $ guild compile-ffi ffi/pango.scm $ guild compile-ffi ffi/gdk2.scm $ guild compile-ffi ffi/gtk2.scm Then come back to examples/nyacc/lang/ffi-help and execute $ guile gtk-01.scm nyacc-1.00.2/examples/nyacc/lang/ffi-help/ffi/0000755000175100000240000000000013605250515020505 5ustar mwettedialoutnyacc-1.00.2/examples/nyacc/lang/ffi-help/ffi/hsearch-t.scm0000644000175100000240000000062513605250515023072 0ustar mwettedialout;; hsearch-t.scm - hsearch test (define-module (ffi hsearch-t) #:use-module (ffi hsearch-s) #:use-module (test-suite lib) #:use-module ((system foreign) #:prefix ffi:) ) (define (str->int8* str) (ffi:pointer-address (ffi:string->pointer str))) (pass-if "ffi/hsearch/01" (let* ((fd (hcreate 31)) (kv (make-ENTRY `((key ,(str->int8* "abc")) (data 0)))) ) #t)) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/ffi-help/ffi/hsearch-s.ffi0000644000175100000240000000017213605250515023050 0ustar mwettedialout;; hsearch-s.ffi -*- Scheme -*- (define-ffi-module (ffi hsearch-s) #:include '("search.h") ) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/ffi-help/fh-01.test0000644000175100000240000000376513605250515021470 0ustar mwettedialout;; nyacc/lang/c99/fh-01.test -*- scheme -*- ;; ;; Copyright (C) 2018 Matthew R. Wette ;; ;; Copying and distribution of this file, with or without modification, ;; are permitted in any medium without royalty provided the copyright ;; notice and this notice are preserved. This file is offered as-is, ;; without any warranty. (define-module (fh-01) #:use-module (nyacc lang c99 ffi-help) #:use-module (nyacc lang c99 munge) #:use-module (nyacc lang c99 parser) #:use-module (system ffi-help-rt) #:use-module ((system foreign) #:prefix ffi:) #:use-module ((srfi srfi-1) #:select (last drop-right)) #:use-module (test-suite lib)) (use-modules (ice-9 pretty-print)) (define (pp exp) (pretty-print exp #:per-line-prefix " ")) (define (sf fmt . args) (apply simple-format #t fmt args)) (define incs '("exam.d")) (define (parse-file file) (with-input-from-file file (lambda () (parse-c99 #:inc-dirs incs #:mode 'code)))) (define (parse-string str) (with-input-from-string str (lambda () (parse-c99 #:inc-dirs incs #:mode 'code)))) (define (parse-string-list . str-l) (parse-string (apply string-append str-l))) (define (string->udecl str) (let* ((tree (parse-string str)) (udict (c99-trans-unit->udict tree))) (and=> udict cdar))) ;; Scheme string -> expression, remove export ;; TODO: change define-public to define (define (fh-str->exp/nox str) (let ((exp (fh-scm-str->scm-exp str))) (if (not (eq? 'begin (car exp))) (error "expecting begin")) (if (eq? 'export (car (last exp))) (drop-right exp 1) exp))) (define fh-llibs '()) (define (nearly-equal? f1 f2) (< (abs (- f1 f2)) 0.0001)) ;; FFI Helper basic test (with-test-prefix "nyacc/ffi-help" ;;(add-to-load-path (getcwd)) (pass-if "C-fun->proc fmod" (let* ((expr (C-fun-decl->scm "double fmod(double x, double y);\n")) (fmod (eval expr (current-module)))) (nearly-equal? 0.3 (fmod 2.3 0.5)))) (compile-ffi-file "ffi/hsearch-s.ffi") (use-modules (ffi hsearch-t)) ) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/ffi-help/gdbus-01.scm0000644000175100000240000000552413605250515021775 0ustar mwettedialout;; dbus1.scm ;; https://askubuntu.com/questions/276392/d-bus-where-to-get-started ;; d-feet command on ubuntu (define (sf fmt . args) (apply simple-format #t fmt args)) (use-modules (system ffi-help-rt)) (use-modules ((system foreign) #:prefix ffi:)) (use-modules (bytestructures guile)) (use-modules (ffi glib)) (use-modules (ffi gobject)) (use-modules (ffi gio)) (define FALSE 0) ; should this go somewhere? (define (g-error-message error) (let* ((eval (fh-object-ref error '* 'message)) (pval (ffi:make-pointer eval)) (sval (ffi:pointer->string pval))) sval)) (define res #f) (define loop (g_main_loop_new NULL FALSE)) (g_type_init) (define error (make-GError*)) (define (got-error? error) (not (zero? (bytestructure-ref (fh-object-val error))))) (define conn (g_bus_get_sync 'G_BUS_TYPE_SESSION NULL (pointer-to error))) (define glib-guardian (make-guardian)) (define gv-string-singleton-type ; verified to work (let* ((code "s") (cptr (ffi:string->pointer code)) ; GVariantType* for string (cadr (ffi:pointer-address cptr)) (cvec (bytestructure (bs:vector 1 (bs:pointer int8)) (vector cadr))) (cptr (ffi:make-pointer (bs-addr cvec))) (gvar (g_variant_type_new_tuple cptr 1))) (glib-guardian code) ; guard "s" from collection gvar)) ;; verify gv-string-singleton-type => "(s)" ;;(sf "~S\n" (ffi:pointer->string ;; (g_variant_type_dup_string gv-string-singleton-type))) ;;(quit) (define (check-rez rez) ; rez: GVariant* (let* ((type (ffi:pointer->string (g_variant_get_type_string rez))) (elt0 (g_variant_get_child_value rez 0)) (strp (g_variant_get_string elt0 NULL)) (strv (ffi:pointer->string strp)) ) (sf "rez: ~S\n" rez) (sf " type: ~S\n" type) (sf " elt0: ~S\n" elt0) (sf " strv: ~S\n" strv) )) (define callback (make-GAsyncReadyCallback (lambda (~src ~res user_data) (let* ((src (make-GObject* ~src)) (res (make-GAsyncResult* ~res)) (err (make-GError*)) (rez (g_dbus_connection_call_finish conn res (pointer-to err))) ) (sf "src: ~S\n" src) ; GObject* (sf "res: ~S\n" res) ; GAsyncResult* (sf "err: ~S\n" err) ; GError* (if (got-error? err) (sf "~A\n" (g-error-message err)) (check-rez rez)) (g_main_loop_quit loop) (if #f #f))))) (define cancellable (g_cancellable_new)) (set! res (g_dbus_connection_call conn ; connection "com.dell.RecoveryMedia" ; bus name (was NULL) "/RecoveryMedia" ; object path "org.freedesktop.DBus.Introspectable" ; interface name "Introspect" ; method NULL ; parameters gv-string-singleton-type ; GVariantType* (should be "(s)") 'G_DBUS_CALL_FLAGS_NONE ; GDBusCallFlags 6000 ; timeout_msec cancellable ; GCancellable* callback ; GAsyncReadyCallback NULL ; user_data )) (g_main_loop_run loop) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/ffi-help/xlsxdemo.scm0000644000175100000240000000124413605250515022311 0ustar mwettedialout;; xlsxdemo.scm ;; https://github.com/jmcnamara/xlsxwriter/Readme.md (use-modules (ffi xlsxwriter)) (use-modules (system ffi-help-rt)) (define workbook (workbook_new "xlsxdemo.xlsx")) (define worksheet (workbook_add_worksheet workbook NULL)) (define format (workbook_add_format workbook)) (format_set_bold format) (worksheet_set_column worksheet 0 0 20 NULL) (worksheet_write_string worksheet 0 0 "Hello" NULL) (worksheet_write_string worksheet 1 0 "World" NULL) (worksheet_write_number worksheet 2 0 123 NULL) (worksheet_write_number worksheet 3 0 123.456 NULL) (worksheet_insert_image worksheet 1 2 "xlsxlogo.png") (workbook_close workbook) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/ffi-help/gdk2-01.scm0000644000175100000240000000177213605250515021521 0ustar mwettedialout;; gdk-ex1.scm ;; Copyright (C) 2018 Matthew R. Wette ;; Copying and distribution of this file, with or without modification, ;; are permitted in any medium without royalty provided the copyright ;; notice and this notice are preserved. This file is offered as-is, ;; without any warranty. (use-modules (ffi gdk2)) (use-modules (system ffi-help-rt)) ;; Initialize. (gdk_init NULL NULL) (define win (let ((attr (make-GdkWindowAttr))) (fh-object-set! attr 'event_mask (apply logior (map gdk-symval '(GDK_EXPOSE)))) (fh-object-set! attr 'width 400) (fh-object-set! attr 'height 300) (fh-object-set! attr 'wclass (gdk-symval 'GDK_INPUT_OUTPUT)) (fh-object-set! attr 'window_type (gdk-symval 'GDK_WINDOW_TOPLEVEL)) (gdk_window_new NULL (pointer-to attr) 0))) (simple-format #t "win=~S\n" win) (gdk_window_show win) (let loop ((n 0) (evt (gdk_event_get))) (when (< n 10) (simple-format #t "evt=~S\n" evt) (sleep 1) (loop (1+ n) (gdk_event_get)))) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/ffi-help/mkjit.scm0000644000175100000240000000654513605250515021575 0ustar mwettedialout;; mkjit.scm ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see ;; convert GNU lightning macros to Scheme functions ;; see output in exmamples/ffi/lightning.ffi (use-modules (nyacc lang c99 parser)) (use-modules (nyacc lang c99 munge)) (use-modules (nyacc lang c99 util)) (use-modules (nyacc lang util)) (use-modules (nyacc lang sx-match)) (use-modules (nyacc lex)) (use-modules (nyacc util)) (use-modules (srfi srfi-1)) (use-modules (ice-9 pretty-print)) (use-modules ((sxml xpath) #:select (sxpath))) (define (sferr fmt . args) (apply simple-format #t fmt args)) (define (pperr exp) (pretty-print exp #:per-line-prefix "")) (define cpp-defs (append '("__restrict=restrict") (get-gcc-cpp-defs))) (define inc-dirs (append '("/usr/include") (get-gcc-inc-dirs))) (define inc-help (cond ((string-contains %host-type "darwin") '(("__builtin" "__builtin_va_list=void*" "__attribute__(X)=" "__inline=" "__inline__=" "__asm(X)=" "__asm__(X)=" "__has_include(X)=__has_include__(X)" "__extension__=" "__signed=signed"))) (else '(("__builtin" "__builtin_va_list=void*" "__attribute__(X)=" "__inline=" "__inline__=" "__asm(X)=" "__asm__(X)=" "__has_include(X)=__has_include__(X)" "__extension__="))))) ;; for defining macros. Let's see how far we can go here ... (define (c99->scm expr) (sx-match expr ((fctn-call (p-expr (ident ,name)) (expr-list . ,args)) (cons (string->symbol name) (map c99->scm args))) ((p-expr (ident ,name)) (string->symbol name)) ((p-expr (fixed ,value)) (string->number (cnumstr->scm value))) ((and ,l ,r) `(and ,(c99->scm l) ,(c99->scm r))) ((le ,l ,r) `(<= ,(c99->scm l) ,(c99->scm r))) ((ge ,l ,r) `(>= ,(c99->scm l) ,(c99->scm r))) ((bitwise-and ,l ,r) `(logand ,(c99->scm l) ,(c99->scm r))) (* (sferr "can't handle this:\n") (pperr expr)))) (define (cnvt) (define (cnvt-cpp-ftn-def defn) (let* ((name (car defn)) (argl (cadr defn)) (repl (cddr defn)) (expr (parse-c99x repl)) (name (string->symbol name)) (argl (map string->symbol argl))) ;;(sferr "~S:\n" name) (pperr expr) (sferr "\n") (pperr `(define (,name ,@argl) ,(c99->scm expr))))) (define (inc-filter file-spec path-spec) (string-contains path-spec "lightning")) (let* ((tree (with-input-from-string "#include \n" (lambda () (parse-c99 #:cpp-defs cpp-defs #:inc-dirs inc-dirs #:inc-help inc-help #:mode 'decl)))) (ddict (c99-trans-unit->ddict tree #:inc-filter inc-filter))) (for-each (lambda (defn) (cond ((string=? (car defn) "offsetof") #f) ((pair? (cdr defn)) (cnvt-cpp-ftn-def defn)))) ddict))) (cnvt) ;; -- last line --- nyacc-1.00.2/examples/nyacc/lang/ffi-help/gtkgl-01.scm0000644000175100000240000001713113605250515021776 0ustar mwettedialout;; gtkgl-01.scm - works! ;; http://www.ccp4.ac.uk/dist/checkout/gtkglext-1.2.0/examples/simple.c ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see (use-modules (ffi gobject)) (use-modules (ffi gtk2)) (use-modules (ffi gtkglext1)) (use-modules (ffi glugl)) (use-modules (system ffi-help-rt)) (use-modules (bytestructures guile)) (define (sf fmt . args) (apply simple-format #t fmt args)) (define TRUE 1) (define FALSE 0) (display "Hey, why not add a user-defined unwrapper for GLenum.\n") (define make-dvec4 (let ((dvec4-desc (bs:vector 4 double))) (lambda (a b c d) (bytestructure dvec4-desc (vector a b c d))))) (define realize (let ((light-diffuse (make-dvec4 1.0 0.0 0.0 1.0)) (light-position (make-dvec4 1.0 1.0 1.0 0.0))) (make-GtkCallback (lambda(widget data) (let* ((widget (make-GtkWidget* widget)) (glcontext (gtk_widget_get_gl_context widget)) (gldrawable (gtk_widget_get_gl_drawable widget)) (qobj #f)) (unless (zero? (gdk_gl_drawable_gl_begin gldrawable glcontext)) (set! qobj (gluNewQuadric)) (gluQuadricDrawStyle qobj (glugl-symval 'GLU_FILL)) (glNewList 1 (glugl-symval 'GL_COMPILE)) (gluSphere qobj 1.0 20 20) (glEndList) (glLightfv (glugl-symval 'GL_LIGHT0) (glugl-symval 'GL_DIFFUSE) (pointer-to light-diffuse)) (glLightfv (glugl-symval 'GL_LIGHT0) (glugl-symval 'GL_POSITION) (pointer-to light-position)) (glEnable (glugl-symval 'GL_LIGHTING)) (glEnable (glugl-symval 'GL_LIGHT0)) (glEnable (glugl-symval 'GL_DEPTH_TEST)) (glClearColor 1.0 1.0 1.0 1.0) (glClearDepth 1.0) (glViewport 0 0 (fh-object-ref widget 'allocation 'width) (fh-object-ref widget 'allocation 'height)) (glMatrixMode (glugl-symval 'GL_PROJECTION)) (glLoadIdentity) (gluPerspective 40.0 1.0 1.0 10.0) (glMatrixMode (glugl-symval 'GL_MODELVIEW)) (glLoadIdentity) (gluLookAt 0.0 0.0 3.0 0.0 0.0 0.0 0.0 1.0 0.0) (glTranslatef 0.0 0.0 -3.0) (gdk_gl_drawable_gl_end gldrawable))))))) (define configure-event (make-GtkEventCallback (lambda (widget event data) (let ((widget (make-GtkWidget* widget)) (glcontext (gtk_widget_get_gl_context widget)) (gldrawable (gtk_widget_get_gl_drawable widget))) (cond ((zero? (gdk_gl_drawable_gl_begin gldrawable glcontext)) FALSE) (else (glViewport 0 0 (fh-object-ref widget 'allocation 'width) (fh-object-ref widget 'allocation 'height)) (gdk_gl_drawable_gl_end gldrawable) TRUE)))))) (define expose-event (let* ((m '(GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT)) (n (apply logior (map glugl-symval m)))) (make-GtkEventCallback (lambda (widget event data) (let ((glcontext (gtk_widget_get_gl_context widget)) (gldrawable (gtk_widget_get_gl_drawable widget))) (cond ((zero? (gdk_gl_drawable_gl_begin gldrawable glcontext)) FALSE) (else (glClear n) (glCallList 1) (if (!0 (gdk_gl_drawable_is_double_buffered gldrawable)) (gdk_gl_drawable_swap_buffers gldrawable) (glFlush)) (gdk_gl_drawable_gl_end gldrawable) TRUE))))))) (define (print-gl-config-attrib glconfig attrib is_boolean) (let ((attrib_str (symbol->string attrib)) (attr (gtkgl-symval attrib)) (value (make-int))) (sf "~A = " attrib_str) (if (!0 (gdk_gl_config_get_attrib glconfig attr (pointer-to value))) (if (!0 is_boolean) (sf "~A\n" (if (eqv? (fh-object-ref value) TRUE) "TRUE" "FALSE")) (sf "~A\n" (fh-object-ref value))) (sf "*** cannot get attributes\n")))) (define (examine_gl_config_attrib glconfig) (define (tf x) (if (zero? x) "FALSE" "TRUE")) (sf "\nOpenGL visual configurations :\n\n") (sf "gdk_gl_config_is_rgba (glconfig) = ~A\n" (tf (gdk_gl_config_is_rgba glconfig))) (sf "gdk_gl_config_is_double_buffered (glconfig) = ~A\n" (tf (gdk_gl_config_is_double_buffered glconfig))) (sf "gdk_gl_config_is_stereo (glconfig) = ~A\n" (tf (gdk_gl_config_is_stereo glconfig))) (sf "gdk_gl_config_has_alpha (glconfig) = ~A\n" (tf (gdk_gl_config_has_alpha glconfig))) (sf "gdk_gl_config_has_depth_buffer (glconfig) = ~A\n" (tf (gdk_gl_config_has_depth_buffer glconfig))) (sf "gdk_gl_config_has_stencil_buffer (glconfig) = ~A\n" (tf (gdk_gl_config_has_stencil_buffer glconfig))) (sf "gdk_gl_config_has_accum_buffer (glconfig) = ~A\n" (tf (gdk_gl_config_has_accum_buffer glconfig))) (sf "\n") (print-gl-config-attrib glconfig 'GDK_GL_USE_GL 1) (print-gl-config-attrib glconfig 'GDK_GL_BUFFER_SIZE 0) (print-gl-config-attrib glconfig 'GDK_GL_LEVEL 0) (print-gl-config-attrib glconfig 'GDK_GL_RGBA 1) (print-gl-config-attrib glconfig 'GDK_GL_DOUBLEBUFFER 1) (print-gl-config-attrib glconfig 'GDK_GL_STEREO 1) (print-gl-config-attrib glconfig 'GDK_GL_AUX_BUFFERS 0) (print-gl-config-attrib glconfig 'GDK_GL_RED_SIZE 0) (print-gl-config-attrib glconfig 'GDK_GL_GREEN_SIZE 0) (print-gl-config-attrib glconfig 'GDK_GL_BLUE_SIZE 0) (print-gl-config-attrib glconfig 'GDK_GL_ALPHA_SIZE 0) (print-gl-config-attrib glconfig 'GDK_GL_DEPTH_SIZE 0) (print-gl-config-attrib glconfig 'GDK_GL_STENCIL_SIZE 0) (print-gl-config-attrib glconfig 'GDK_GL_ACCUM_RED_SIZE 0) (print-gl-config-attrib glconfig 'GDK_GL_ACCUM_GREEN_SIZE 0) (print-gl-config-attrib glconfig 'GDK_GL_ACCUM_BLUE_SIZE 0) (print-gl-config-attrib glconfig 'GDK_GL_ACCUM_ALPHA_SIZE 0) ) ;; Initialize. (define argc (make-int 0)) (gtk_init (pointer-to argc) NULL) (gtk_gl_init (pointer-to argc) NULL) (let ((major (make-int)) (minor (make-int))) (gdk_gl_query_version (pointer-to major) (pointer-to minor)) (sf "\nOpenGL extension version - ~A.~A\n" (fh-object-ref major) (fh-object-ref minor))) ;; double-buffered visual (define glconfig (let* ((m '(GDK_GL_MODE_RGB GDK_GL_MODE_DEPTH GDK_GL_MODE_DOUBLE)) (n (apply logior (map gtkgl-symval m)))) (gdk_gl_config_new_by_mode n))) (examine_gl_config_attrib glconfig) (define window (gtk_window_new 'GTK_WINDOW_TOPLEVEL)) (gtk_window_set_title window "simple") (gtk_container_set_reallocate_redraws window TRUE) (g_signal_connect window "delete_event" ~gtk_main_quit NULL) (define vbox (gtk_vbox_new FALSE 0)) (gtk_container_add window vbox) (gtk_widget_show vbox) (define drawing-area (gtk_drawing_area_new)) (gtk_widget_set_size_request drawing-area 200 200) (gtk_widget_set_gl_capability drawing-area glconfig NULL TRUE (gtkgl-symval 'GDK_GL_RGBA_TYPE)) (g_signal_connect_after drawing-area "realize" (fh-cast GCallback realize) NULL) (g_signal_connect drawing-area "configure_event" (fh-cast GCallback configure-event) NULL) (g_signal_connect drawing-area "expose_event" (fh-cast GCallback expose-event) NULL) (gtk_box_pack_start vbox drawing-area TRUE TRUE 0) (gtk_widget_show drawing-area) (define button (gtk_button_new_with_label "Quit")) (g_signal_connect button "clicked" ~gtk_main_quit NULL) (gtk_box_pack_start vbox button FALSE FALSE 0) (gtk_widget_show button) (gtk_widget_show window) (gtk_main) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/ffi-help/gdk2-02.scm0000644000175100000240000001074013605250515021515 0ustar mwettedialout;; gdk2-ex02.scm ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see (use-modules (ffi gdk2)) (use-modules (system ffi-help-rt)) (use-modules ((system foreign) #:prefix ffi:)) (use-modules (bytestructures guile)) (define (sf fmt . args) (apply simple-format #t fmt args)) (gdk_init NULL NULL) (define win (let ((attr (make-GdkWindowAttr))) (fh-object-set! attr 'event_mask (apply logior (map gdk-symval '(GDK_EXPOSE)))) (fh-object-set! attr 'width 400) (fh-object-set! attr 'height 300) (fh-object-set! attr 'wclass (gdk-symval 'GDK_INPUT_OUTPUT)) (fh-object-set! attr 'window_type (gdk-symval 'GDK_WINDOW_TOPLEVEL)) (gdk_window_new NULL (pointer-to attr) 0))) (gdk_window_show win) (define (gdk-event-type evt) (if (zero? (fh-object-ref evt)) 'GDK_NOTHING (case (fh-object-ref evt '* 'type) ((0) 'GDK_DELETE) ((1) 'GDK_DESTROY) ((2) 'GDK_EXPOSE) ((3) 'GDK_MOTION_NOTIFY) ((4) 'GDK_BUTTON_PRESS) ((5) 'GDK_2BUTTON_PRESS) ((6) 'GDK_3BUTTON_PRESS) ((7) 'GDK_BUTTON_RELEASE) ((8) 'GDK_KEY_PRESS) ((9) 'GDK_KEY_RELEASE) ((10) 'GDK_ENTER_NOTIFY) ((11) 'GDK_LEAVE_NOTIFY) ((12) 'GDK_FOCUS_CHANGE) ((13) 'GDK_CONFIGURE) ((14) 'GDK_MAP) ((15) 'GDK_UNMAP) ((16) 'GDK_PROPERTY_NOTIFY) ((17) 'GDK_SELECTION_CLEAR) ((18) 'GDK_SELECTION_REQUEST) ((19) 'GDK_SELECTION_NOTIFY) ((20) 'GDK_PROXIMITY_IN) ((21) 'GDK_PROXIMITY_OUT) ((22) 'GDK_DRAG_ENTER) ((23) 'GDK_DRAG_LEAVE) ((24) 'GDK_DRAG_MOTION) ((25) 'GDK_DRAG_STATUS) ((26) 'GDK_DROP_START) ((27) 'GDK_DROP_FINISHED) ((28) 'GDK_CLIENT_EVENT) ((29) 'GDK_VISIBILITY_NOTIFY) ((30) 'GDK_NO_EXPOSE) ((31) 'GDK_SCROLL) ((32) 'GDK_WINDOW_STATE) ((33) 'GDK_SETTING) ((34) 'GDK_OWNER_CHANGE) ((35) 'GDK_GRAB_BROKEN) ((36) 'GDK_DAMAGE) (else (sf "unknown event: ~S\n" (fh-object-ref evt '* 'type)) 'UNKNOWN)))) (define (check1) (let* ((evt (make-GdkEventAny)) (p (pointer-to evt))) (let loop ((n 36)) (unless (negative? n) (fh-object-set! evt type n) (unless (= n (gdk-symval (gdk-event-type p) )) (simple-formt (current-error-port) "mismatch ~S\n" n) (loop (1- n))))))) ;; Any Expose NoExpose Visibility Motion Button Scroll Key Focus Crossing ;; Configure Property Selection OwnerChange Promimity Client DND WindowState ;; Setting GrabBroken (define (fork-event evt) (if (zero? (fh-object-ref evt)) #f (case (fh-object-ref evt '* 'type) ;;((0) (make-GdkEventDelete* (fh-object-ref evt))) ;;((1) (make-GdkEventDestroy* (fh-object-ref evt))) ((2) (make-GdkEventExpose* (fh-object-ref evt))) ((3) (make-GdkEventMotion* (fh-object-ref evt))) ((4 5 6 7) (make-GdkEventButton* (fh-object-ref evt))) ((8 9) (make-GdkEventKey* (fh-object-ref evt))) ((10 11) (make-GdkEventMotion* (fh-object-ref evt))) ((12) (make-GdkEventFocus* (fh-object-ref evt))) ((13) (make-GdkEventConfigure* (fh-object-ref evt))) ;;((14) (make-GdkEventMap* (fh-object-ref evt))) ;;((15) (make-GdkEventUnmap* (fh-object-ref evt))) ((16) (make-GdkEventProperty* (fh-object-ref evt))) ((17 18 19) (make-GdkEventSelectionClear* (fh-object-ref evt))) ((20 21) (make-GdkEventProximity* (fh-object-ref evt))) ((22 23 24 25 26 27) (make-GdkEventDND* (fh-object-ref evt))) ((28) (make-GdkEventClient* (fh-object-ref evt))) ((29) (make-GdkEventVisibility* (fh-object-ref evt))) ((30) (make-GdkEventNoExpose* (fh-object-ref evt))) ((31) (make-GdkEventScroll* (fh-object-ref evt))) ((32) (make-GdkEventWindowState* (fh-object-ref evt))) ((33) (make-GdkEventSetting* (fh-object-ref evt))) ((34) (make-GdkEventOwnerChange* (fh-object-ref evt))) ((35) (make-GdkEventGrabBroken* (fh-object-ref evt))) ;;((36) (make-GdkEventDamage* (fh-object-ref evt))) (else (sf "missed it\n") evt)))) (let loop ((n 0) (evt (gdk_event_get))) (when (< n 10) (simple-format #t "evt ~S is ~S\n" evt (gdk-event-type evt)) (sleep 1) (loop (1+ n) (gdk_event_get)))) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/ffi-help/pangocairo-01.scm0000644000175100000240000000552113605250515023010 0ustar mwettedialout;;; examples/nyacc/lang/ffi-help/pangocairo-01.scm - this works ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see ;;; Notes: ;; This demo is translated from the following: ;; https://developer.gnome.org/pango/stable/pango-Cairo-Rendering.html ;;; Code: (use-modules (ffi glib)) (use-modules (ffi gobject)) (use-modules (ffi cairo)) (use-modules (ffi pangocairo)) (use-modules (system ffi-help-rt)) (define PANGO_SCALE (ffi-pangocairo-symbol-val 'PANGO_SCALE)) (define RADIUS 150) (define N_WORDS 10) (define FONT "Sans Bold 27") (define (draw-text cr) (define layout #f) (define desc #f) (cairo_translate cr RADIUS RADIUS) (set! layout (pango_cairo_create_layout cr)) (pango_layout_set_text layout "Text" -1) (set! desc (pango_font_description_from_string FONT)) (pango_layout_set_font_description layout desc) (pango_font_description_free desc) (do ((i 0 (1+ i))) ((= i N_WORDS)) (let ((width (make-int)) (height (make-int)) (angle (/ (* 360.0 i) N_WORDS)) (red 0.0)) (cairo_save cr) (set! red (/ (1+ (cos (/ (* (- angle 60.0) G_PI) 180.0))) 2.0)) (cairo_set_source_rgb cr red 0.0 (- 1.0 red)) (cairo_rotate cr (/ (* angle G_PI) 180.0)) (pango_cairo_update_layout cr layout) (pango_layout_get_size layout (pointer-to width) (pointer-to height)) (cairo_move_to cr (- (/ (fh-object-ref width) PANGO_SCALE 2.0)) (- RADIUS)) (pango_cairo_show_layout cr layout) (cairo_restore cr))) (g_object_unref layout)) (define (main argv) (define filename #f) (define surface #f) (define cr #f) (define status #f) (if (= 2 (length argv)) (set! filename (list-ref argv 1)) (set! filename "pangocairo-01.png")) (set! surface (cairo_image_surface_create 'CAIRO_FORMAT_ARGB32 (* 2 RADIUS) (* 2 RADIUS))) (set! cr (cairo_create surface)) (cairo_set_source_rgb cr 1.0 1.0 1.0) (cairo_paint cr) (draw-text cr) (cairo_destroy cr) (set! status (cairo_surface_write_to_png surface filename)) (cairo_surface_destroy surface) (unless (eq? status 'CAIRO_STATUS_SUCCESS) (simple-format #t "Could not save png to ~S.\n" filename))) (let ((args (program-arguments))) (main args)) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/ffi-help/xlsxlogo.png0000644000175100000240000003120713605250515022331 0ustar mwettedialout‰PNG  IHDR›Š½ë8²gAMA± üa cHRMz&€„ú€èu0ê`:˜pœºQ< pHYs × ×B(›xËiTXtXML:com.adobe.xmp 1 www.inkscape.org ÔèË0&IDATxí} tÇyfõÝsƒk@‚xŸâ)J¢uR”(K²%9ŠOù%^;kÇöÆ9^g³»oßæÙÉÚq¼»Yk³±'q,K‰eÙ²hݧyH”(Qx `÷û{0À †" `.€hr0Ý=ÝÕU}ý_õ×_\ðê–»m> ý™ßæ)PF hcøO›èþÆÌCÓâq÷pþÏ<ÊE%dâjÅœHÍ<¢±ðºXàÚNšåzÎ|9W:€­ÄîóläÁ^&®PÀÙ :µÑ8€ÖÌ"ïëÇ+[ŽñÓ,ÿûäßòç ¯¦k&Ÿ/<7¹ŒÂ{+½_X¯rÖ£°ÜÂ6Lå…eLå¾Âç]l¿Üå_¨<|,W÷þ/¿ÉD%2vDõrE+n“¯nU…ÂB&Wþb¿][È%ItËÆ}´ïn—QFþÒ©~µãR7£týx½&]_XÖ¤ŸJß­ zéòÏÈço¾Ðqþ·‹õÁ»Ý÷®u+´è¾2ö[îXyØ·¨îtnl›xmÜ Ò!.¸Teów_ê{r9“/uÿL~Ÿê³.výÅ~›Jóåä¿ó÷^ê8ÝäïrÝ7¹ÜéO®ñ²‚s`›îæè}‚åpLȑDZx®€fc-¦3¯íØ'ØNž$³Æ÷óç®äïR°•RuŽÒÇbã‡H–Àñø ! ±™c[Lw Á°ÓÌ´5€‡cšC‚‚>*>8‘T_|ËLäy&£,Žð-Y/ (n³Pžµ‚c¼c¹H¶ñl7þÐ9Jæ‚f•‚^Ö9 8ŽQ'§’9ÎQàƒNÂIÃ,aô°ó4NG~…Ù$6Y^1 û¬èF¿3£B 刬Aðs XH ^Qµ<¢ÊT>@€ÎqÈ9Lô1À•‚m·Y÷‘,˜ßà2 –1û„³™3lÀ†mÚÿµ±u­wd›Z}º7¢j«èHÍ2SœÍùññp§pO4ËS‰d&Àâçè`”G°Óº­§ Þˆ¼>¢Ë™¡¸˜Šù£çO+ý±g”#IÆbv³Ð..eÍR€ù$â„8ç\»¥`Cá\ú’Äô®”1 §Ó½ì”¹Ù\çݑܺ¨y´m¹_÷¯—¨Liå™r ;(ˆ"ã äŸËÈ´HøÇý™~wÿC(ÓŽÉ1] áØ6³3¶¾ç’Ö¨ÝÀ´¡Û%­7­¤øΟ8ÖØÓÿ¤°?)B ¯c¹™5ʶÅñŽÞÜ3¥`›í³ *ˆJgqΰ0œÝ/ôéëÌ…ê­Ñë—FíWy3þ-’)-—x¹BU&ü8h¶‰»™mÛºé3.¸Æ° ‹t,ÚƾÆa‡3ø1÷ý عHu8žã%fóa™—Ê ,ܼ¶¬¯5Þ–X6°¢÷yûÛQÿÈ£GŽ=ëycÄ/ø¸å,¢z™}c1ˆøY,fI³ØJÁ–×̺=Ÿ%‰†Àì“ìtºGˆZwǶ´Þݱ±!Óx¬IENó".ààÂ6 ´;†EÀʃ‰ ¤ñ.`rìͥ˹Š¨‘NìÒ%€+α aØ0XI\ÉÉ¢(6ɼÚä5›CA­}´£g«zݾ³žÓ{÷·8úŠøZl [ìi²zyLAƒi #fo¥`›Åœ8õEp:EßüØðíÝ]rc@o¸AÔÅU’,CÊA;2 Æ æ¨Ûwš Õj~mŽ«–WH )ãYöVúý™÷´ÜsæÎ;B™Æ»$^]H º Fº:FT¨š×»¸`v¨ 8<8Q=ˆ®'øÿUjRY{ÛѦ;64lzä‰ÈÓ¿NŠÙÄJ¶Èo3æ¯a“nZ\býÍJ°‘¯ ÎS^GëúR²) pæã·µ%|Haž•Ð¾˜®eá“uelVtÏåºPÎàv4=kÂðýJ`ƒ2¬®} ùÁg7ý—h~ôð6¶Æ€‘e)¼IãLºÎv)¡Îª{¡ê(pŒ¦ÍxFØ`èÞå+G×|Dͨ;$Aæ #ëºþÁ/\Nv¡ûgÇ9àÎa", ˆØ ÌZ^ ØáÛV÷¯_ÿ§‰öýjñÓ?ïa½é¥V§Ï€X…7«¾¹œ«PÏâ7£zªpÊö gSÃlÈüâ‰ÏÞ»~`ÃWBfèv˜œ®eȪsp_õYÁÍ.I{ üN€JàhÙ´)8bkK²ý ÷¾ïK[†×/Ø%¼ã1,F²Z/Y^ /˜b”ˆ(ÃÒäá˜Ý%¼ÿØÖÈúþÍŸðÓä³Ù œ p­(ý5¤ieSDÒA9ç‚vèÖMg®^Úªµ~ó› ¾¿ç&¶ÁO4ªg=®î9 ž}ÅŸ~ÿüà}›¶žºîË vø½Žis†A– g‰^6c$æ¸Ëf2¦Ê{»º†—þ—/ö}úîçÙ±´Á,‹8ýp¸b^V×`#Ñ©ÀA›dqý ëÍþI︧{héõp¾eÐcL¸ Ðw.Œwä¬)–5^02 x‡ Fâøg'þÝG÷±ZZÈôrÖà&ˆZ·`#bІ„hÆÖlþwü3­±Èò6ß±iA!#±97ô²‰þ˜Ò±jXb“šR-¿óÇ=Ÿøí>h2¨/—kV]‚€æƒÅy†À‚t³ï}=÷þq“Ùúa „“Ø´1!矚RßÌÍ‹A Ë2lË°ø¦LËo}²çßz“Õ5Á0I‡«'Ww`›ÚÉäÆäÊð 'oýR ï0uÍÂ+ìÀ/[wu®5Š‰&¶mÚàr\C¦éãŸ?þÀ_dïd)dI†•š·äk]Ϻê8"JŽ£NnŠ­i¹öÔõ_ rÁmÐÏ,8ÏÈáYWõ­uç>?8zÁáRÍŸú“¾O¼÷yöF’"Ý(ä‹k´_?gYŒœµäC[Ÿ\¾æì{¾ècþ«³™ò£žó@»$F Rm 1R'µÄÚ>û¹3Ùú”p0îŒ^òæÊ_P`#Ñ©2¯Ð/œÏt¦#þkOmû#Ÿãs6²+Ú˜ 8qS£ v /ù½ ß؉(˜d= ¥`#oBU7ˈ ]69þú“7~ÎÏ‚ï!Ñ9´éubæDnŸèëZ7´á“~S•BZ÷¸!XUïàñF”‚mü§ÊïŽ&X2gc0æëÓî<~÷ǃvø ã.nTìêc·7há@ç@¬ ñÍëhÓÁÙÄ=˜Ë³Š"×Ùæ|úü=« '\q:qM¥÷Š£>j 6òtŽ%?uîkÚbí¿kS²Á:ou– Ðß•lÊ‚^4´ì­É“€º"aRM™ž0¥bjòPª!…pÇ„¨¶&ÝX|nù§e^i5 ®Äá§)õÙ/v¨%LÕ<7ÞÒ¿ýfˆÓ4Í™b!e¹¼&`£èµzÚ ·|ÀÇ6ëÙ,† æV–^-*„ââ lX8Ùtÿ’7F†`õÓË^íÑ…R°U<èÓWù½ìxò³gîÛäK?щés4ÜI!Ò³iƒJý2§cÖq½áñÕu î%ϲ5g×ß±Ÿõ锦¤ò!å5úÐÊMzëÃ×ïúˆ"©~Ë4€´º†"XQ¨9œ¦4™ÞÌJÅÌTÌù£7çéƒxnšüP_$îFubA£áöŽÞÚyZH‹–›ˆ¤‚oIM d>€¾@zÃõ½×ïPMÏ5˜+@sÛJ9lI0…¢Ñ=‘ÈhHV1¥YQÅãÕ#HØ—e5÷­Òy{^–LÏ€=šCàѤˆZo 1EˆÈŽÒ¹dxåöÃlY)uDÅEÙxË‹ùÜøéJìóVå„Áô}±›ÛaŽßƒ™èœi4³z-¾œ¦ÁHH!R’UàLÀ4S9‚sNãõó–cŒšÌHš¼™ÁÐ#rÃ8€"¯`Ú _⤑—Z8‹¨ªÃG˜Õn„;â„<:¸Vª"çs¸é 7ß?ºíÉC=çÚ­eiº²LýšbxQi$ *Òõè0$t9ÀÎïzßíxÖÁú$ Õ W#ÉGâЙ¢º“™uG;‘³¯Ç|ÑC1ßHï9i`dPMÆ”„ÇT:Ó܉ˆ 8v£éšõ°7’m ·&[ºBZx î-‹Ê"¨é‹Nu±VÀÖ ¹-ˆÒÒ‰U×<Üøü¿¶³u{e¶b1Z ¶Š-çêègC™Ž¾§p5ŽT€­6„/¥.å[°EY&nä¤ìÄë±ÆØ=¡·_É÷æР˜0#,,´3¿@þÁ–#³™È²³EÛ‰ŠñôQo_¢7ëi3ÅçoJ\óÈòÑU×’¡{TÅÓaè:]Y+_"æj96qj_"tóÍÚÚ§“J\C^©”JÁV!Îná¼ÍΘ÷Ü}£dËÝY?\â—0š!+‚ƲÇχ†ÚÝþÊ /(ûãW±åÊJÖ©®C\˜ËñAJ8«”Ž‹Îy-yØülëb¶hÚ‡ >Ôø‹}0~×KWõoü°×Þ…à3xmÔt„ ÀKœ¸vÃð¦Õ³àG»wZëÃ÷•ž X ¶²s¶œJ™„ÞŸ¼¶9Ýêò2WfÕ…õÈSJ@ Ƹá'Þê8ð? >zúvµo{OsH Àå²Oº»}(«dˆ£“-S;…ˆç@ðàÀ¯‚{ÿçgN~¬'kýŒ I^ {µõU`Ãh[‘=r8ÞÖÀø½b}Ý©€ãuϵ Ü«¢/ ‚ÌígGµU£k7KŽ¼Œ”íºàjš !±‹6ìúöWüð¯Þ >w»¶#°|R–¥-Ržáƒ.ád—ÓtååÈZY»‹uú6°¥êW»¿öð@èÔ×!ÍRк$Kª¶¹Šk&ÛLÖ”-·Åohdç5 1ƒ•vòVlÈ Å9Í4c [á ă7‹p€©k¬«AwÐ ý´ÁÀÙ¿ýËe~¿Il–ºØŸ¦dLCÈ–%†ë8¤R˜„‚ÙÆümlGÃÿèþú®¡Ð¹ªó¤@A{­ÚèA97¹ªm£kÞf½H§D믔{F}±à¬(ØHO£Ñ‚wØÉì¦ÍK‘Ov-åCCc«JÛ’‡ÁµAnü·‡}CßýZ÷7Ùζø½Ì#(r×_B^–zñÔ‘4Š8»‰Ýú«îïü"¡Æ%oyDªè‹ƒÑš’ úSÍͬUÈ2ÍÊëoÉô­(ØHáDT¼sÉOÚ’m[DdyDRThyìàL!mµXž_öœ üSñ dÈ"Àmª³Á„„§–#‹R º±³°¨ƒÊËÑ S ¶Â_gºz÷°A}ÅÐÒ.…ót’%·üL‹îý¤CEMËH÷ý¿_ ·XmJ!Z~}åⵤ,’ÛØZï+‘w§ÅÌY1I\ü®2þ UÌÔƒtxÞ‡"¦ËøUìÔ6üXF`“Îvi؛ҭk›o¦¹dz—·A—W1 Lj³EIbq1úÔ#?{m;[áGº©2ørê#@s³œ€å•÷ˆ'Ó#ÞsObÖ§ÚˆUän®%†ê5¼‹×™Í Yß•ÔÛ&íruy×P¥©òëÌvůV‚¡ÍU3Š rsˆºê‹ô>J Ò7RÚ/¯E彊æ_Ъ/”¤ùpë;¯œÖ#ÁXÀVµú€³ÙL²•Ž%©Î†YÌ®(-o[ó¥M[±©š¿h:ßTé–4VÄ—…e[é¦ìÙˆ€¨ WCý]Ó[œ/þ üLÏj«ÛK>°j‹Ï<-‰ÏRžß+(?îÝ7š’Ó¯º F5‡ï dh‰#HH‹¶°å"AÊ)ÙÈR¸M[±Œ-¼pÊûÇo³˜ÉFñ·1k5tyPX†Èë––j|ÚñN m¸tØiÊíœÑ ä‡$¥\d±àÈ ë§!JyˆRènd,ä?îËB/Ì%?(Œ¦¥¹Ÿüõùã¢o¤ÍÇ1¥Ð§(¼P0ãkº)S©AåR‹ñ4 lô 2mn}“N0ÓÐ…ŽöŒ >Sûª¿Á2d‰é²~`Oó¾c«ÙB-ßSé±ÀËi(‰Ò5¬Mì÷ž=e9æ°¬ª€†aáë…÷èCCjð "ß i¾”’¾‹?ˆ& ø@B› &pKÊ^ü!»ËÕPÔ‘mC½à¼†¯øJ Ë¨¸¡˜Ïü0Ó] ìÚ]f£è1½‹Ð¤üÇÒND…êoî2+zž Æ÷¼…|ÛÌ­œRýÊ? €»†X@ìõž‰n> `°€HEcÇôM¸ë—ÈGèr±àžw‹]s—å wˆq,¢9ÝO'é<ÝŽžäñû™¢';ÚL¿¤‹:æòÒ*‚îí¹‹Êô·"`#ã ͲF·µÈ_Û"’¨zŽ~eªøeƒwWe¬ék øOêB˜ù“°L]ld•J ʤèØÇ[|/þ x¢˜:02°6ÄÆÎ\?¸M20¡ÕgxD™À“ƒÜÀË\踙ø“»·‹C²@|ocÄ+Ýoò±ä‰raŽˆfLMyG°B€>¡2oØè°XÎNµGHB5eqssº£•3ù6s© _½©–9Ó뉳fùìÑ#ãg#X ¯ÒÎÓ©/ ëínÞ{ìm6rb XÈGPiîJ0àI9ɘ+Ÿ8OþÃèî5ô íÓ–ÿöóÝLž´Oåç‚>UGY–­fM""T\s˜î(Ï–n®´â£2< ª€s ÛŸilÄ;Úh#žLoÓï.Ãs.³W¿!¦šS=¯)'SÛ¬•Hå^wÇ¥êÜnµ{:ØBï¸×ÓÇw.UÄøï¤ÛåîºÔ½9ÐV&x²˜q•‚ê6“w%DáÌ ¾ð{OnÑ0”;¦/ŒS¤Ò;xeÖ¦Ù[©`↤lâ ì¥z Ò5»`ùôßfÐãe\ÞNUz¦"™,,†å­=¶¯!E®ã¬­l FL:Gd£1%z¦™…xš30¿U‹ż¬"`# ‹± q±‘LtHÏš(md” €#£Jt¸KgƒÓUå-®VwÖ÷sŠ_ìR°Íu“%Š±»+£#ÍBØeg9+¼&t!Oáè£ýÒ`>ÖS a~«JÁV†Zµ×ÈTà סCwÕ7<H§cÑÑyñZ"Ú[ü¶U½ZWðË 6Zû“"Ru'h…°\5ó‘ Ÿêëk„5Rñ|L&=.j&eξ‚ûºæM/?ñ!†)’"¤ûe¸=<ÕŒ,¤&€F0w}ɶdÇMXljŠéLÄìæ·P ü`C#HŒŠ:#^qÁVu¾–£$yÛ1ƒ!+MâS€£~~«*6 nLD†‚„,¦5܈³‘aT+ìç\3jû¡Ž]v°Qž\w¼ÏÆ49Œ÷ÞÕÔkÐhY˜“kíK`³”y·G ºaü‘“ÀVKÍÄÔ4Lü¥¾FlY„Õ7ò-t4Dm¢ó\-O”}OÛÌjA2‹|Æä¥ç-׬ySP“š×cf”wO[ñðÂT›XÂÁÜtdµ¢cµ§ IÈ@@øüVM ãiØf^‘œ ÆÂÆìÐñ™a5s7G@è …ìÌ‹Ò™÷ðôK(Û â!HŒRUDLl±(°ÂõtÕNg£9ßc °!á…ÜÌUM*3¿³l34$F±.²R# œGZ ˆÈû0™W÷òK[uÉ(&U´E?c>žòª!½ò¼þvùd,ë•¥`+Cñ4oðXˆ99Çq¸*o®a€ ðX5Œo\Èü"¸- ˜b=¢ÊÕºÂWìݨ؀ͲP’ƒ:›Ä«¾á¹ÄÛÈå%¼Pk(åÁLC«Þ†9öÀR°Í@gsiƒû)º"Ígu‡w2®×¡úŒ-×MXSž†ËÛØb´ù ¤…Êeê™c½XÏÍ)ÀS)Øf ³åÛ,›˜ð"'u$œ§I·Ä^j7š÷@©á‘h!N56öcN¾ŽóßU¢@žJÁ6£:`$”pL>çbbÜ´y;A¶ØK-)žKñ`okl4#gX)ok–bF” 7—l ئŒÔ¦GXÒBÐbÔµ ˆ½Õbƒ¾F3ñ^Tü™@7U¹K)D½n·Ú§„¨iJÁV c§óXÊ–¡*”;b™¢5B:,[-D©;Ù†æúz-ß’ Z»§é<§C7º‡¬xZOŠ¾ÝÏÜ4rpC¸r œagM·¢—}_±å_|”kñeõnæ¦óqŽ!e‡Í„;9\m˜šà‚îÝn«Èyòý‘ÞFYÊW¦—µ¼¡9ÛÁ<^ŠL©ÈgPhÖL[ºhÛ2&yËôä‘eé(97tŸ\fÈâJ¾M÷,°gaXn|Ra/¿ ÐÒ<Òâ;«T ¶Ö!/DL›KH©óMŽ­Á‡¯XXx§²”fwa0JвhafÑ’7¾Ð×ÁšgØÊòßN£Š¥Š2€‘4cP5ÎBAŽ»1w Ü–H"hÆÏù™Ì‡˜Â©¦‚o«9PvvÙåŒHQ °âb«<àËå–,ïÔ&†›rI á+®"/_±=Vv°¹Ý€7m! òqOt˜ Î(ròDh‰žš  žZdB•½|(Ñ°¹‰©/RR2’êA¹pLš&PÝÒw÷^Í·+`œ‡s)1,jŸ693ãðvÆýì´ÁY]05Sㆈu ÅlÖP²Z–é¸Ð0ÓBÊ2XÅmР@VMäœ(’c¹sfZŒ6•k€®„ XXñ3oݘ»¢ÜË6Êk‚åÏÙ/õô®7 ÈÁ|:Ô½¼ O%£Ô²‘Bݼ3uMÛ¾wÎÑaËÂX¨8/Òg4AHâ2BÒjAÕ¯¶4x«Òééoî}”eˆ>øþCû€ mÐRðÑÑ6J¥Ó>lþ,”† öN–Ì"ÏJ¢UCJI,Um¤-²š·2†heáwÔ0 _ôÊçR”-à"•ÆOÅð*>šFqº…Úîg>¡W8•2%ógrAˆê+lã•sW£c²$-ìì¾úŸ—<úoV›×¨ñœRdéå`Qcm|uÔ­¦d"d`Ë-‹‰×xÂ_›û¶º„„rÀc¡wŽ>î?ú ®·Åt†’|æÍ2²Ñ(g ¨”š Ó‘ÿ`el0Óÿw-Þû³›­UJæA©Ø(1Š«ê¸5Ò|²×g"×cŽ`h6Q¢êQÞDRB1n¸u»¶õ阒ÄjtªD3ÁòùIª]+uÀvÎjÉ4wI‚Ô@˯Bò‹ ÒÀЈpØ6î7|‹âó§Ýï±?c»GnATÔø\‚'ñ6'aB¼‰RÐdÉ» K›Á~±ÎVÊ6Ë¥È@ ˆÌÏE½Ñã¶m¥(×ØÍfPÿißjó´ü¢j«k7 nÞº›ÊÐâµZ¾”SDDŠ7\ &¹É‡&€† ‚Zòß@)©8¤\løРІQî“;Os® ’¡S ³©m:ÈPnMð‡^¯ßÉ7Óý.[ÑÏ38@õW³°tÖ{æ´%Ùg`­{gPì´o¥¤xŽmŠX¯9Õv÷ÚUÁ˜Ôhai—9ƒÉj—àââú]™Ma¯©^Eü«$B™®UŠêŽƒà$ñ €š[ÊÍëV̉fм ÞZJè2éË4lf>é-_Ϭ¥#äX­ƒMб’°Çðn¹nàÚ[v³73”ô±‰Pò›½ÎŽiKÎ-[+1u‘II®s€¨Z•Àå$ÞÉä’ V–»U ä·¡5šŽ‹çô¸)$uiqpöꆤ'ÝßÊþ⃷² Óèb-â ¯ÿ†±ú1QVCQJyimz•÷t®^ÿ1pžœ¨äµÏ;¤‹:¥Bäf8(œJßpöšÕÈÔ½Õ]j‰lDtUØð$R‘ šƒÏN‹‘ß7WòÑy†:X“º·åÓi.yˆüÛx—*`õL‘D@˜žÍ2OÆw燎Ý{ï‹ìå$ Q.àj¸zÉ‘«a™ìVæ•:â]wË¢‚Ân’²?Å–ÌèrJ}‡w*)¦c]pÂçGfTèEn®hãH”ú°âÝÖ§Çü±W,Ç"'$WãÈ ô*¬E°oL6ê÷z÷–§„ç¢9ëTÆë>6ÖxÂMÿ'Ä×Y²ðÛ—¼ëÌÎk}†ÿÓÐQ¸a«¸Áõ…H8~Œøˆd´‘yÇd^¹Ü¥©h©ÓèmÙÄ–+ÇÂGÀcÝë®ÏŸbiUª}RÃ2áü=ñî?øÜ™O]»Kxr„8éš•Ðá¨L/Æ?û„ÓÉ$o‹´ ·ÿ6â<è³°«ËÕ`Ÿ¸Ú¡Î´s'=ý‰+g0UldqÑ8d˜…ÕŸùŸJªñç]• g­Ú\\Å‚¾ÖÔ=¼üOÿÔço~JØ¥0$âÈÿr.4E‚«#+™‚¸éô–O«‚o¹®cDÉÍ[Õ—|!H‚â0Ãc‹ÔhÍÕÊ ÆO´«¢`Ë=¢c»XDì Ÿx ëG Á×o%EÕD/¹Àéºf‰œØ¼p¤ëϾÔóÙß<)ôë=B_Š¬TŸ%ÍH¼äÁ°|Ò€0’îgQûþ÷ÿ{Ÿ¼ÍÐiùIW‰­¨b~!::›”=n¶0† ]WÎsU›€ÅÈ-k [¨>~ádÆ“z†ÂiÎS92£²@xxÒ1Fô5'"¿ÿ™#Ÿø£kF×/Ø%¼í¢ixøÁ áëæò7ºž8…ý<)싶¤žO¾óÀ‚ÙÐo"]>FÓ5 íòK,Û•Xõs{mmx töĶ‹ÌTbw±“¸ØR¶¶”$YŽàTvw¦áìÞ·‡N=£IRôk„!>Nð ¢V_%‘™F\Ú ËZIÄ‘m0[Õ÷FoX±p´kG ¸]äåÝ@X“ÙW³FÓÓ­H“¯a'´nk›'‹uë+nU5°Y‚Ž´ *ßÅü‘¦w~¾yàêm°L;¡·­]Ü äã€ãWÃbe<¯Êê2%«. œi¸¹¼òÐmbêpJ‰÷ÆÔø`BJÄ >£i¼ªÁ<¶"ª¦×Ê647d»ýfp­¤ÉeAi¤He]Ï''Õ¥foéÊ’¤ÀpÓûOXʺ S)ý¹^ÅGDìŠm–ã2ìnñþ¨é‰“‹G»Ö’iÿÊ ïBnŠÈ˜]ïm]‘\A6BÇ#ê,;Ðêýï_Yüí.`íbˆù•z]y1Z3/Laµ ÷s:Y©}þÁøOVÿ䯇}CßBàb¾8Š5ƒíp o‘ cI‘Î|‚‹¿|0òÆú›Îzf»µÆ´¥B.#zu‡¢ {ìÝöK9[õÆeß­N~:ÈÙ†"i‹2~7³ûÁ·_ºU[ýÖÕg·ÞÒ˜ ¿_–Ôå°Xiâ1ê˜è<Š¤¥púÔåFCåH  ˆZ†aMAdf™º•áÓG†wíï{ñÉÀ‘ë­UþͬÉåf`u¬:ëøˆº!Ç‹ë²CŠ+•3(¯ÚNëªÐ°Õ¾¶øïú¾äu¯¬Zc ¼ë–"ÕƒL\ë0Xn®=šyBܹ-ÿ]\tõŽHÛ'þE•BP9\e¢DyÅ yé‰ ‹¾oŒ>µ¿éµ}OzßEd³²ƒmÙ‚áP"Áú™"Ú,£“›ãêqHË…DƒVƒ”wå3þ³ÑÇü/>¼3½õ™uC6‡R 7xï*$mÇüMp šªbÂKg™› :×å{¹P• ±­±Ç‘žO¤g¢V0nD¤B Š`8­ñ™S)1µ(0øÊ«-ûŽì¥¯f«”ÖÆ é@†rÃêh.e‹þ”r¶¢ŸgÏA~:…šïÂêˆw4õ®ï<‰4¢Ï_;´©³-Ö¾9€Iò .ålÖ+ÖaG™|l œ/·˜P@¹´IÞ¿¡=:p÷q û¹é$ý2¶]—?ÌÝ[€`‚2%vD¬wƒoB7Ò= ¤ÅÍòéÞ´”><ªŒ8ÙxâðÏü{Îû1Ër#[êÙi]¢™öùöÕµR=ÞþüN1¼Šò×Ìâï\§X,Àet”J)LÕòʉ3-‰c´*ßšøŠH›¶ ÛŸõ/õ˜Þ%‚-,*š!Äü"¦S تrØ"йpʃϥÏØ9ìÃÎe„±\ îeØ'ñíŠr«¬0s8ËÛý†¨õ¦<É“£¾ó='=½g8K2ݾŠµËdmSbBŠbž-Êÿå@fÎ-×hŠÎÚ–à ý»,¬µºý«ÀÒJÆÜÓòú©öä ?ž[§uyÚŒH°5¶lULµY±ä0V¤ià!ÀÛ¼Ú” °IøÆ’½Èâ˜wèêó9§8 EË÷ºv GKûhp:§lÞŠÙ¢58}$+iC9y~Ô:­œ=ªœL Â%‚å:X£´ÕZæE*!äu¦Y©ºCiPI•›]œì⛣`›ð7ѼHÒéˆ ÓÕmux»…7ˆ0«hÖqåäðsþQ(ã9¿Êu²&±Ù H>Ë‹åUQµeXÖ¸“8ûHü’½ˆ)¿±€ùˆô¶e`Þ¼®jzšOéq–2ãJÆ8ÄÎAKŽãù"þù¹¥¬A±€´YÖŽ¹evõˆò‹Ð UdÀ¸lòâ½7Ë~-Û¬±F§Né1à+X>/R`Q!ÇU ¦#}½!š¶&ÒÊvHÜN“Åã,d&‚ó÷ÓúvÅùåD¸ÅÜ|l´#2Ó~ØòŠÛ…U23¿Vèø30¤Î¸¾M÷}€¸·”§ÞÀº»cY£3¥­ >’»§1î}G²B"ë·ói]y`$ѱ”I³tù ÂBÿs‰õÂ(pV|àéX1¥nŽ‰Æ©ôÁ$΂ÍaÎvaÂV:>]Cà oʃáB`\‚N|У\N¤»Çù?¤·å÷é"lNçÊŸ-}Nþ—+å{ØÐl—WJó/ÞNiyrŒ#é]nÁïãF)Ýs©ëߥ˜9}º4ê#§:ÌéFÏ7®6˜àlã Éç·y ÌŒcúØ8® µ\àKp-2zÄgöÀ+íæjzW< O…j™×Sƒ,±û|H¼Ò 2ßÞ2S ŒpEø"œqÁ«[î"ô™‡4¦Åãe~Ú|qW:”`‰«×Ë‘“—àftBT"W:mæÛ_n P\瘴üÿêÒhcƒìËIEND®B`‚nyacc-1.00.2/examples/nyacc/lang/ecmascript/0000755000175100000240000000000013605250515020401 5ustar mwettedialoutnyacc-1.00.2/examples/nyacc/lang/ecmascript/parse.scm0000644000175100000240000004416313605250515022227 0ustar mwettedialout;;; ECMAScript for Guile ;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. ;;; Copyright (C) 2017 Matthew R. Wette ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Lesser General Public ;;; License as published by the Free Software Foundation; either ;;; version 3 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Lesser General Public License for more details. ;;; ;;; You should have received a copy of the GNU Lesser General Public License ;;; along with this library; if not, see ;;; Code: ;;(define-module (language ecmascript parse) (define-module (nyacc lang ecmascript parse) ;;#:use-module (system base lalr) #:use-module (nyacc lalr2) #:use-module (language ecmascript tokenize) #:export (read-ecmascript read-ecmascript/1 make-parser)) (define* (syntax-error message #:optional token) (if (lexical-token? token) (throw 'syntax-error #f message (and=> (lexical-token-source token) source-location->source-properties) (or (lexical-token-value token) (lexical-token-category token)) #f) (throw 'syntax-error #f message #f token #f))) (define (read-ecmascript port) (let ((parse (make-parser))) (parse (make-tokenizer port) syntax-error))) (define (read-ecmascript/1 port) (let ((parse (make-parser))) (parse (make-tokenizer/1 port) syntax-error))) (define *eof-object* (call-with-input-string "" read-char)) (define lbrace 'lbrace) (define rbrace 'rbrace) (define lparen 'lparen) (define rparen 'rparen) (define rbracket 'rbracket) (define dot 'dot) (define semicolon 'semicolon) (define comma 'comma) (define < '<) (define > '>) (define <= '<=) (define >= '>=) (define == '==) (define != '!=) (define + '+) (define - '-) (define * '* ) (define % '%) (define ++ '++) (define == '==) (define << '<<) (define >> '>>) (define >>> '>>>) (define & '&) (define bor 'bor ) (define ^ '^) (define ! '!) (define ~ '~) (define && '&&) (define or 'or) (define ? '?) (define colon 'colon) (define = '=) (define += '+=) (define -= '-=) (define *= '*=) (define %= '%=) (define <<= '<<=) (define >>= '>>=) (define >>>= '>>>=) (define &= '&=) (define bor= 'bor=) (define ^= '^=) (define / '/) (define /= '/=) (define break 'break) (define else 'else) (define new 'new ) (define var 'var) (define case 'case) (define finally 'finally) (define return 'return) (define void 'void) (define catch 'catch) (define for 'for) (define switch 'switch) (define while 'while) (define continue 'continue) (define function 'function) (define this 'this) (define with 'with ) (define default 'default) (define if 'if) (define throw 'throw) (define delete 'delete) (define in 'in) (define try 'try) (define do 'do) (define instanceof 'instanceof) (define typeof 'typeof) (define null 'null) (define true 'true) (define false 'false) (define Identifier 'Identifier) (define StringLiteral 'StringLiteral) (define NumericLiteral 'NumericLiteral) (define RegexpLiteral 'RegexpLiteral) (define (make-parser) ;; Return a fresh ECMAScript parser. Parsers produced by `lalr-scm' are now ;; stateful (e.g., they won't invoke the tokenizer any more once it has ;; returned `*eoi*'), hence the need to instantiate new parsers. (bison-parser ;; terminal (i.e. input) token types #;(lbrace rbrace lparen rparen lbracket rbracket dot semicolon comma < > <= >= == != === !== + - * % ++ -- << >> >>> & bor ^ ! ~ && or ? colon = += -= *= %= <<= >>= >>>= &= bor= ^= / /= break else new var case finally return void catch for switch while continue function this with default if throw delete in try do instanceof typeof null true false Identifier StringLiteral NumericLiteral RegexpLiteral) (start Program) (grammar (Program (SourceElements) (*eoi* ($$ *eof-object*))) ;; ;; Verily, here we define statements. Expressions are defined ;; afterwards. ;; (SourceElement (Statement) (FunctionDeclaration)) (FunctionDeclaration (function Identifier lparen rparen lbrace FunctionBody rbrace ($$ `(var (,$2 (lambda () ,$6))))) (function Identifier lparen FormalParameterList rparen lbrace FunctionBody rbrace ($$ `(var (,$2 (lambda ,$4 ,$7))))) ) (FunctionExpression (function lparen rparen lbrace FunctionBody rbrace ($$ `(lambda () ,$5))) (function Identifier lparen rparen lbrace FunctionBody rbrace ($$ `(lambda () ,$6))) (function lparen FormalParameterList rparen lbrace FunctionBody rbrace ($$ `(lambda ,$3 ,$6))) (function Identifier lparen FormalParameterList rparen lbrace FunctionBody rbrace ($$ `(lambda ,$4 ,$7))) ) (FormalParameterList (Identifier ($$ `(,$1))) (FormalParameterList comma Identifier ($$ `(,@$1 ,$3))) ) (SourceElements (SourceElement) (SourceElements SourceElement ($$ (if (and (pair? $1) (eq? (car $1) 'begin)) `(begin ,@(cdr $1) ,$2) `(begin ,$1 ,$2)))) ) (FunctionBody (SourceElements) ($empty ($$ '(begin))) ) (Statement (Block) (VariableStatement) (EmptyStatement) (ExpressionStatement) (IfStatement) (IterationStatement) (ContinueStatement) (BreakStatement) (ReturnStatement) (WithStatement) (LabelledStatement) (SwitchStatement) (ThrowStatement) (TryStatement) ) (Block (lbrace StatementList rbrace ($$ `(block ,$2)))) (StatementList (Statement) (StatementList Statement ($$ (if (and (pair? $1) (eq? (car $1) 'begin)) `(begin ,@(cdr $1) ,$2) `(begin ,$1 ,$2)))) ) (VariableStatement (var VariableDeclarationList ($$ `(var ,@$2)))) (VariableDeclarationList (VariableDeclaration ($$ `(,$1))) (VariableDeclarationList comma VariableDeclaration ($$ `(,@$1 ,$2)))) (VariableDeclarationListNoIn (VariableDeclarationNoIn ($$ `(,$1))) (VariableDeclarationListNoIn comma VariableDeclarationNoIn ($$ `(,@$1 ,$2)))) (VariableDeclaration (Identifier ($$ `(,$1))) (Identifier Initialiser ($$ `(,$1 ,$2)))) (VariableDeclarationNoIn (Identifier ($$ `(,$1))) (Identifier Initialiser ($$ `(,$1 ,$2)))) (Initialiser (= AssignmentExpression ($$ $2))) (InitialiserNoIn (= AssignmentExpressionNoIn ($$ $2))) (EmptyStatement (semicolon ($$ '(begin)))) (ExpressionStatement (Expression semicolon)) (IfStatement (if lparen Expression rparen Statement else Statement ($$ `(if ,$3 ,$5 ,$7))) (if lparen Expression rparen Statement ($$ `(if ,$3 ,$5))) ) (IterationStatement (do Statement while lparen Expression rparen semicolon ($$ `(do ,$2 ,$5))) (while lparen Expression rparen Statement ($$ `(while ,$3 ,$5))) (for lparen semicolon semicolon rparen Statement ($$ `(for #f #f #f ,$6))) (for lparen semicolon semicolon Expression rparen Statement ($$ `(for #f #f ,$5 ,$7))) (for lparen semicolon Expression semicolon rparen Statement ($$ `(for #f ,$4 #f ,$7))) (for lparen semicolon Expression semicolon Expression rparen Statement ($$ `(for #f ,$4 ,$6 ,$8))) (for lparen ExpressionNoIn semicolon semicolon rparen Statement ($$ `(for ,$3 #f #f ,$7))) (for lparen ExpressionNoIn semicolon semicolon Expression rparen Statement ($$ `(for ,$3 #f ,$6 ,$8))) (for lparen ExpressionNoIn semicolon Expression semicolon rparen Statement ($$ `(for ,$3 ,$5 #f ,$8))) (for lparen ExpressionNoIn semicolon Expression semicolon Expression rparen Statement ($$ `(for ,$3 ,$5 ,$7 ,$9))) (for lparen var VariableDeclarationListNoIn semicolon semicolon rparen Statement ($$ `(for (var ,@$4) #f #f ,$8))) (for lparen var VariableDeclarationListNoIn semicolon semicolon Expression rparen Statement ($$ `(for (var ,@$4) #f ,$7 ,$9))) (for lparen var VariableDeclarationListNoIn semicolon Expression semicolon rparen Statement ($$ `(for (var ,@$4) ,$6 #f ,$9))) (for lparen var VariableDeclarationListNoIn semicolon Expression semicolon Expression rparen Statement ($$ `(for (var ,@$4) ,$6 ,$8 ,$10))) (for lparen LeftHandSideExpression in Expression rparen Statement ($$ `(for-in ,$3 ,$5 ,$7))) (for lparen var VariableDeclarationNoIn in Expression rparen Statement ($$ `(begin (var ,$4) (for-in (ref ,@$4) ,$6 ,$8)))) ) (ContinueStatement (continue Identifier semicolon ($$ `(continue ,$2))) (continue semicolon ($$ `(continue)))) (BreakStatement (break Identifier semicolon ($$ `(break ,$2))) (break semicolon ($$ `(break)))) (ReturnStatement (return Expression semicolon ($$ `(return ,$2))) (return semicolon ($$ `(return)))) (WithStatement (with lparen Expression rparen Statement ($$ `(with ,$3 ,$5)))) (SwitchStatement (switch lparen Expression rparen CaseBlock ($$ `(switch ,$3 ,@$5)))) (CaseBlock (lbrace rbrace ($$ '())) (lbrace CaseClauses rbrace ($$ $2)) (lbrace CaseClauses DefaultClause rbrace ($$ `(,@$2 ,@$3))) (lbrace DefaultClause rbrace ($$ `(,$2))) (lbrace DefaultClause CaseClauses rbrace ($$ `(,@$2 ,@$3)))) (CaseClauses (CaseClause ($$ `(,$1))) (CaseClauses CaseClause ($$ `(,@$1 ,$2)))) (CaseClause (case Expression colon ($$ `(case ,$2))) (case Expression colon StatementList ($$ `(case ,$2 ,$4)))) (DefaultClause (default colon ($$ `(default))) (default colon StatementList ($$ `(default ,$3)))) (LabelledStatement (Identifier colon Statement ($$ `(label ,$1 ,$3)))) (ThrowStatement (throw Expression semicolon ($$ `(throw ,$2)))) (TryStatement (try Block Catch ($$ `(try ,$2 ,$3 #f))) (try Block Finally ($$ `(try ,$2 #f ,$3))) (try Block Catch Finally ($$ `(try ,$2 ,$3 ,$4))) (Catch (catch lparen Identifier rparen Block ($$ `(catch ,$3 ,$5)))) (Finally (finally Block ($$ `(finally ,$2)))) ) ;; ;; As promised, expressions. We build up to Expression bottom-up, so ;; as to get operator precedence right. ;; (PrimaryExpression (this ($$ 'this)) (null ($$ 'null)) (true ($$ 'true)) (false ($$ 'false)) (Identifier ($$ `(ref ,$1))) (StringLiteral ($$ `(string ,$1))) (RegexpLiteral ($$ `(regexp ,$1))) (NumericLiteral ($$ `(number ,$1))) (dot NumericLiteral ($$ `(number ,(string->number (string-append "." (number->string $2)))))) (ArrayLiteral ($$ $1)) (ObjectLiteral ($$ $1)) (lparen Expression rparen ($$ $2))) (ArrayLiteral (lbracket rbracket ($$ '(array))) (lbracket Elision rbracket ($$ '(array ,@$2))) (lbracket ElementList rbracket ($$ `(array ,@$2))) (lbracket ElementList comma rbracket ($$ `(array ,@$2))) (lbracket ElementList comma Elision rbracket ($$ `(array ,@$2)))) (ElementList (AssignmentExpression ($$ `(,$1))) (Elision AssignmentExpression ($$ `(,@$1 ,$2))) (ElementList comma AssignmentExpression ($$ `(,@$1 ,$3))) (ElementList comma Elision AssignmentExpression ($$ `(,@$1 ,@$3 ,$4)))) (Elision (comma ($$ '((number 0)))) (Elision comma ($$ `(,@$1 (number 0))))) (ObjectLiteral (lbrace rbrace ($$ `(object))) (lbrace PropertyNameAndValueList rbrace ($$ `(object ,@$2)))) (PropertyNameAndValueList (PropertyName colon AssignmentExpression ($$ `((,$1 ,$3)))) (PropertyNameAndValueList comma PropertyName colon AssignmentExpression ($$ `(,@$1 (,$3 ,$5))))) (PropertyName (Identifier ($$ $1)) (StringLiteral ($$ (string->symbol $1))) (NumericLiteral ($$ $1))) (MemberExpression (PrimaryExpression ($$ $1)) (FunctionExpression ($$ $1)) (MemberExpression lbracket Expression rbracket ($$ `(aref ,$1 ,$3))) (MemberExpression dot Identifier ($$ `(pref ,$1 ,$3))) (new MemberExpression Arguments ($$ `(new ,$2 ,$3)))) (NewExpression (MemberExpression ($$ $1)) (new NewExpression ($$ `(new ,$2 ())))) (CallExpression (MemberExpression Arguments ($$ `(call ,$1 ,$2))) (CallExpression Arguments ($$ `(call ,$1 ,$2))) (CallExpression lbracket Expression rbracket ($$ `(aref ,$1 ,$3))) (CallExpression dot Identifier ($$ `(pref ,$1 ,$3)))) (Arguments (lparen rparen ($$ '())) (lparen ArgumentList rparen ($$ $2))) (ArgumentList (AssignmentExpression ($$ `(,$1))) (ArgumentList comma AssignmentExpression ($$ `(,@$1 ,$3)))) (LeftHandSideExpression (NewExpression ($$ $1)) (CallExpression ($$ $1))) (PostfixExpression (LeftHandSideExpression ($$ $1)) (LeftHandSideExpression ++ ($$ `(postinc ,$1))) (LeftHandSideExpression -- ($$ `(postdec ,$1)))) (UnaryExpression (PostfixExpression ($$ $1)) (delete UnaryExpression ($$ `(delete ,$2))) (void UnaryExpression ($$ `(void ,$2))) (typeof UnaryExpression ($$ `(typeof ,$2))) (++ UnaryExpression ($$ `(preinc ,$2))) (-- UnaryExpression ($$ `(predec ,$2))) (+ UnaryExpression ($$ `(+ ,$2))) (- UnaryExpression ($$ `(- ,$2))) (~ UnaryExpression ($$ `(~ ,$2))) (! UnaryExpression ($$ `(! ,$2)))) (MultiplicativeExpression (UnaryExpression ($$ $1)) (MultiplicativeExpression * UnaryExpression ($$ `(* ,$1 ,$3))) (MultiplicativeExpression / UnaryExpression ($$ `(/ ,$1 ,$3))) (MultiplicativeExpression % UnaryExpression ($$ `(% ,$1 ,$3)))) (AdditiveExpression (MultiplicativeExpression ($$ $1)) (AdditiveExpression + MultiplicativeExpression ($$ `(+ ,$1 ,$3))) (AdditiveExpression - MultiplicativeExpression ($$ `(- ,$1 ,$3)))) (ShiftExpression (AdditiveExpression ($$ $1)) (ShiftExpression << MultiplicativeExpression ($$ `(<< ,$1 ,$3))) (ShiftExpression >> MultiplicativeExpression ($$ `(>> ,$1 ,$3))) (ShiftExpression >>> MultiplicativeExpression ($$ `(>>> ,$1 ,$3)))) (RelationalExpression (ShiftExpression ($$ $1)) (RelationalExpression < ShiftExpression ($$ `(< ,$1 ,$3))) (RelationalExpression > ShiftExpression ($$ `(> ,$1 ,$3))) (RelationalExpression <= ShiftExpression ($$ `(<= ,$1 ,$3))) (RelationalExpression >= ShiftExpression ($$ `(>= ,$1 ,$3))) (RelationalExpression instanceof ShiftExpression ($$ `(instanceof ,$1 ,$3))) (RelationalExpression in ShiftExpression ($$ `(in ,$1 ,$3)))) (RelationalExpressionNoIn (ShiftExpression ($$ $1)) (RelationalExpressionNoIn < ShiftExpression ($$ `(< ,$1 ,$3))) (RelationalExpressionNoIn > ShiftExpression ($$ `(> ,$1 ,$3))) (RelationalExpressionNoIn <= ShiftExpression ($$ `(<= ,$1 ,$3))) (RelationalExpressionNoIn >= ShiftExpression ($$ `(>= ,$1 ,$3))) (RelationalExpressionNoIn instanceof ShiftExpression ($$ `(instanceof ,$1 ,$3)))) (EqualityExpression (RelationalExpression ($$ $1)) (EqualityExpression == RelationalExpression ($$ `(== ,$1 ,$3))) (EqualityExpression != RelationalExpression ($$ `(!= ,$1 ,$3))) (EqualityExpression === RelationalExpression ($$ `(=== ,$1 ,$3))) (EqualityExpression !== RelationalExpression ($$ `(!== ,$1 ,$3)))) (EqualityExpressionNoIn (RelationalExpressionNoIn ($$ $1)) (EqualityExpressionNoIn == RelationalExpressionNoIn ($$ `(== ,$1 ,$3))) (EqualityExpressionNoIn != RelationalExpressionNoIn ($$ `(!= ,$1 ,$3))) (EqualityExpressionNoIn === RelationalExpressionNoIn ($$ `(=== ,$1 ,$3))) (EqualityExpressionNoIn !== RelationalExpressionNoIn ($$ `(!== ,$1 ,$3)))) (BitwiseANDExpression (EqualityExpression ($$ $1)) (BitwiseANDExpression & EqualityExpression ($$ `(& ,$1 ,$3)))) (BitwiseANDExpressionNoIn (EqualityExpressionNoIn ($$ $1)) (BitwiseANDExpressionNoIn & EqualityExpressionNoIn ($$ `(& ,$1 ,$3)))) (BitwiseXORExpression (BitwiseANDExpression ($$ $1)) (BitwiseXORExpression ^ BitwiseANDExpression ($$ `(^ ,$1 ,$3)))) (BitwiseXORExpressionNoIn (BitwiseANDExpressionNoIn ($$ $1)) (BitwiseXORExpressionNoIn ^ BitwiseANDExpressionNoIn ($$ `(^ ,$1 ,$3)))) (BitwiseORExpression (BitwiseXORExpression ($$ $1)) (BitwiseORExpression bor BitwiseXORExpression ($$ `(bor ,$1 ,$3)))) (BitwiseORExpressionNoIn (BitwiseXORExpressionNoIn ($$ $1)) (BitwiseORExpressionNoIn bor BitwiseXORExpressionNoIn ($$ `(bor ,$1 ,$3)))) (LogicalANDExpression (BitwiseORExpression ($$ $1)) (LogicalANDExpression && BitwiseORExpression ($$ `(and ,$1 ,$3)))) (LogicalANDExpressionNoIn (BitwiseORExpressionNoIn ($$ $1)) (LogicalANDExpressionNoIn && BitwiseORExpressionNoIn ($$ `(and ,$1 ,$3)))) (LogicalORExpression (LogicalANDExpression ($$ $1)) (LogicalORExpression or LogicalANDExpression ($$ `(or ,$1 ,$3)))) (LogicalORExpressionNoIn (LogicalANDExpressionNoIn ($$ $1)) (LogicalORExpressionNoIn or LogicalANDExpressionNoIn ($$ `(or ,$1 ,$3)))) (ConditionalExpression (LogicalORExpression ($$ $1)) (LogicalORExpression ? AssignmentExpression colon AssignmentExpression ($$ `(if ,$1 ,$3 ,$5)))) (ConditionalExpressionNoIn (LogicalORExpressionNoIn ($$ $1)) (LogicalORExpressionNoIn ? AssignmentExpressionNoIn colon AssignmentExpressionNoIn ($$ `(if ,$1 ,$3 ,$5)))) (AssignmentExpression (ConditionalExpression ($$ $1)) (LeftHandSideExpression AssignmentOperator AssignmentExpression ($$ `(,$2 ,$1 ,$3)))) (AssignmentExpressionNoIn (ConditionalExpressionNoIn ($$ $1)) (LeftHandSideExpression AssignmentOperator AssignmentExpressionNoIn ($$ `(,$2 ,$1 ,$3)))) (AssignmentOperator (= ($$ '=)) (*= ($$ '*=)) (/= ($$ '/=)) (%= ($$ '%=)) (+= ($$ '+=)) (-= ($$ '-=)) (<<= ($$ '<<=)) (>>= ($$ '>>=)) (>>>= ($$ '>>>=)) (&= ($$ '&=)) (^= ($$ '^=)) (bor= ($$ 'bor=))) (Expression (AssignmentExpression ($$ $1)) (Expression comma AssignmentExpression ($$ `(begin ,$1 ,$3)))) (ExpressionNoIn (AssignmentExpressionNoIn ($$ $1)) (ExpressionNoIn comma AssignmentExpressionNoIn ($$ `(begin ,$1 ,$3))))))) nyacc-1.00.2/examples/nyacc/lang/ecmascript/README0000644000175100000240000000046613605250515021267 0ustar mwettedialoutThis is my attempt to "fix" the builtin guile lalr parser module. Plan is to use my syntax but have an external bison executable convert the grammar to a parse machine. TODO: 1) add `token' expression to lalr2 2) ucase tokens: e.g., convert lparen to LPAREN See lalr2.scm and bison.scm in module/nyacc/. nyacc-1.00.2/examples/nyacc/lang/tcl/0000755000175100000240000000000013605250515017031 5ustar mwettedialoutnyacc-1.00.2/examples/nyacc/lang/tcl/mach.scm0000644000175100000240000001203013605250515020441 0ustar mwettedialout;;; lang/tcl/mach.scm ;;; ;;; Copyright (C) 2018 Matthew R. Wette ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Lesser General Public ;;; License as published by the Free Software Foundation; either ;;; version 3 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Lesser General Public License for more details. ;;; ;;; You should have received a copy of the GNU Lesser General Public License ;;; along with this library; if not, see . (define-module (nyacc lang tcl mach) #:export (tcl-expr-spec tcl-expr-mach gen-tcl-files) #:use-module (nyacc lalr) #:use-module (nyacc parse) #:use-module (nyacc lex) #:use-module (nyacc lang util) #:use-module ((srfi srfi-43) #:select (vector-map)) #:use-module (rnrs arithmetic bitwise) ) (define tcl-expr-spec (lalr-spec (notice (string-append "Copyright (C) 2018 Matthew R. Wette" license-lgpl3+)) ;;(expect 0) (start conditional-expression) (grammar (conditional-expression (logical-or-expression) (logical-or-expression "?" logical-or-expression ":" conditional-expression ($$ `(cond-expr ,$1 ,$3 ,$5)))) (logical-or-expression (logical-and-expression) (logical-or-expression "||" logical-and-expression ($$ `(or ,$1 ,$3)))) (logical-and-expression (bitwise-or-expression) (logical-and-expression "&&" bitwise-or-expression ($$ `(and ,$1 ,$3)))) (bitwise-or-expression (bitwise-xor-expression) (bitwise-or-expression "|" bitwise-xor-expression ($$ `(bitwise-or ,$1 ,$3)))) (bitwise-xor-expression (bitwise-and-expression) (bitwise-xor-expression "^" bitwise-and-expression ($$ `(bitwise-xor ,$1 ,$3)))) (bitwise-and-expression (equality-expression) (bitwise-and-expression "&" equality-expression ($$ `(bitwise-and ,$1 ,$3)))) (equality-expression (relational-expression) (equality-expression "==" relational-expression ($$ `(eq ,$1 ,$3))) (equality-expression "!=" relational-expression ($$ `(ne ,$1 ,$3)))) (relational-expression (shift-expression) (relational-expression "<" shift-expression ($$ `(lt ,$1 ,$3))) (relational-expression "<=" shift-expression ($$ `(le ,$1 ,$3))) (relational-expression ">" shift-expression ($$ `(gt ,$1 ,$3))) (relational-expression ">=" shift-expression ($$ `(ge ,$1 ,$3)))) (shift-expression (additive-expression) (shift-expression "<<" additive-expression ($$ `(lshift ,$1 ,$3))) (shift-expression ">>" additive-expression ($$ `(rshift ,$1 ,$3)))) (additive-expression (multiplicative-expression) (additive-expression "+" multiplicative-expression ($$ `(add ,$1 ,$3))) (additive-expression "-" multiplicative-expression ($$ `(sub ,$1 ,$3)))) (multiplicative-expression (unary-expression) (multiplicative-expression "*" unary-expression ($$ `(mul ,$1 ,$3))) (multiplicative-expression "/" unary-expression ($$ `(div ,$1 ,$3))) (multiplicative-expression "%" unary-expression ($$ `(mod ,$1 ,$3)))) (unary-expression (postfix-expression) ("-" unary-expression ($$ `(neg ,$2))) ("+" unary-expression ($$ `(pos ,$2))) ("!" unary-expression ($$ `(not ,$2))) ("~" unary-expression ($$ `(bitwise-not ,$2))) ("++" unary-expression ($$ `(pre-inc ,$2))) ("--" unary-expression ($$ `(pre-dec ,$2)))) (postfix-expression (primary-expression) (postfix-expression "++" ($$ `(post-inc ,$1))) (postfix-expression "--" ($$ `(post-dec ,$1)))) (primary-expression ($ident ($$ `(ident ,$1))) ($fixed ($$ `(fixed ,$1))) ; integer literal ($float ($$ `(float ,$1))) ; float literal ($chlit ($$ `(char ,$1))) ; char literal ;;($chlit/L ($$ `(char (@ (type "wchar_t")) ,$1))) ;;($chlit/u ($$ `(char (@ (type "char16_t")) ,$1))) ;;($chlit/U ($$ `(char (@ (type "char32_t")) ,$1))) ("(" expression-list ")" ($$ $2))) (expression-list (conditional-expression) (expression-list "," conditional-expression ($$ $3))) ))) (define tcl-expr-mach (compact-machine (hashify-machine (make-lalr-machine tcl-expr-spec)))) ;;; ===================================== ;; gen-tcl-files [dir] => #t (define (gen-tcl-files . rest) (define (lang-dir path) (if (pair? rest) (string-append (car rest) "/" path) path)) (define (xtra-dir path) (lang-dir (string-append "mach.d/" path))) (write-lalr-actions tcl-expr-mach (xtra-dir "expr-act.scm.new") #:prefix "tcl-expr-") (write-lalr-tables tcl-expr-mach (xtra-dir "expr-tab.scm.new") #:prefix "tcl-expr-") (let ((a (move-if-changed (xtra-dir "expr-act.scm.new") (xtra-dir "expr-act.scm"))) (b (move-if-changed (xtra-dir "expr-tab.scm.new") (xtra-dir "expr-tab.scm")))) (or a b))) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/tcl/compile-tree-il.scm0000644000175100000240000002663213605250515022535 0ustar mwettedialout;;; nyacc/lang/tcl/compile-tree-il.scm - compile tcl sxml to tree-il ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see ;;; Notes: ;; limitations: ;; 1) variables cannot be introduced by lhs expression: ;; i.e., a = 1 is OK, but a(1) = 1 is not ;;; Code: (define-module (nyacc lang tcl compile-tree-il) #:export (compile-tree-il show-tcl-sxml show-tcl-xtil) #:use-module (nyacc lang tcl xlib) #:use-module (nyacc lang nx-util) #:use-module (nyacc lang sx-util) #:use-module ((sxml fold) #:select (foldts*-values)) #:use-module ((srfi srfi-1) #:select (fold fold-right append-reverse)) #:use-module (language tree-il) #:use-module (ice-9 match) ;;#:use-module (system base compile) ) (use-modules (ice-9 pretty-print)) (define (sferr fmt . args) (apply simple-format (current-error-port) fmt args)) (define (pperr tree) (pretty-print tree (current-error-port) #:per-line-prefix " ")) (define xlib-mod '(nyacc lang tcl xlib)) (define xlib-module (resolve-module xlib-mod)) (define (xlib-ref name) `(@@ (nyacc lang tcl xlib) ,name)) ;; scope must be manipulated at execution time ;; the @code{proc} command should push-scope (define push-scope nx-push-scope) (define pop-scope nx-pop-scope) (define top-level? nx-top-level?) (define add-toplevel nx-add-toplevel) (define add-lexical nx-add-lexical) (define add-lexicals nx-add-lexicals) (define add-symbol nx-add-symbol) (define (lookup name dict) (or (nx-lookup name dict) (nx-lookup-in-env name xlib-module))) (define make-opcall (opcall-generator xlib-mod)) ;; @deffn {Procedure} make-arity args ;; This procedure generates a tree-il arity part of a lambda-case. ;; @end deffn (define (make-arity args) (let loop ((req '()) (opt '()) (rest #f) (inits '()) (gsyms '()) (args args)) (if (null? args) (list (reverse req) (reverse opt) rest #f (reverse inits) (reverse gsyms)) (let* ((arg (car args)) (lref (cadr arg)) (var (cadr lref)) (sym (caddr lref))) (case (car arg) ((arg) (loop (cons var req) opt rest inits (cons sym gsyms) (cdr args))) ((opt-arg) (loop req (cons var opt) rest (cons (caddr arg) inits) (cons sym gsyms) (cdr args))) ((rest) (loop req opt var inits (cons sym gsyms) (cdr args))) (else (error "coding error"))))))) (define (make-function name arity body) (let* ((meta '((language . nx-tcl))) (meta (if name (cons `(name . ,name) meta) meta))) `(lambda ,meta (lambda-case (,arity ,body))))) ;; @deffn {Procedure} sxml->xtil exp env opts ;; Compile SXML tree to external Tree-IL representation. ;; @end deffn (define-public (sxml->xtil exp env opts) (define (fD tree seed dict) ;; => tree seed dict (when #f (sferr "fD: ~S\n" tree) ) (sx-match tree ((string ,sval) (values '() `(const ,sval) dict)) ((fixed ,sval) (values '() `(const ,(string->number sval)) dict)) ((float ,sval) (values '() `(const ,(string->number sval)) dict)) ((deref ,name) (let ((ref (lookup name dict))) (unless ref (throw 'tcl-error "undefined variable: ~A" name)) (values '() ref dict))) ((deref ,name ,expr) (let ((ref (lookup name dict))) (unless ref (throw 'tcl-error "undefined variable: ~A" name)) ;;(values '() `(call ,(xlib-ref 'tcl:any->) ,ref ,expr) dict))) (values '() `(call ,(xlib-ref 'tcl:array-ref) ,ref ,expr) dict))) ;; convert (C) string to number (i.e., 0xf => 15) ((number (deref ,name)) (error "not implemented")) ((number (deref ,name) ,indx) (error "not implemented")) ((number ,arg) (error "not implemented")) ((integer (deref ,name)) (error "not implemented")) ((integer (deref ,name ,indx)) (error "not implemented")) ((integer ,arg) (error "not implemented")) ((list . ,items) ;; ??? (error "not implemented")) ((proc ,name (arg-list . ,args) ,body) ;; replace each name with (lexical name gsym) (let* ((dict (add-symbol name dict)) (nref (lookup name dict)) (dict (push-scope dict)) (dict (fold (lambda (a d) (add-lexical (cadr a) d)) dict args)) (args (fold-right ;; replace arg-name with lexical-ref (lambda (a l) (cons (cons* (car a) (lookup (cadr a) dict) (cddr a)) l)) '() args)) (dict (add-lexical "return" dict)) (dict (acons '@F name dict)) ) (values `(proc ,nref (arg-list . ,args) ,body) '() dict))) ((incr (string ,var) ,val) (values `(incr ,var ,val) '() dict)) ((incr (string ,var)) (values `(incr ,var (const 1)) '() dict)) ((set (string ,name) ,value) (let* ((dict (add-symbol name dict)) (nref (lookup name dict))) (values `(set ,nref ,value) '() dict))) ;;((set otherwise could be ugly ((set-indexed (string ,name) ,index ,value) (let* ((dict (add-symbol name dict)) (nref (lookup name dict))) (values `(set-indexed ,nref ,index ,value) '() dict))) ((command (string ,name) . ,args) (let ((ref (lookup name dict))) (unless ref (throw 'tcl-error "not defined")) (values `(command ,ref . ,args) '() dict))) ((command) (values '() '(void) dict)) (else (values tree '() dict)))) (define (fU tree seed dict kseed kdict) ;; => seed dict (when #f (sferr "fU: ~S\n" (if (pair? tree) (car tree) tree)) (sferr " kseed=~S\n seed=~S\n" kseed seed) ;;(pperr tree) ) ;; This routine rolls up processes leaves into the current branch. ;; We have to be careful about returning kdict vs dict. ;; Approach: always return kdict or (pop-scope kdict) (if (null? tree) (if (null? kseed) (values seed kdict) (values (cons kseed seed) kdict)) (case (car tree) ;; before leaving add a call to make sure all toplevels are defined ((*TOP*) (let ((tail (rtail kseed))) (cond ((null? tail) (values '(void) kdict)) ; just comments (else (values (car kseed) kdict))))) ((command) (values (cons `(call . ,(rtail kseed)) seed) kdict)) ((comment) (values seed kdict)) ((proc) (let* ((tail (rtail kseed)) (name-ref (list-ref tail 0)) (ptag (lookup "return" kdict)) (argl (list-ref tail 1)) (body (block (cdr (list-ref tail 2)))) (arity (make-arity (cdr argl))) ;; add lexicals : CLEAN THIS UP -- used in nx-octave also (lvars (let loop ((ldict kdict)) (if (eq? '@F (caar ldict)) '() (cons (cdar ldict) (loop (cdr ldict)))))) (body (let loop ((nl '()) (ll '()) (vl '()) (vs lvars)) (if (null? vs) `(let ,nl ,ll ,vl ,body) (loop (cons (list-ref (car vs) 1) nl) (cons (list-ref (car vs) 2) ll) (cons '(void) vl) (cdr vs))))) ;; (body (with-escape/arg ptag body)) (fctn (make-function (cadr name-ref) arity body)) (stmt (if (eq? 'toplevel (car name-ref)) `(define ,(cadr name-ref) ,fctn) `(set! ,name-ref ,fctn))) ;; never used methinks ) ;;(sferr "proc ~S:\n" name-ref) (pperr tail) (pperr fctn) (values (cons stmt seed) (pop-scope kdict)))) ;; others to add: incr foreach while continue break ((incr) (let* ((tail (rtail kseed)) (name (car tail)) (expr (cadr tail)) (vref (lookup (car tail) kdict)) (stmt `(set! ,vref (primcall + ,vref ,expr)))) (values (cons stmt seed) kdict))) ((format) (let* ((tail (rtail kseed)) (stmt `(call (@@ (nyacc lang nx-lib) sprintf) . ,tail)) ) (values (cons stmt seed) kdict))) ;; for allows continue and break ((for) (sferr "todo: for\n") (values (cons '(void) seed) kdict)) ;; conditional: elseif and else are translated by the default case ((if) (let* ((tail (rtail kseed)) (cond-expr `(primcall not (primcall zero? ,(list-ref tail 0)))) (then-expr (list-ref tail 1)) (rest-part (list-tail tail 2)) (rest-expr (let loop ((rest-part rest-part)) (match rest-part ('() '(void)) (`((else ,body)) (block body)) (`((elseif ,cond-part ,body-part) . ,rest) `(if (primcall not (primcall zero? ,cond-part)) ,body-part ,(loop (cdr rest-part))))))) (stmt `(if ,cond-expr ,then-expr ,rest-expr))) (values (cons stmt seed) kdict))) ((return) (values (cons `(abort ,(lookup "return" kdict) (,(if (> (length kseed) 1) (car kseed) '(void))) (const ())) seed) kdict)) ((set) (let* ((value (car kseed)) (nref (cadr kseed)) (toplev? (eq? (car nref) 'toplevel))) (values (cons (if toplev? `(define ,(cadr nref) ,value) `(set! ,nref ,value)) seed) kdict))) ((set-indexed) ;; This only works if the variable appeared as string constant in fD.? (let* ((value (car kseed)) (indx (cadr kseed)) (nref (caddr kseed)) (toplev? (eq? (car nref) 'toplevel))) (values (cons `(seq ,(if toplev? (make-defonce (cadr nref) `(call ,(xlib-ref 'tcl:make-array))) `(set! ,nref (if (call (toplevel hash-table?) ,nref) ,nref `(call ,(xlib-ref 'tcl:make-array))))) (call ,(xlib-ref 'tcl:array-set1) ,nref ,indx ,value)) seed) kdict))) ((body) (values (cons (block (rtail kseed)) seed) kdict)) ((void) (values (cons '(void) seed) kdict)) ((expr) ;;(sferr "expr: ~S\n" (reverse kseed)) (values (cons `(call ,(xlib-ref 'tcl:expr) . ,(rtail kseed)) seed) kdict)) ((word) (values (cons `(call ,(xlib-ref 'tcl:word) . ,(rtail kseed)) seed) kdict)) (else (cond ((null? seed) (values (reverse kseed) kdict)) (else (values (cons (reverse kseed) seed) kdict))))))) (define (fH leaf seed dict) (values (cons leaf seed) dict)) (catch 'tcl-error (lambda () (foldts*-values fD fU fH `(*TOP* ,exp) '() env)) (lambda (key fmt . args) (apply simple-format (current-error-port) (string-append "*** tcl: " fmt "\n") args) (values '(void) env)))) (define show-sxml #f) (define (show-tcl-sxml v) (set! show-sxml v)) (define show-xtil #f) (define (show-tcl-xtil v) (set! show-xtil v)) (define (compile-tree-il exp env opts) (when show-sxml (sferr "sxml:\n") (pperr exp)) ;; Need to make an interp. All Tcl commands execute in an interp ;; so need (interp-lookup at turntime) (let ((cenv (if (module? env) (cons* `(@top . #t) `(@M . ,env) xdict) env))) (if exp (call-with-values (lambda () (sxml->xtil exp cenv opts) ;;(values #f cenv) ) (lambda (exp cenv) (when show-xtil (sferr "tree-il:\n") (pperr exp)) (values (parse-tree-il exp) env cenv) ;;(values (parse-tree-il '(const "[hello]")) env cenv) ) ) (values (parse-tree-il '(void)) env cenv)))) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/tcl/exam.d/0000755000175100000240000000000013605250515020205 5ustar mwettedialoutnyacc-1.00.2/examples/nyacc/lang/tcl/exam.d/ex01.tcl0000644000175100000240000000001413605250515021461 0ustar mwettedialoutset a(x) b nyacc-1.00.2/examples/nyacc/lang/tcl/mach.d/0000755000175100000240000000000013605250515020163 5ustar mwettedialoutnyacc-1.00.2/examples/nyacc/lang/tcl/mach.d/expr-tab.scm0000644000175100000240000001715213605250515022417 0ustar mwettedialout;; mach.d/expr-tab.scm ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; See the file COPYING.LESSER included with the this distribution. (define tcl-expr-len-v #(1 1 5 1 3 1 3 1 3 1 3 1 3 1 3 3 1 3 3 3 3 1 3 3 1 3 3 1 3 3 3 1 2 2 2 2 2 2 1 2 2 1 1 1 1 3 1 3)) (define tcl-expr-pat-v #(((5 . 1) (6 . 2) (7 . 3) (8 . 4) (9 . 5) (37 . 6) (10 . 7) (11 . 8) (12 . 9) (13 . 10) (18 . 11) (17 . 12) (38 . 13) (39 . 14) (40 . 15) (41 . 16) (42 . 17) (43 . 18) (44 . 19) (45 . 20) (46 . 21) (47 . 22) (48 . 23) (49 . 24) (50 . 25)) ((5 . 1) (6 . 2) (7 . 3) (8 . 4) (9 . 5) (37 . 6) (10 . 7) (11 . 8) (12 . 9) (13 . 10) (18 . 11) (17 . 12) (38 . 13 ) (39 . 14) (40 . 15) (41 . 16) (42 . 17) (43 . 18) (44 . 19) (45 . 20) (46 . 21) (47 . 22) (48 . 23) (49 . 24) (50 . 53) (36 . 54)) ((1 . -44)) ((1 . -43)) ((1 . -42)) ((1 . -41)) ((1 . -38)) ((5 . 1) (6 . 2) (7 . 3) (8 . 4) (9 . 5) (37 . 6) (10 . 7) (11 . 8) (12 . 9) (13 . 10) (18 . 11) (17 . 12) (38 . 13) (39 . 52)) ((5 . 1) (6 . 2) (7 . 3) (8 . 4) (9 . 5) (37 . 6) (10 . 7) (11 . 8) (12 . 9) (13 . 10) (18 . 11) (17 . 12) (38 . 13 ) (39 . 51)) ((5 . 1) (6 . 2) (7 . 3) (8 . 4) (9 . 5) (37 . 6) (10 . 7) (11 . 8) (12 . 9) (13 . 10) (18 . 11) (17 . 12) (38 . 13) (39 . 50)) ((5 . 1) (6 . 2) (7 . 3) (8 . 4) (9 . 5) (37 . 6) (10 . 7) (11 . 8) (12 . 9) (13 . 10) (18 . 11) (17 . 12) (38 . 13) (39 . 49)) ((5 . 1) (6 . 2) (7 . 3) (8 . 4) (9 . 5) (37 . 6) (10 . 7) (11 . 8) (12 . 9) (13 . 10) (18 . 11) (17 . 12) (38 . 13) (39 . 48)) ((5 . 1) (6 . 2) (7 . 3) (8 . 4) (9 . 5) (37 . 6) (10 . 7) (11 . 8) (12 . 9) (13 . 10) (18 . 11) (17 . 12) (38 . 13) (39 . 47)) ((11 . 45) (10 . 46) (1 . -31)) ((1 . -27)) ((16 . 42) (15 . 43) (14 . 44) (1 . -24)) ((18 . 40) (17 . 41) (1 . -21)) ((20 . 38) (19 . 39) (1 . -16)) ((24 . 34) (23 . 35) (22 . 36) (21 . 37) (1 . -13)) ((26 . 32) (25 . 33) (1 . -11)) ((27 . 31) (1 . -9)) ((28 . 30) (1 . -7)) ((29 . 29) (1 . -5)) ((30 . 28) (1 . -3)) ((33 . 26) (31 . 27) (1 . -1)) ((35 . 0)) ((5 . 1) (6 . 2) (7 . 3) (8 . 4) (9 . 5) (37 . 6) (10 . 7) (11 . 8) (12 . 9) (13 . 10) (18 . 11) (17 . 12) (38 . 13 ) (39 . 14) (40 . 15) (41 . 16) (42 . 17) (43 . 18) (44 . 19) (45 . 20) (46 . 21) (47 . 22) (48 . 23) (49 . 75)) ((5 . 1) (6 . 2) (7 . 3) (8 . 4) (9 . 5) (37 . 6) (10 . 7) (11 . 8) (12 . 9) (13 . 10) (18 . 11) (17 . 12) (38 . 13) (39 . 14) (40 . 15) (41 . 16) (42 . 17) (43 . 18) (44 . 19) (45 . 20) (46 . 21) (47 . 22) (48 . 74)) ((5 . 1) (6 . 2) (7 . 3) (8 . 4) (9 . 5) (37 . 6) (10 . 7) (11 . 8) (12 . 9) (13 . 10) (18 . 11) (17 . 12) (38 . 13) (39 . 14) (40 . 15) (41 . 16) (42 . 17) (43 . 18) (44 . 19) (45 . 20) (46 . 21) (47 . 73)) ((5 . 1) (6 . 2) (7 . 3) (8 . 4) (9 . 5) (37 . 6) (10 . 7) (11 . 8) (12 . 9) (13 . 10) (18 . 11) (17 . 12) (38 . 13 ) (39 . 14) (40 . 15) (41 . 16) (42 . 17) (43 . 18) (44 . 19) (45 . 20) (46 . 72)) ((5 . 1) (6 . 2) (7 . 3) (8 . 4) (9 . 5) (37 . 6) (10 . 7) (11 . 8) (12 . 9) (13 . 10) (18 . 11) (17 . 12) (38 . 13) (39 . 14) (40 . 15) (41 . 16) (42 . 17) (43 . 18) (44 . 19) (45 . 71)) ((5 . 1) (6 . 2) (7 . 3) (8 . 4) (9 . 5) (37 . 6) (10 . 7) (11 . 8) (12 . 9) (13 . 10) (18 . 11) (17 . 12) (38 . 13) (39 . 14) (40 . 15) (41 . 16) (42 . 17) (43 . 18) (44 . 70)) ((5 . 1) (6 . 2) (7 . 3) (8 . 4) (9 . 5) (37 . 6) (10 . 7) (11 . 8) (12 . 9) (13 . 10) (18 . 11) (17 . 12) (38 . 13 ) (39 . 14) (40 . 15) (41 . 16) (42 . 17) (43 . 69)) ((5 . 1) (6 . 2) (7 . 3) (8 . 4) (9 . 5) (37 . 6) (10 . 7) (11 . 8) (12 . 9) (13 . 10) (18 . 11) (17 . 12) (38 . 13) (39 . 14) (40 . 15) (41 . 16) (42 . 17) (43 . 68)) ((5 . 1) (6 . 2) (7 . 3) (8 . 4) (9 . 5) (37 . 6) (10 . 7) (11 . 8) (12 . 9) (13 . 10) (18 . 11) (17 . 12) (38 . 13) (39 . 14) (40 . 15) (41 . 16) (42 . 67)) ((5 . 1) (6 . 2) (7 . 3) (8 . 4) (9 . 5) (37 . 6) (10 . 7) (11 . 8) (12 . 9) (13 . 10) (18 . 11) (17 . 12) (38 . 13 ) (39 . 14) (40 . 15) (41 . 16) (42 . 66)) ((5 . 1) (6 . 2) (7 . 3) (8 . 4) (9 . 5) (37 . 6) (10 . 7) (11 . 8) (12 . 9) (13 . 10) (18 . 11) (17 . 12) (38 . 13) (39 . 14) (40 . 15) (41 . 16) (42 . 65)) ((5 . 1) (6 . 2) (7 . 3) (8 . 4) (9 . 5) (37 . 6) (10 . 7) (11 . 8) (12 . 9) (13 . 10) (18 . 11) (17 . 12) (38 . 13) (39 . 14) (40 . 15) (41 . 16) (42 . 64)) ((5 . 1) (6 . 2) (7 . 3) (8 . 4) (9 . 5) (37 . 6) (10 . 7) (11 . 8) (12 . 9) (13 . 10) (18 . 11) (17 . 12) (38 . 13) (39 . 14) (40 . 15) (41 . 63)) ((5 . 1) (6 . 2) (7 . 3) (8 . 4) (9 . 5) (37 . 6) (10 . 7) (11 . 8) (12 . 9) (13 . 10) (18 . 11) (17 . 12) (38 . 13) (39 . 14) (40 . 15) (41 . 62)) ((5 . 1) (6 . 2) (7 . 3) (8 . 4) (9 . 5) (37 . 6) (10 . 7) (11 . 8) (12 . 9) (13 . 10) (18 . 11) (17 . 12) (38 . 13 ) (39 . 14) (40 . 61)) ((5 . 1) (6 . 2) (7 . 3) (8 . 4) (9 . 5) (37 . 6) (10 . 7) (11 . 8) (12 . 9) (13 . 10) (18 . 11) (17 . 12) (38 . 13) (39 . 14) (40 . 60)) ((5 . 1) (6 . 2) (7 . 3) (8 . 4) (9 . 5) (37 . 6) (10 . 7) (11 . 8) (12 . 9) (13 . 10) (18 . 11) (17 . 12) (38 . 13) (39 . 59)) ((5 . 1) (6 . 2) (7 . 3) (8 . 4) (9 . 5) (37 . 6) (10 . 7) (11 . 8) (12 . 9) (13 . 10) (18 . 11) (17 . 12) (38 . 13) (39 . 58)) ((5 . 1) (6 . 2) (7 . 3) (8 . 4) (9 . 5) (37 . 6) (10 . 7) (11 . 8) (12 . 9) (13 . 10) (18 . 11) (17 . 12) (38 . 13) (39 . 57)) ((1 . -39)) ((1 . -40)) ((1 . -32)) ((1 . -33)) ((1 . -34)) ((1 . -35)) ((1 . -36)) ((1 . -37)) ((1 . -46)) ((4 . 55) (3 . 56)) ((1 . -45)) ((5 . 1) (6 . 2) (7 . 3) (8 . 4) (9 . 5) (37 . 6) (10 . 7) (11 . 8) (12 . 9) (13 . 10) (18 . 11) (17 . 12) (38 . 13) (39 . 14) (40 . 15) (41 . 16) (42 . 17) (43 . 18) (44 . 19) (45 . 20) (46 . 21) (47 . 22) (48 . 23) (49 . 24) (50 . 77)) ((1 . -30)) ((1 . -29)) ((1 . -28)) ((16 . 42) (15 . 43) (14 . 44) (1 . -26)) ((16 . 42) (15 . 43) (14 . 44) (1 . -25)) ((18 . 40) (17 . 41) (1 . -23)) ((18 . 40) (17 . 41) (1 . -22)) ((20 . 38) (19 . 39) (1 . -20)) ((20 . 38) (19 . 39) (1 . -19)) ((20 . 38) (19 . 39) (1 . -18)) ((20 . 38) (19 . 39) (1 . -17)) ((24 . 34) (23 . 35) (22 . 36) (21 . 37) (1 . -15)) ((24 . 34) (23 . 35) (22 . 36) (21 . 37) (1 . -14)) ((26 . 32) (25 . 33) (1 . -12)) ((27 . 31) (1 . -10)) ((28 . 30) (1 . -8)) ((29 . 29) (1 . -6)) ((30 . 28) (1 . -4)) ((32 . 76) (31 . 27)) ((5 . 1) (6 . 2) (7 . 3) (8 . 4) (9 . 5) (37 . 6) (10 . 7) (11 . 8) (12 . 9) (13 . 10) (18 . 11) (17 . 12) (38 . 13) (39 . 14) (40 . 15) (41 . 16) (42 . 17) (43 . 18) (44 . 19) (45 . 20) (46 . 21) (47 . 22) (48 . 23) (49 . 24) (50 . 78)) ((1 . -47)) ((1 . -2)))) (define tcl-expr-rto-v #(#f 50 50 49 49 48 48 47 47 46 46 45 45 44 44 44 43 43 43 43 43 42 42 42 41 41 41 40 40 40 40 39 39 39 39 39 39 39 38 38 38 37 37 37 37 37 36 36)) (define tcl-expr-mtab '(($start . 50) ("," . 3) (")" . 4) ("(" . 5) ($chlit . 6) ($float . 7) ($fixed . 8) ($ident . 9) ("--" . 10) ("++" . 11) ("~" . 12) ("!" . 13) ("%" . 14) ("/" . 15) ("*" . 16) ("-" . 17) ("+" . 18) (">>" . 19) ("<<" . 20) (">=" . 21) (">" . 22) ("<=" . 23) ("<" . 24) ("!=" . 25) ("==" . 26) ("&" . 27) ("^" . 28) ("|" . 29) ("&&" . 30) ("||" . 31) (":" . 32) ("?" . 33) ($error . 2) ($end . 35))) (define tcl-expr-tables (list (cons 'len-v tcl-expr-len-v) (cons 'pat-v tcl-expr-pat-v) (cons 'rto-v tcl-expr-rto-v) (cons 'mtab tcl-expr-mtab))) ;;; end tables nyacc-1.00.2/examples/nyacc/lang/tcl/mach.d/expr-act.scm0000644000175100000240000001213713605250515022416 0ustar mwettedialout;; mach.d/expr-act.scm ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; See the file COPYING.LESSER included with the this distribution. (define tcl-expr-act-v (vector ;; $start => conditional-expression (lambda ($1 . $rest) $1) ;; conditional-expression => logical-or-expression (lambda ($1 . $rest) $1) ;; conditional-expression => logical-or-expression "?" logical-or-expres... (lambda ($5 $4 $3 $2 $1 . $rest) `(cond-expr ,$1 ,$3 ,$5)) ;; logical-or-expression => logical-and-expression (lambda ($1 . $rest) $1) ;; logical-or-expression => logical-or-expression "||" logical-and-expre... (lambda ($3 $2 $1 . $rest) `(or ,$1 ,$3)) ;; logical-and-expression => bitwise-or-expression (lambda ($1 . $rest) $1) ;; logical-and-expression => logical-and-expression "&&" bitwise-or-expr... (lambda ($3 $2 $1 . $rest) `(and ,$1 ,$3)) ;; bitwise-or-expression => bitwise-xor-expression (lambda ($1 . $rest) $1) ;; bitwise-or-expression => bitwise-or-expression "|" bitwise-xor-expres... (lambda ($3 $2 $1 . $rest) `(bitwise-or ,$1 ,$3)) ;; bitwise-xor-expression => bitwise-and-expression (lambda ($1 . $rest) $1) ;; bitwise-xor-expression => bitwise-xor-expression "^" bitwise-and-expr... (lambda ($3 $2 $1 . $rest) `(bitwise-xor ,$1 ,$3)) ;; bitwise-and-expression => equality-expression (lambda ($1 . $rest) $1) ;; bitwise-and-expression => bitwise-and-expression "&" equality-expression (lambda ($3 $2 $1 . $rest) `(bitwise-and ,$1 ,$3)) ;; equality-expression => relational-expression (lambda ($1 . $rest) $1) ;; equality-expression => equality-expression "==" relational-expression (lambda ($3 $2 $1 . $rest) `(eq ,$1 ,$3)) ;; equality-expression => equality-expression "!=" relational-expression (lambda ($3 $2 $1 . $rest) `(ne ,$1 ,$3)) ;; relational-expression => shift-expression (lambda ($1 . $rest) $1) ;; relational-expression => relational-expression "<" shift-expression (lambda ($3 $2 $1 . $rest) `(lt ,$1 ,$3)) ;; relational-expression => relational-expression "<=" shift-expression (lambda ($3 $2 $1 . $rest) `(le ,$1 ,$3)) ;; relational-expression => relational-expression ">" shift-expression (lambda ($3 $2 $1 . $rest) `(gt ,$1 ,$3)) ;; relational-expression => relational-expression ">=" shift-expression (lambda ($3 $2 $1 . $rest) `(ge ,$1 ,$3)) ;; shift-expression => additive-expression (lambda ($1 . $rest) $1) ;; shift-expression => shift-expression "<<" additive-expression (lambda ($3 $2 $1 . $rest) `(lshift ,$1 ,$3)) ;; shift-expression => shift-expression ">>" additive-expression (lambda ($3 $2 $1 . $rest) `(rshift ,$1 ,$3)) ;; additive-expression => multiplicative-expression (lambda ($1 . $rest) $1) ;; additive-expression => additive-expression "+" multiplicative-expression (lambda ($3 $2 $1 . $rest) `(add ,$1 ,$3)) ;; additive-expression => additive-expression "-" multiplicative-expression (lambda ($3 $2 $1 . $rest) `(sub ,$1 ,$3)) ;; multiplicative-expression => unary-expression (lambda ($1 . $rest) $1) ;; multiplicative-expression => multiplicative-expression "*" unary-expr... (lambda ($3 $2 $1 . $rest) `(mul ,$1 ,$3)) ;; multiplicative-expression => multiplicative-expression "/" unary-expr... (lambda ($3 $2 $1 . $rest) `(div ,$1 ,$3)) ;; multiplicative-expression => multiplicative-expression "%" unary-expr... (lambda ($3 $2 $1 . $rest) `(mod ,$1 ,$3)) ;; unary-expression => postfix-expression (lambda ($1 . $rest) $1) ;; unary-expression => "-" unary-expression (lambda ($2 $1 . $rest) `(neg ,$2)) ;; unary-expression => "+" unary-expression (lambda ($2 $1 . $rest) `(pos ,$2)) ;; unary-expression => "!" unary-expression (lambda ($2 $1 . $rest) `(not ,$2)) ;; unary-expression => "~" unary-expression (lambda ($2 $1 . $rest) `(bitwise-not ,$2)) ;; unary-expression => "++" unary-expression (lambda ($2 $1 . $rest) `(pre-inc ,$2)) ;; unary-expression => "--" unary-expression (lambda ($2 $1 . $rest) `(pre-dec ,$2)) ;; postfix-expression => primary-expression (lambda ($1 . $rest) $1) ;; postfix-expression => postfix-expression "++" (lambda ($2 $1 . $rest) `(post-inc ,$1)) ;; postfix-expression => postfix-expression "--" (lambda ($2 $1 . $rest) `(post-dec ,$1)) ;; primary-expression => '$ident (lambda ($1 . $rest) `(ident ,$1)) ;; primary-expression => '$fixed (lambda ($1 . $rest) `(fixed ,$1)) ;; primary-expression => '$float (lambda ($1 . $rest) `(float ,$1)) ;; primary-expression => '$chlit (lambda ($1 . $rest) `(char ,$1)) ;; primary-expression => "(" expression-list ")" (lambda ($3 $2 $1 . $rest) $2) ;; expression-list => conditional-expression (lambda ($1 . $rest) $1) ;; expression-list => expression-list "," conditional-expression (lambda ($3 $2 $1 . $rest) $3) )) ;;; end tables nyacc-1.00.2/examples/nyacc/lang/tcl/nxtcl0000755000175100000240000000207013605250515020106 0ustar mwettedialout#!/bin/sh # -*- scheme -*- exec guile $0 $* !# (use-modules (nyacc lang tcl parser)) (use-modules (srfi srfi-37)) (use-modules (ice-9 pretty-print)) (define (fail fmt . args) (apply simple-format (current-error-port) (string-append "nxtcl: " fmt "\n") args) (exit 1)) (define options (list)) (define (parse-args args) (args-fold args options (lambda (opt name arg seed) (fail "unrecognized option: ~S" name) (exit 1)) (lambda (file seed) (if (assq-ref 'file seed) (fail "only one inupt file can be specified")) (if (string-suffix? file ".tcl") (fail "expecting .tcl file")) (acons 'file file seed)) '())) (define (compile-nx-file . args) (let* ((options (parse-args args)) (file (assoc-ref options 'file))) (let* ((tree (call-with-input-file file (lambda (port) (read-tcl-file port (current-module)))))) (pretty-print tree) (display "--------------------------------------\n") (if #f #f)))) (apply compile-nx-file (cdr (program-arguments))) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/tcl/xlib.scm0000644000175100000240000001477413605250515020510 0ustar mwettedialout;;; nyacc/lang/tcl/xlib.scm ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see . ;;; Notes: ;; 1) expr needs exp (i.e., ** as in 2**4 => 16) ;;; Code: (define-module (nyacc lang tcl xlib) #:export (xdict xlib-ref tcl-eval) #:use-module (rnrs arithmetic bitwise) ) (use-modules (ice-9 pretty-print)) (define (sferr fmt . args) (apply simple-format (current-error-port) fmt args)) (define (pperr exp) (pretty-print exp (current-error-port))) ;; Evaluate expression (a string) (define* (tcl-eval expr #:optional (env (current-module))) #f ;;(eval-string expr #:lang 'nx-tcl) ) (define (xlib-ref name) `(@@ (nyacc lang tcl xlib) ,name)) ;; expr evaluator (use-modules (nyacc lalr)) (use-modules (nyacc lex)) (use-modules (nyacc parse)) (include-from-path "nyacc/lang/tcl/mach.d/expr-act.scm") (include-from-path "nyacc/lang/tcl/mach.d/expr-tab.scm") (define expr-lexr ((make-lexer-generator tcl-expr-mtab))) (define raw-parser (make-lalr-parser (list (cons 'act-v tcl-expr-act-v) (cons 'len-v tcl-expr-len-v) (cons 'pat-v tcl-expr-pat-v) (cons 'rto-v tcl-expr-rto-v) (cons 'mtab tcl-expr-mtab)))) (define (parse-expr-string str) (with-input-from-string str (lambda () (catch 'nyacc-error (lambda () (raw-parser expr-lexr #:debug #f)) (lambda (key fmt . args) (apply simple-format (current-error-port) fmt args)) #f)))) (define sx-ref list-ref) (define (eval-expr tree) (letrec ((tx (lambda (tr ix) (sx-ref tr ix))) (tx1 (lambda (tr) (sx-ref tr 1))) (ev (lambda (ex ix) (eval-expr (sx-ref ex ix)))) (ev1 (lambda (ex) (ev ex 1))) ; eval expr in arg 1 (ev2 (lambda (ex) (ev ex 2))) ; eval expr in arg 2 (ev3 (lambda (ex) (ev ex 3))) ; eval expr in arg 3 (eval-expr (lambda (tree) (case (car tree) ((fixed) (string->number (cnumstr->scm (tx1 tree)))) ((float) (string->number (cnumstr->scm (tx1 tree)))) ((string) (sx-ref tree 1)) ((ident) (sx-ref tree 1)) ((pre-inc post-inc) (1+ (ev1 tree))) ((pre-dec post-dec) (1- (ev1 tree))) ((pos) (ev1 tree)) ((neg) (- (ev1 tree))) ((not) (if (zero? (ev1 tree)) 1 0)) ((mul) (* (ev1 tree) (ev2 tree))) ((div) (/ (ev1 tree) (ev2 tree))) ((mod) (modulo (ev1 tree) (ev2 tree))) ((add) (+ (ev1 tree) (ev2 tree))) ((sub) (- (ev1 tree) (ev2 tree))) ((lshift) (bitwise-arithmetic-shift-left (ev1 tree) (ev2 tree))) ((rshift) (bitwise-arithmetic-shift-right (ev1 tree) (ev2 tree))) ((lt) (if (< (ev1 tree) (ev2 tree)) 1 0)) ((le) (if (<= (ev1 tree) (ev2 tree)) 1 0)) ((gt) (if (> (ev1 tree) (ev2 tree)) 1 0)) ((ge) (if (>= (ev1 tree) (ev2 tree)) 1 0)) ((eq) (if (= (ev1 tree) (ev2 tree)) 1 0)) ((ne) (if (= (ev1 tree) (ev2 tree)) 0 1)) ((bitwise-not) (lognot (ev1 tree))) ((bitwise-or) (logior (ev1 tree) (ev2 tree))) ((bitwise-xor) (logxor (ev1 tree) (ev2 tree))) ((bitwise-and) (logand (ev1 tree) (ev2 tree))) ((or) (if (and (zero? (ev1 tree)) (zero? (ev2 tree))) 0 1)) ((and) (if (or (zero? (ev1 tree)) (zero? (ev2 tree))) 0 1)) ((cond-expr) (if (zero? (ev1 tree)) (ev3 tree) (ev2 tree))) (else (error "incomplete expr implementation" tree)))))) (eval-expr tree))) (define-public (tcl:word . args) (apply string-append (map tcl:any->str args))) ;; @deffn {Procedure} tcl:expr frags ;; @var{frags} is a list of string fragments. We join, parse and execute. ;; @end deffn (define-public (tcl:expr . frags) (let* ((strs (map tcl:any->str frags)) (xarg (apply string-append strs)) (tree (parse-expr-string xarg)) (xval (eval-expr tree))) xval)) ;; @deffn {Procedure} tcl:list arg ... ;; This creates a tcl list. ;; @end deffn (define-public (tcl:list . args) args) ;; === (associative) arrays ;; arrays are what set abc(foo) mean ;; they are apparently ordered ;; @deffn {Procedure} tcl:make-array name ;; Make an array. In Tcl this actually takes an argument and would add ;; to the current scope. To do that this would need to look like ;; @example ;; (tcl:make-array dict name) ;; @end example ;; @end deffn (define-public (tcl:make-array) (make-hash-table)) ;; @deffn {Procedure} tcl:array-get name index ;; Get value from the array. What if not there? ;; The argument @var{index} will be converted to a symbol.@* ;; Note: What if it's an integer (e.g., @code{1}, or then @code{"1"}). ;; @end deffn (define-public (tcl:array-get name index) (let ((key (if (string? index) (string->symbol index) index))) (hashq-ref name key))) ;; @deffn {Procedure} tcl:array-set name index value ;; @end deffn (define-public (tcl:array-set1 name index value) (let ((key (if (string? index) (string->symbol index) index))) (hashq-set! name key value))) ;;(define-public (ztcl:array-set env name value) ;; (let ((key (if (string? index) (string->symbol index) index))) ;; (hashq-set! name key value))) ;; =================================== (define (tcl:list->string tcl-list) (map (lambda (elt) (let ((str (tcl:any->str elt))) (if (string-any #\space str) (string-append "{" str "}") str))) tcl-list)) ;; @deffn {Procedure} tcl:any->str [value] [index] ;; Convert value to string. ;; @end deffn (define-public tcl:any->str (case-lambda ((val) (cond ((string? val) val) ((number? val) (number->string val)) ((list? val) (tcl:list->string val)) ;;((vector? val) ... (else (simple-format #f "~A" val)))) ((val index) (error "indexed deref not implemented") ))) (define-public tcl:puts (case-lambda ((val) (display (tcl:any->str val)) (newline)) ((arg0 val) (if (string=? arg0 "-nonewline") (display val) (display val arg0))) ; broken need arg0 => port ((nnl chid val) (unless (string=? nnl "-nonewline") (throw 'tcl-error "puts: bad arg")) "(not implemented)" ))) ;; === xdict (define xdict `( ("puts" . ,(xlib-ref 'tcl:puts)) )) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/tcl/parser.scm0000644000175100000240000004347313605250515021044 0ustar mwettedialout;;; nyacc/lang/tcl/parser.scm - parse tcl code ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see . ;;; Notes: ;; TODO: be more agressive to parse 123 as fixed and 567.0 as float. ;; We can convert to string later. ;; args string => (arg-list (arg "abc") (opt-arg "def" "123") (rest "args")) ;; @table asis ;; @item @code{arg} @emph{var} ;; @item @code{opt-arg} @emph{var} @emph{val} ;; @item @code{rest "args"} ;; @end table ;;; Code: (define-module (nyacc lang tcl parser) #:export (read-command read-tcl-stmt read-tcl-file ;; debugging: split-body cnvt-tree cnvt-args splice-xtail tclme ) #:use-module ((nyacc lex) #:select (read-c-num cnumstr->scm)) #:use-module (nyacc lang sx-util) #:use-module (sxml match) #:use-module ((srfi srfi-1) #:select (fold-right)) #:use-module (ice-9 match) ) (use-modules (ice-9 pretty-print)) (define pp pretty-print) (define (sf fmt . args) (apply simple-format #t fmt args)) (define (db fmt . args) #f) (define (echo obj) (sf " ~S\n" obj) obj) (define (rls chl) (reverse-list->string chl)) ;; bug? No char for eof. Maybe use nul for that??? (define cs:ws (string->char-set " \t")) (define cs:nl (string->char-set "\n")) (define cs:nl+ws (string->char-set "\n" cs:ws)) ;; command terminator (define cs:ct (string->char-set "];\n")) (define cs:ct+ws (string->char-set "];\n" cs:ws)) ;; right square (define cs:rs (string->char-set "]")) (define cs:rs+ws (string->char-set "]" cs:ws)) ;; left paren (define cs:lparen (string->char-set "(")) ;; right paren (define cs:rparen (string->char-set ")")) ;; left curly brace (define cs:lcurly (string->char-set "{")) ;; right curly brace (define cs:rcurly (string->char-set "}")) ;; double quote (define cs:dquote (string->char-set "\"")) ;; variable terminator (define cs:vt (string->char-set "()+-*/%&|!^<>?" cs:ct+ws)) (define (report-error fmt . args) (let* ((port (current-input-port)) (fn (or (port-filename port) "(unknown)")) (ln (1+ (port-line port)))) (apply simple-format (current-error-port) fmt args)) (throw 'tcl-error)) (define (read-command port) ;; This is a bit of a hack job. (letrec ((error (lambda (fmt . args) (with-input-from-port port (lambda () (apply report-error port fmt args))))) (foldin (lambda (word word-list) (cons (if (and (pair? (cdr word)) (null? (cddr word))) (cadr word) word) word-list))) (skip-ws (lambda (port) (let loop ((ch (peek-char port))) (cond ((eof-object? ch) ch) ((char-set-contains? cs:ws ch) (read-char port) (loop (peek-char port))) (else ch))))) (read-cmmd (lambda (end-cs) (db "C: read-cmmd end-cs=~S\n" end-cs) (let loop ((wordl '()) (ch (skip-ws port))) (db "C: wordl=~S ch=~S\n" wordl ch) (cond ((eof-object? ch) (db "C: done\n") (if (pair? wordl) (cons 'command (reverse wordl)) ch)) ((char=? ch #\#) `(comment ,(reverse-list->string (let loop2 ((chl '()) (ch (read-char port))) (cond ((eof-object? ch) chl) ((char=? ch #\newline) (unread-char ch port) chl) (else (loop2 (cons ch chl) (read-char port)))))))) ((char-set-contains? end-cs ch) (db "C: done\n") (if (pair? wordl) `(command ,@(reverse wordl)) '(command (string "NOOP")))) ((char-set-contains? cs:ws ch) (read-char port) (loop wordl (peek-char port))) ((char=? #\" ch) (read-char port) (let ((word (read-word cs:dquote))) (db "C: \" .. word=~S lach=~S\n" word (peek-char port)) (read-char port) ;; " (db "C: \" .. word=~S lach=~S\n" word (peek-char port)) (loop (foldin word wordl) (peek-char port)))) ((char=? #\{ ch) (read-char port) ;; { (loop (cons (read-brace) wordl) (peek-char port))) ;;((eq? end-cs cs:nl) ((eq? end-cs cs:ct) ;;(let ((word (read-word cs:nl+ws))) (let ((word (read-word cs:ct+ws))) (loop (foldin word wordl) (peek-char port)))) ((eq? end-cs cs:rs) (let ((word (read-word cs:rs+ws))) (loop (foldin word wordl) (peek-char port)))) (else (error "coding error")))))) (read-word (lambda (end-cs) (let loop ((fragl '()) (frag (read-frag end-cs))) (db "W: fragl=~S frag=~S\n" fragl frag) (cond ((eq? frag end-cs) (db "W: done\n") (cons 'word (reverse fragl))) (else (loop (cons frag fragl) (read-frag end-cs))))))) (finish (lambda (tag chl ch) (db "F: finish ~S ~S ~S\n" tag chl ch) (unless (eof-object? ch) (unread-char ch port)) ;;(case tag ((string) (rls chl)) (else (list tag (rls chl)))))) (list tag (rls chl)))) (swallow (lambda (val) (db "swallow ") (read-char port) val)) (read-brace (lambda () (let loop ((chl '()) (bl 1) (ch (read-char port))) (db "B: ch=~S bl=~S chl=~S\n" ch bl chl) (cond ((eof-object? ch) (error "no end brace")) ((char=? ch #\}) (if (= 1 bl) (list 'string (rls chl)) (loop (cons ch chl) (1- bl) (read-char port)))) ((char=? ch #\{) (loop (cons ch chl) (1+ bl) (read-char port))) (else (loop (cons ch chl) bl (read-char port))))))) (read-index (lambda () ;;(if (not (char=? #\( (read-char port))) (error "coding error")) (if (char=? (peek-char port) #\() (read-char port)) (let ((word (read-word cs:rparen))) ;;(sf "index word=~S\n" word) (if (not (char=? #\) (read-char port))) (error "coding error")) `(index . ,(foldin word '()))))) (read-escape ;; a b f n r t v ; xhh ... (lambda () (let* ((ch (read-char port))) (case ch ((#\a) #\alarm) ((#\b) #\backspace) ;;((#\f) #\formfeed) ((#\n) #\newline) ((#\r) #\return) ((#\t) #\tab) (else ch))))) (read-vref (lambda () (let* ((frag (read-frag cs:vt)) (frag (sx-ref frag 1)) ; extract string value (ch1 (peek-char port)) (indx (cond ((eof-object? ch1) #f) ((char=? ch1 #\() #t) (else #f)))) (db "$frag=~S ch1=~S\n" frag ch1) (if indx `(deref-indexed ,frag ,(cadr (read-index))) `(deref ,frag))))) (init-blev ; initial brace level (lambda (end-cs) (if (eq? end-cs cs:rcurly) 1 0))) (read-frag (lambda (end-cs) ;;(sf "\n") (let loop ((tag #f) ; tag: string etc (chl '()) ; list of chars read (bl (init-blev end-cs)) ; brace level (ch (read-char port))) ; next char (db "F: tag=~S ch=~S chl=~S bl=~S end-cs=~S\n" tag ch chl bl end-cs) (cond ((eof-object? ch) (if (positive? bl) (error "missing end-brace")) (if (pair? chl) (finish tag chl ch) end-cs)) ((and (zero? bl) (char-set-contains? end-cs ch)) (db "F: done\n") (if tag (finish tag chl ch) (begin (unread-char ch port) end-cs))) ((and (char=? ch #\\) (zero? bl)) (loop tag (cons (read-escape) chl) bl (read-char port))) ((char=? ch #\$) (if tag (finish tag chl ch) (read-vref))) ((char=? ch #\{) (read-brace)) ((char=? ch #\() (if tag (finish tag chl ch) (read-index))) ((char=? ch #\[) (if tag (finish tag chl ch)) (swallow (read-cmmd cs:rs))) ((char=? ch #\") (swallow (read-frag cs:dquote))) ((not tag) (loop 'string (cons ch chl) bl (read-char port))) (else (loop tag (cons ch chl) bl (read-char port))))))) ) ;; wrap w/ catch ;;(read-cmmd cs:nl) (let ((cmd (read-cmmd cs:ct)) (nxt (peek-char port))) (cond ((eof-object? nxt)) ((char-set-contains? cs:ct nxt) (read-char port))) cmd) ;; or (swallow (read-cmmd cs:ct)) )) ;; @deffn {Procedure} split-body body ;; For the string @var{body} which is known to be interpreted as a sequence ;; of commands, split the string into a sequence of commands inside a ;; @code{(body ...)} element. ;; @end deffn (define (split-body body) (cons 'body (call-with-input-string body (lambda (port) (let loop ((cmd (read-command port))) (cond ((eof-object? cmd) '()) ((null? (cdr cmd)) (loop (read-command port))) (else (cons cmd (loop (read-command port)))))))))) (define (fix-expr-string xstr) (let* ((cmmd (call-with-input-string (string-append "expr " xstr) (lambda (port) (read-command port)))) (tail (sx-tail cmmd 2)) (tail (splice-xtail tail))) `(expr . ,tail))) ;; convert all words in an expr command to a single list of frags (define (splice-xtail tail) (let* ((blank `(string " ")) (terms (fold-right (lambda (word terms) (if (eq? 'word (sx-tag word)) (append (list blank) (cdr word) terms) (cons* blank word terms))) '() tail)) (toks (fold-right (lambda (term toks) (if (string? term) (cons term toks) (if (eq? 'command (sx-tag term)) (cons term toks) (cons term toks)))) '() (cdr terms)))) ;;(sf "sxt ~S => ~S\n" tail toks) toks)) ;; @deffn {Procedure} cnvt-args astr ;; Given the argument string @var{astr} for a procedure definition, ;; convert to an sxml tree (@code{arg-list}) with child elements with ;; tags @code{arg} (required), @code{opt-arg} (optional with default), ;; or @code{rest}. ;; @end deffn (define (cnvt-args astr) (with-input-from-string astr (lambda () (define (unread-chl-1 chl) (cond ((null? chl)) ((null? (cdr chl))) ((eof-object? (car chl))) (else (unread-char (car chl)) (unread-chl-1 (cdr chl))))) (define (skip-ws ch) (if (char-set-contains? cs:ws ch) (skip-ws (read-char)) ch)) (define (read-non-ws ch) (let loop ((chl '()) (ch ch)) (cond ((eof-object? ch) (rls chl)) ((char-set-contains? cs:ws ch) (rls chl)) (else (loop (cons ch chl) (read-char)))))) (define (read-pair ch) (if (not (char=? ch #\{)) #f (let loop ((arg #f) (chl '()) (ch (read-char))) (cond ((eof-object? ch) (report-error "missing right brace")) ((char=? ch #\}) `(opt-arg ,arg (string ,(rls chl)))) ((char-set-contains? cs:ws ch) (if arg (if (pair? chl) (loop arg (cons ch chl) (read-char)) (loop arg chl (read-char))) (loop (rls chl) '() (read-char)))) (else (loop arg (cons ch chl) (read-char))))))) (define (read-args-kw ch) (let loop ((kw '(#\a #\r #\g #\s)) (chl '()) (ch ch)) (cond ((null? kw) #t) ((eof-object? ch) (unread-chl-1 chl) #f) ((char=? ch (car kw)) (loop (cdr kw) (cons (car kw) chl) (read-char))) (else (unread-chl-1 (cons ch chl)) #f)))) (cons 'arg-list (let loop ((ch (read-char))) (cond ((eof-object? ch) '()) ((char-set-contains? cs:ws ch) (loop (read-char))) ((char=? ch #\{) (cons (read-pair ch) (loop (read-char)))) ((read-args-kw ch) (cons '(rest "args") (loop (read-char)))) (else (let ((argval (read-non-ws ch))) (cons `(arg ,argval) (loop (read-char))))))))))) ;; @deffn {Procedure} num-string cstr ;; Given a string return a numeric sxml elment like @code{(fixed "123")} ;; or @code{(float "4.56")} or return @code{#f} if not a number. ;; @end deffn (define (num-string cstr) ;; includes ugliness to add sign (let* ((neg? (char=? #\- (string-ref cstr 0))) (cstr (if neg? (substring/shared cstr 1) cstr))) (define (addsign s) (if neg? (string-append "-" s) s)) (and=> (with-input-from-string cstr (lambda () (let ((val (read-c-num (read-char)))) (and (eof-object? (peek-char)) val)))) (lambda (p) (case (car p) (($fixed) `(fixed ,(addsign (cnumstr->scm (cdr p))))) (($float) `(float ,(addsign (cdr p)))) (else (error "coding error"))))))) ;; ((string "elseif") cond-part body-part . rest) ;; ((string "else") body-part) (define (cnvt-cond-tail ctail) (db "ctail=~S\n" ctail) (match ctail ('() '()) (`((string "else") (string ,body-part)) `((else ,(split-body body-part)))) (`((string "elseif") (string ,cnd) (string ,body-part) . ,rest) (cons `(elseif ,(fix-expr-string cnd) ,(split-body body-part)) (cnvt-cond-tail (list-tail ctail 3)))) (_ (throw 'tcl-error "syntax error")))) ;; This is an alist of commands which are translated into pre-compiled ;; constructs. For example, while, for, proc, if. ;; The lambdas in here should NEVER emit a command element, otherwise ;; infinite loop will happen (define tcl-res-cmds `(("NOOP" . ,(lambda (tree) `(void))) ("array" . ,(lambda (tree) (let ((cmmd (sx-ref* tree 2 1)) (name (sx-ref* tree 3 1)) (rest (sx-tail tree 4))) (if (string=? cmmd "set") `(array-set ,name ,@rest) `(array ,name ,@rest))))) ("break" . ,(lambda (tree) `(break))) ("continue" . ,(lambda (tree) `(continue))) ("expr" . ,(lambda (tree) `(expr . ,(splice-xtail (sx-tail tree 2))))) ("format" . ,(lambda (tree) `(format . ,(sx-tail tree 2)))) ("if" . ,(lambda (tree) (sxml-match tree ;; TODO : deal with "elseif" ((command (string "if") (string ,cnd) (string ,bdy) . ,rest) `(if ,(fix-expr-string cnd) ,(split-body bdy) . ,(cnvt-cond-tail rest))) (,_ (report-error "usage: if cond then else"))))) ("incr" . ,(lambda (tree) `(incr ,@(sx-tail tree 2)))) ("proc" ;; This assumes default arguments are strings constants. . ,(lambda (tree) (sxml-match tree ((command (string "proc") (string ,name) (string ,args) (string ,body)) `(proc ,name ,(cnvt-args args) ,(split-body body))) (,_ (report-error "usage: proc name args body"))))) ("return" . ,(lambda (tree) `(return ,(sx-ref tree 2)))) ("set" . ,(lambda (tree) (sxml-match tree ((command (string "set") (string ,name) . ,rest) `(set . ,(sx-tail tree 2))) ((command (string "set") (word (string ,name) (index ,indx)) . ,rest) `(set-indexed (string ,name) (word ,indx) . ,rest)) ;;(,_ (report-error "can't handle this yet"))))) (,_ `(set . ,(sx-tail tree 2)))))) ("while" . ,(lambda (tree) (sxml-match tree ((command (string "while") ,cond (string ,body)) `(while (expr . ,(splice-xtail (list cond))) ,(split-body body))) (,_ (report-error "usage: while cond body"))))) ;;("array" . #f) ;;("list" . #f) ;; === string-> Scheme for calling Scheme functions ;;("number" . #f) ;;("integer" . #f) )) ;; @deffn {Procedure} nxify-command form => form ;; Convert commands like @code{while} or @code{proc} to ;; the associated nx-tcl form. ;; @example ;; (nxify-command '(command "if" "1" "set x 3")) => ;; (if (expr "1") (body "set x 3"))) ;; @end example ;; If no match if found, returns @code{#f}. ;; @noindent ;; Further processing should be executed on the body. ;; @end deffn (define (nxify-command tree) (let ((repl (and=> (assoc-ref tcl-res-cmds (sx-ref* tree 1 1)) (lambda (proc) (proc tree))))) (if (and (pair? repl) (eq? 'command (car repl))) (error "coding error")) repl)) (export nxify-command) ;; convert special commands and words into nx-tcl syntax ;; @example ;; (cnvt-tcl '(command (string "expr") ...)) => (expr ...) ;; @end example (define (cnvt-tree tree) ;;(sf "tree=~S\n" tree) (letrec ((cnvt-elt (lambda (tree) (if (string? tree) tree (sxml-match tree ((command . ,rest) (or (and=> (nxify-command tree) cnvt-tree) (let* ((tail0 (sx-tail tree)) (tail1 (cnvt-tail tail0))) (if (eq? tail1 tail0) tree `(command . ,tail1))))) ((string ,val) (or (num-string val) tree)) ((word (string ,val)) (cnvt-tree (sx-ref tree 1))) ((word . ,rest) (let* ((tail0 (sx-tail tree)) (tail1 (cnvt-tail tail0))) (if (eq? tail1 tail0) tree `(word . ,tail1)))) (,_ (let* ((tag (sx-tag tree)) (tail0 (sx-tail tree)) (tail1 (cnvt-tail tail0))) ;;(sf "cnvt _ tag=~S\n" tag) ;;(sf " tail0=~S tail1=~S\n" tail0 tail1) (if (eq? tail1 tail0) tree (cons tag tail1)))))))) (cnvt-tail (lambda (tail) (if (null? tail) tail (let* ((head0 (car tail)) (head1 (cnvt-elt head0)) (tail0 (cdr tail)) (tail1 (cnvt-tail tail0))) ;;(sf "cnvt-tail ~S ~S\n" head0 tail0) ;;(sf "cnvt-tail ~S ~S\n" head1 tail1) (if (eq? head1 head0) (if (eq? tail1 tail0) tail (cons head0 tail1)) (if (eq? tail1 tail0) (cons head1 tail0) (cons head1 tail1)))))))) (cnvt-elt tree))) ;; @deffn {Procedure} read-tcl-stmt port env ;; Guile extension language routine to read a single statement. ;; @end deffn (define (read-tcl-stmt port env) "- Procedure: read-tcl-stmt port env Guile extension language routine to read a single statement." (let* ((cmmd0 (read-command port)) (cmmd1 (cnvt-tree cmmd0))) ;;(sf "s:cmd1:\n ") (pp cmmd0) ;;(sf "s:cmd2:\n ") (pp cmmd1) cmmd1)) ;; @deffn {Procedure} read-tcl-file port env ;; Read a Tcl file. Return a SXML tree. ;; @end deffn (define (read-tcl-file port env) "- Procedure: read-tcl-file port env Read a Tcl file. Return a SXML tree." (if (eof-object? (peek-char port)) (read-char port) (cons 'body (let loop ((cmd (read-command port))) (if (eof-object? cmd) '() (let ((cmd1 cmd) (cmd2 (cnvt-tree cmd))) ;;(sf "cmd1:\n") (pp cmd1) ;;(sf "cmd2::n") (pp cmd2) (cons (cnvt-tree cmd) (loop (read-command port)))))))) ) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/tcl/NOTES0000644000175100000240000000202213605250515017640 0ustar mwettedialoutnyacc/lang/tcl/NOTES Copyright (C) 2018 Matthew R. Wette Copying and distribution of this file, with or without modification, are permitted in any medium without royalty provided the copyright notice and this notice are preserved. This file is offered as-is, without any warranty. ;; name arg ... => (cmd name arg ...) ;; word => (word "acc" (command xxx)) ;; $name => (vref name) ;; $name{index} => (vxref name index) ;; ${name} => (vxref (word ...)) ;; [name arg ...] (cmd name arg ...) ;; {x"xx"x} => ;; cmd : word word ... ;; word : ;; tough ones: ;; ${abc}${def} ;; 00) {*} not implemented; I think this is unquote splicing ;; blank = EOF or whitespace ;; command ;; check first character ;; case { : read word to }, eat }, check blank after ;; case " : read word to ", eat ", check blank after ;; else read word to whitespace ;; word ;; read frags until end-cs ;; read char ;; $ : read frag => if followed by {...} then ixref, else deref ;; { : read to } => string ;; else collect string ;; returns (word "xxx" (xxx ...) nyacc-1.00.2/examples/nyacc/lang/tcl/tcl-01.test0000644000175100000240000000415313605250515020735 0ustar mwettedialout;; nyacc/lang/tcl/tcl-01.test -*- scheme -*- ;; ;; Copyright (C) 2017 Matthew R. Wette ;; ;; Copying and distribution of this file, with or without modification, ;; are permitted in any medium without royalty provided the copyright ;; notice and this notice are preserved. This file is offered as-is, ;; without any warranty. (define-module (tcl-01) #:use-module (nyacc lang tcl parser) ;;#:use-module (language nx-tcl spec) #:use-module ((srfi srfi-1) #:select (fold)) #:use-module (test-suite lib)) (use-modules (ice-9 pretty-print)) (define pp pretty-print) (define (sf fmt . args) (apply simple-format #t fmt args)) (with-test-prefix "nyacc/lang/tcl-01, parser" (pass-if "read-command" (fold (lambda (pair ok?) (and ok? (equal? (call-with-input-string (car pair) read-command) (cdr pair)))) #t '(("a" . (command (string "a"))) ("abc" . (command (string "abc"))) ("abc def ghi" . (command (string "abc") (string "def") (string "ghi"))) ("abc \"def ghi\"" . (command (string "abc") (string "def ghi"))) ("abc [def ghi]" . (command (string "abc") (command (string "def") (string "ghi")))) ("abc [def ghi] ljk" . (command (string "abc") (command (string "def") (string "ghi")) (string "ljk"))) ("abc def$ghi" . (command (string "abc") (word (string "def") (deref "ghi")))) ("abc def$ghi$jkl" . (command (string "abc") (word (string "def") (deref "ghi") (deref "jkl")))) ("abc [def ${ghi}] jkl" . (command (string "abc") (command (string "def") (deref "ghi")) (string "jkl"))) ("abc [def ${ghi jkl}] mno" . (command (string "abc") (command (string "def") (deref "ghi jkl") ) (string "mno"))) ("abc {a {b 1} c}" . (command (string "abc") (string "a {b 1} c"))) ("abc ${def}(ghi)" . (command (string "abc") (deref-indexed "def" (string "ghi")))) )))) #| (define (tclme) (pp (split-body " abc def ghi abc \"def ghi\" abc [def ghi] abc [def ghi] lkj abc [def $ghi] lkj abc def$ghi abc def$ghi$jkl abc [def ${ghi}] lkj abc [def ${ghi jkl}] mno "))) |# ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/tcl/tcl-02.test0000644000175100000240000000166613605250515020744 0ustar mwettedialout;; nyacc/lang/tcl/tcl-02.test -*- scheme -*- ;; ;; Copyright (C) 2017 Matthew R. Wette ;; ;; Copying and distribution of this file, with or without modification, ;; are permitted in any medium without royalty provided the copyright ;; notice and this notice are preserved. This file is offered as-is, ;; without any warranty. (define-module (tcl-02) #:use-module (system base compile) #:use-module (test-suite lib)) (use-modules (ice-9 pretty-print)) (define pp pretty-print) (define (sf fmt . args) (apply simple-format #t fmt args)) (define a) (define b) (define c) (define d) (define e) (define f) (define _1pl) (with-test-prefix "tcl-02" (pass-if "compile tcl-02.tcl" (string? (compile-file "tcl-02.tcl" #:from 'nx-tcl))) (load "tcl-02.tcl") (pass-if "set/expr" (= c 12)) (pass-if "proc" (= 3 (_1pl 2))) (pass-if "if-else" (and (= d 3) (= e 4) (= f 6) #t)) ) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/tcl/tcl-02.tcl0000644000175100000240000000117713605250515020544 0ustar mwettedialout# tcl-01.tcl # Copyright (C) 2018 Matthew R. Wette # # Copying and distribution of this file, with or without modification, # are permitted in any medium without royalty provided the copyright # notice and this notice are preserved. This file is offered as-is, # without any warranty. # set/expr set a 1 set b $a$a set c [expr $a + $b] # proc proc _1pl {y} { set x 1 set z [expr $x + $y] return $z } # if-else set d 0 set e 0 set f 0 if {$a == 1} { set d 3 } if {$a < 0} { set e -4 } else { set e 4 } if {$a < 0} { set f 5 } elseif {$a == 1} { set f 6 } else { set f 7 } # --- last line --- nyacc-1.00.2/examples/nyacc/lang/tcl/nx-tcl.texi0000644000175100000240000000266513605250515021142 0ustar mwettedialout\input texinfo.tex @setfilename nx-tcl.info @settitle Notes on NX-Tcl @copying Copyright (C) 2018 -- Matthew R. Wette. Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.3 or any later version published by the Free Software Foundation; with no Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts. A copy of the license is included with the distribution as @file{COPYING.DOC}. @end copying @headings off @everyfooting @| @thispage @| @node Top @top Notes on NX-Tcl @format Matt Wette September 2018 @end format @heading Notes You can't redefine commands that would usually not be redefined. That includes @code{proc}, @code{while}, @code{if}, etc. In Tcl all values are strings. However, some functions may return numbers or lists, so Tcl eventually wants those as strings. Tcl is lazy with respect to converting to string. In some cases this makes code more effecient and robust. @subsubheading Dynamic Stack Keep a dynamic ``stack'' variable, add a commands to save proc-local variable in the environment. and push a frame as each proc is called. We need one call to save to d-stack and another to ref from the d-stack. This would be added as a fluid to the top-level env. @example downvar local-name upvar [level] stack-name local-name @end example Error message: ``no such upvar''@* I think we should ignore the level. @bye @c --- last line --- nyacc-1.00.2/examples/nyacc/lang/python/0000755000175100000240000000000013605250515017570 5ustar mwettedialoutnyacc-1.00.2/examples/nyacc/lang/python/mach.scm0000644000175100000240000001450313605250515021207 0ustar mwettedialout (define gram (make-lalr-grammar (start file-input) ;;(start single-input) ;;(start eval-input) (grammar (file-input ("\n") (stmt) (file-input "\n") (file-input stmt) ) (single-input ("\n") (simple-stmt) (compound-stmt "\n") ) (eval-input (testlist) (eval-input "\n")) (decorator ("@" dotted-name opt-arg-list "\n")) (opt-arg-list ($empty) ("(" ")") ("(" arg-list ")")) (decorators (decorator) (decorators decorator)) (decorated (decorators classdef) (decorators funcdef)) (funcdef ("def" name parameters opt-test ":" suite)) (opt-test ($empty) ("->" text)) (parameters ("(" typedargslist ")") ("(" ")")) (typeargslist ;; typedargslist: ((tfpdef ['=' test] ',')* ;; ('*' [tname] (',' tname ['=' test])* [',' '**' tname] | '**';; ;; ;; ;; tname) ;; | tfpdef ['=' test] (',' tfpdef ['=' test])* [',']) ;; tname: NAME [':' test] ;; tfpdef: tname | '(' tfplist ')' ;; tfplist: tfpdef (',' tfpdef)* [','] ;; varargslist: ((vfpdef ['=' test] ',')* ;; ('*' [vname] (',' vname ['=' test])* [',' '**' vname] | '**' ;; ;; ;; ;; vname) ;; | vfpdef ['=' test] (',' vfpdef ['=' test])* [',']) ;; vname: NAME ;; vfpdef: vname | '(' vfplist ')' ;; vfplist: vfpdef (',' vfpdef)* [','] ;; ;; stmt: simple_stmt | compound_stmt ;; simple_stmt: small_stmt (';' small_stmt)* [';'] NEWLINE ;; small_stmt: (expr_stmt | print_stmt | del_stmt | pass_stmt | flow_stmt | ;; import_stmt | global_stmt | exec_stmt | assert_stmt) ;; expr_stmt: testlist_star_expr (augassign (yield_expr|testlist) | ;; ('=' (yield_expr|testlist_star_expr))*) ;; testlist_star_expr: (test|star_expr) (',' (test|star_expr))* [','] ;; augassign: ('+=' | '-=' | '*=' | '@=' | '/=' | '%=' | '&=' | '|=' | '^=' | ;; '<<=' | '>>=' | '**=' | '//=') ;; # For normal assignments, additional restrictions enforced by the interprete;; ;; ;; ;; ;; ;; r ;; print_stmt: 'print' ( [ test (',' test)* [','] ] | ;; '>>' test [ (',' test)+ [','] ] ) ;; del_stmt: 'del' exprlist ;; pass_stmt: 'pass' ;; flow_stmt: break_stmt | continue_stmt | return_stmt | raise_stmt | yield_stm;; ;; ;; ;; ;; t ;; break_stmt: 'break' ;; continue_stmt: 'continue' ;; return_stmt: 'return' [testlist] ;; yield_stmt: yield_expr ;; raise_stmt: 'raise' [test ['from' test | ',' test [',' test]]] ;; import_stmt: import_name | import_from ;; import_name: 'import' dotted_as_names ;; import_from: ('from' ('.'* dotted_name | '.'+) ;; 'import' ('*' | '(' import_as_names ')' | import_as_names)) ;; import_as_name: NAME ['as' NAME] ;; dotted_as_name: dotted_name ['as' NAME] ;; import_as_names: import_as_name (',' import_as_name)* [','] ;; dotted_as_names: dotted_as_name (',' dotted_as_name)* ;; dotted_name: NAME ('.' NAME)* ;; global_stmt: ('global' | 'nonlocal') NAME (',' NAME)* ;; exec_stmt: 'exec' expr ['in' test [',' test]] ;; assert_stmt: 'assert' test [',' test] ;; ;; compound_stmt: if_stmt | while_stmt | for_stmt | try_stmt | with_stmt | func;; def | classdef | decorated ;; if_stmt: 'if' test ':' suite ('elif' test ':' suite)* ['else' ':' suite] ;; while_stmt: 'while' test ':' suite ['else' ':' suite] ;; for_stmt: 'for' exprlist 'in' testlist ':' suite ['else' ':' suite] ;; try_stmt: ('try' ':' suite ;; ((except_clause ':' suite)+ ;; ['else' ':' suite] ;; ['finally' ':' suite] | ;; 'finally' ':' suite)) ;; with_stmt: 'with' with_item (',' with_item)* ':' suite ;; with_item: test ['as' expr] ;; with_var: 'as' expr ;; NB compile.c makes sure that the default except clause is last ;; except_clause: 'except' [test [(',' | 'as') test]] ;; suite: simple_stmt | NEWLINE INDENT stmt+ DEDENT ;; ;; # Backward compatibility cruft to support: ;; # [ x for x in lambda: True, lambda: False if x() ] ;; # even while also allowing: ;; # lambda x: 5 if x else 2 ;; # (But not a mix of the two) ;; testlist_safe: old_test [(',' old_test)+ [',']] ;; old_test: or_test | old_lambdef ;; old_lambdef: 'lambda' [varargslist] ':' old_test ;; ;; test: or_test ['if' or_test 'else' test] | lambdef ;; or_test: and_test ('or' and_test)* ;; and_test: not_test ('and' not_test)* ;; not_test: 'not' not_test | comparison ;; comparison: expr (comp_op expr)* ;; comp_op: '<'|'>'|'=='|'>='|'<='|'<>'|'!='|'in'|'not' 'in'|'is'|'is' 'not' ;; star_expr: '*' expr ;; expr: xor_expr ('|' xor_expr)* ;; xor_expr: and_expr ('^' and_expr)* ;; and_expr: shift_expr ('&' shift_expr)* ;; shift_expr: arith_expr (('<<'|'>>') arith_expr)* ;; arith_expr: term (('+'|'-') term)* ;; term: factor (('*'|'@'|'/'|'%'|'//') factor)* ;; factor: ('+'|'-'|'~') factor | power ;; power: atom trailer* ['**' factor] ;; atom: ('(' [yield_expr|testlist_gexp] ')' | ;; '[' [listmaker] ']' | ;; '{' [dictsetmaker] '}' | ;; '`' testlist1 '`' | ;; NAME | NUMBER | STRING+ | '.' '.' '.') ;; listmaker: (test|star_expr) ( comp_for | (',' (test|star_expr))* [','] ) ;; testlist_gexp: (test|star_expr) ( comp_for | (',' (test|star_expr))* [','] ) ;; lambdef: 'lambda' [varargslist] ':' test ;; trailer: '(' [arglist] ')' | '[' subscriptlist ']' | '.' NAME ;; subscriptlist: subscript (',' subscript)* [','] ;; subscript: test | [test] ':' [test] [sliceop] ;; sliceop: ':' [test] ;; exprlist: (expr|star_expr) (',' (expr|star_expr))* [','] ;; testlist: test (',' test)* [','] ;; dictsetmaker: ( (test ':' test (comp_for | (',' test ':' test)* [','])) | ;; (test (comp_for | (',' test)* [','])) ) ;; ;; classdef: 'class' NAME ['(' [arglist] ')'] ':' suite ;; ;; arglist: (argument ',')* (argument [','] ;; |'*' test (',' argument)* [',' '**' test] ;; |'**' test) ;; argument: test [comp_for] | test '=' test # Really [keyword '='] test ;; ;; comp_iter: comp_for | comp_if ;; comp_for: 'for' exprlist 'in' testlist_safe [comp_iter] ;; comp_if: 'if' old_test [comp_iter] ;; ;; testlist1: test (',' test)* ;; ;; # not used in grammar, but may appear in "node" passed from Parser to Compil;; ;; ;; ;; ;; er ;; encoding_decl: NAME ;; ;; yield_expr: 'yield' [yield_arg];; ;; yield_arg: 'from' test | testlist nyacc-1.00.2/examples/nyacc/lang/python/gram.txt0000644000175100000240000001320413605250515021257 0ustar mwettedialout (define gram (make-lalr-grammar # Start symbols for the grammar: # file_input is a module or sequence of commands read from an input file; # single_input is a single interactive statement; # eval_input is the input for the eval() and input() functions. # NB: compound_stmt in single_input is followed by extra NEWLINE! file_input: (NEWLINE | stmt)* ENDMARKER single_input: NEWLINE | simple_stmt | compound_stmt NEWLINE eval_input: testlist NEWLINE* ENDMARKER decorator: '@' dotted_name [ '(' [arglist] ')' ] NEWLINE decorators: decorator+ decorated: decorators (classdef | funcdef) funcdef: 'def' NAME parameters ['->' test] ':' suite parameters: '(' [typedargslist] ')' typedargslist: ((tfpdef ['=' test] ',')* ('*' [tname] (',' tname ['=' test])* [',' '**' tname] | '**' tname) | tfpdef ['=' test] (',' tfpdef ['=' test])* [',']) tname: NAME [':' test] tfpdef: tname | '(' tfplist ')' tfplist: tfpdef (',' tfpdef)* [','] varargslist: ((vfpdef ['=' test] ',')* ('*' [vname] (',' vname ['=' test])* [',' '**' vname] | '**' vname) | vfpdef ['=' test] (',' vfpdef ['=' test])* [',']) vname: NAME vfpdef: vname | '(' vfplist ')' vfplist: vfpdef (',' vfpdef)* [','] stmt: simple_stmt | compound_stmt simple_stmt: small_stmt (';' small_stmt)* [';'] NEWLINE small_stmt: (expr_stmt | print_stmt | del_stmt | pass_stmt | flow_stmt | import_stmt | global_stmt | exec_stmt | assert_stmt) expr_stmt: testlist_star_expr (augassign (yield_expr|testlist) | ('=' (yield_expr|testlist_star_expr))*) testlist_star_expr: (test|star_expr) (',' (test|star_expr))* [','] augassign: ('+=' | '-=' | '*=' | '@=' | '/=' | '%=' | '&=' | '|=' | '^=' | '<<=' | '>>=' | '**=' | '//=') # For normal assignments, additional restrictions enforced by the interpreter print_stmt: 'print' ( [ test (',' test)* [','] ] | '>>' test [ (',' test)+ [','] ] ) del_stmt: 'del' exprlist pass_stmt: 'pass' flow_stmt: break_stmt | continue_stmt | return_stmt | raise_stmt | yield_stmt break_stmt: 'break' continue_stmt: 'continue' return_stmt: 'return' [testlist] yield_stmt: yield_expr raise_stmt: 'raise' [test ['from' test | ',' test [',' test]]] import_stmt: import_name | import_from import_name: 'import' dotted_as_names import_from: ('from' ('.'* dotted_name | '.'+) 'import' ('*' | '(' import_as_names ')' | import_as_names)) import_as_name: NAME ['as' NAME] dotted_as_name: dotted_name ['as' NAME] import_as_names: import_as_name (',' import_as_name)* [','] dotted_as_names: dotted_as_name (',' dotted_as_name)* dotted_name: NAME ('.' NAME)* global_stmt: ('global' | 'nonlocal') NAME (',' NAME)* exec_stmt: 'exec' expr ['in' test [',' test]] assert_stmt: 'assert' test [',' test] compound_stmt: if_stmt | while_stmt | for_stmt | try_stmt | with_stmt | funcdef | classdef | decorated if_stmt: 'if' test ':' suite ('elif' test ':' suite)* ['else' ':' suite] while_stmt: 'while' test ':' suite ['else' ':' suite] for_stmt: 'for' exprlist 'in' testlist ':' suite ['else' ':' suite] try_stmt: ('try' ':' suite ((except_clause ':' suite)+ ['else' ':' suite] ['finally' ':' suite] | 'finally' ':' suite)) with_stmt: 'with' with_item (',' with_item)* ':' suite with_item: test ['as' expr] with_var: 'as' expr # NB compile.c makes sure that the default except clause is last except_clause: 'except' [test [(',' | 'as') test]] suite: simple_stmt | NEWLINE INDENT stmt+ DEDENT # Backward compatibility cruft to support: # [ x for x in lambda: True, lambda: False if x() ] # even while also allowing: # lambda x: 5 if x else 2 # (But not a mix of the two) testlist_safe: old_test [(',' old_test)+ [',']] old_test: or_test | old_lambdef old_lambdef: 'lambda' [varargslist] ':' old_test test: or_test ['if' or_test 'else' test] | lambdef or_test: and_test ('or' and_test)* and_test: not_test ('and' not_test)* not_test: 'not' not_test | comparison comparison: expr (comp_op expr)* comp_op: '<'|'>'|'=='|'>='|'<='|'<>'|'!='|'in'|'not' 'in'|'is'|'is' 'not' star_expr: '*' expr expr: xor_expr ('|' xor_expr)* xor_expr: and_expr ('^' and_expr)* and_expr: shift_expr ('&' shift_expr)* shift_expr: arith_expr (('<<'|'>>') arith_expr)* arith_expr: term (('+'|'-') term)* term: factor (('*'|'@'|'/'|'%'|'//') factor)* factor: ('+'|'-'|'~') factor | power power: atom trailer* ['**' factor] atom: ('(' [yield_expr|testlist_gexp] ')' | '[' [listmaker] ']' | '{' [dictsetmaker] '}' | '`' testlist1 '`' | NAME | NUMBER | STRING+ | '.' '.' '.') listmaker: (test|star_expr) ( comp_for | (',' (test|star_expr))* [','] ) testlist_gexp: (test|star_expr) ( comp_for | (',' (test|star_expr))* [','] ) lambdef: 'lambda' [varargslist] ':' test trailer: '(' [arglist] ')' | '[' subscriptlist ']' | '.' NAME subscriptlist: subscript (',' subscript)* [','] subscript: test | [test] ':' [test] [sliceop] sliceop: ':' [test] exprlist: (expr|star_expr) (',' (expr|star_expr))* [','] testlist: test (',' test)* [','] dictsetmaker: ( (test ':' test (comp_for | (',' test ':' test)* [','])) | (test (comp_for | (',' test)* [','])) ) classdef: 'class' NAME ['(' [arglist] ')'] ':' suite arglist: (argument ',')* (argument [','] |'*' test (',' argument)* [',' '**' test] |'**' test) argument: test [comp_for] | test '=' test # Really [keyword '='] test comp_iter: comp_for | comp_if comp_for: 'for' exprlist 'in' testlist_safe [comp_iter] comp_if: 'if' old_test [comp_iter] testlist1: test (',' test)* # not used in grammar, but may appear in "node" passed from Parser to Compiler encoding_decl: NAME yield_expr: 'yield' [yield_arg] yield_arg: 'from' test | testlist nyacc-1.00.2/examples/nyacc/lang/nx-lib.scm0000644000175100000240000001712213605250515020147 0ustar mwettedialout;; nyacc/lang/nx-util.scm - run-time library ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see ;;; Description: ;; This module provide run-time procecures for the NYACC extension (nx) ;; languages. The intent is to provide a consistent data model between ;; nx languages so that they can inter-operate. ;;; Notes: ;; For OO languages we should use single-inheritance with interfaces. ;; An object is a hash table with entries for data and either ;; A) a single class (type) entry, or ;; B) one class (type) entry and N interface entries ;; This module will need to provide run-time type determination. Well, ;; We need a procedure (obj-call obj name args) ;; ;; Idea: for each object add a lang-specific field to decorate ;; (hashq-ref* obj 'lang 'nx-javascript) => ... ;; ;; Feeling: in scheme (lisp) there is really no strong distinction between ;; an integer, float and a procedure. They are all data. ;; @subheading Object Architecture ;; The principles are ;; @itemize ;; @item campatability among many languages important ;; @item strict language adherence is not priority ;; @item base Scheme compatiblity is priority ;; @item speed is not high priority ;; @end itemize ;; Tcl arrays are ordered -- alist? ;; Tcl dicts are unordered ;;; Todos: ;; 1) add traits (aka interfaces) ;;; Code: (define-module (nyacc lang nx-lib) #:export (nx-get-method ;; make-nx-hash-table nx-hash-ref nx-hash-set! nx-hash-add-lang nx-hash-lang-ref nx-hash-lang-set! %nx-lang-key ;; install-inline-language-evaluator uninstall-inline-language-evaluator) ) (define (sferr fmt . args) (apply simple-format (current-error-port) fmt args)) (use-modules (ice-9 pretty-print)) (define (pperr exp) (pretty-print exp (current-error-port) #:per-line-prefix " ")) (define nx-undefined (if #f #f)) ;; @deffn {Procedure} nx-get-method obj name ;; find a ;; @end deffn (define (nx-get-method obj name) #f) (define fooo 1) ;;; hash tables ;; maybe this should be a Guile (record) type ;; This is guile hash table with v keys ;; The hash table has a {lang} key to another hash table. ;; each language gets an entry in the lang entry so ... (define %nx-lang-key '{nx-lang}) (define (nx-hash-add-lang htab lang) (unless (hashq-ref htab %nx-lang-key) (hashv-set! htab %nx-lang-key (make-hash-table 7))) (let ((ltab (hashv-ref htab '%nx-lang-key))) (hashv-set! ltab lang (make-hash-table 7)))) (define (nx-hash-lang-ref htab lang key) (let ((ltab (hashv-ref (hashv-ref htab %nx-lang-key) lang))) (hashv-ref ltab key))) (define (nx-hash-lang-set! htab lang key val) (let ((ltab (hashv-ref (hashv-ref htab %nx-lang-key) lang))) (hashv-set! ltab key val))) (define* (make-nx-hash-table #:optional (n 31) #:key (lang #f)) (let ((htab (make-hash-table n))) (if lang (nx-hash-add-lang htab lang)) htab)) (define (nx-hash-ref htab key) (hashq-ref htab key)) (define (nx-hash-set! htab key val) (hashq-set! htab key val)) (define (sprintf fmt . args) (define rls reverse-list->string) (define (numstr->string val) (if (string? val) val (number->string val))) (define (escape ch) (case ch ((#\\) #\\) ((#\n) #\newline) (else ch))) (with-input-from-string fmt (lambda () (let loop ((stl '()) (chl '()) (ch (read-char)) (args args)) ;;(sf "ch=~S\n" ch) (cond ((eof-object? ch) (apply string-append (reverse (cons (rls chl) stl)))) ((char=? ch #\%) (let ((ch1 (read-char))) (case ch1 ((#\\) (loop stl (cons (escape ch1) chl) (read-char) args)) ((#\%) (loop stl (cons ch1 chl) (read-char) args)) ((#\s) (loop (cons* (car args) (rls chl) stl) '() (read-char) (cdr args))) ((#\d #\f) (loop (cons* (numstr->string (car args)) (rls chl) stl) '() (read-char) (cdr args))) (else (error "sprintf: unknown % char"))))) (else (loop stl (cons ch chl) (read-char) args))))))) ;;; === in-line reading ========================================================= (use-modules (system base language)) (use-modules (system base compile)) (use-modules (language tree-il)) ;; @deffn {Procedure} read-inline-code read-char port ;; @example ;; scheme@(guile-user)> (define x ##) ;; @end example ;; @noindent ;; This executes code like it was written on the command line. ;; So the above is equivalent to: ;; @example ;; scheme@(guile-user)> ,L nx-octave ;; nx-octave@(guile-user)> [1, 2]; ;; $1 = #(1 2) ;; nx-octave@(guile-user)> ,L scheme ;; scheme@(guile-user)> (define a $1) ;; @end example ;; @end deffn (define (read-inline-code reader-char port) (let* ((str-port (open-output-string)) (name (let loop ((chl '()) (ch (read-char port))) (cond ((eof-object? ch) ch) ((char=? ch #\:) (reverse-list->string chl)) (else (loop (cons ch chl) (read-char port)))))) (code (let loop ((ch (read-char port))) (cond ((eof-object? ch) (error "oops")) ((char=? ch #\>) (let ((ch1 (read-char port))) (cond ((eof-object? ch) (error "oops")) ((char=? ch1 #\#) (display "\n" str-port) (get-output-string str-port)) (else (display ch str-port) (loop ch1))))) (else (display ch str-port) (loop (read-char port)))))) ;; (lang (lookup-language (string->symbol name))) (lread (and lang (language-reader lang))) (lcomp (and lang (assq-ref (language-compilers lang) 'tree-il))) ;; (sxml (and lread (call-with-input-string code (lambda (port) (lread port (current-module)))))) (itil (and lcomp (call-with-values (lambda () (lcomp sxml (current-module) '())) (lambda (exp env cenv) exp)))) (xtil (unparse-tree-il itil)) (scm (decompile itil)) ) (unless lang (error "no such language:" name)) scm)) ;; @deffn {Procedure} install-inline-language-evaluator ;; Install the extension language reader macro @code{#<} ... @code{>#}. ;; This reader macro will evaluate statements in extension languages, which ;; often have expression statements can return a value. Here is an example: ;; @example ;; scheme@@(guile-user)> (define a 1) ;; scheme@@(guile-user)> (define b ##) ;; scheme@@(guile-user)> b ;; $1 = 11 ;; @end example ;; @end deffn (define (install-inline-language-evaluator) "- Procedure: install-inline-language-evaluator Install the extension language reader macro '#<' ... '>#'. This reader macro will evaluate statements in extension languages, which often have expression statements can return a value. Here is an example: scheme@(guile-user)> (define a 1) scheme@(guile-user)> (define b ##) scheme@(guile-user)> b $1 = 11" (read-hash-extend #\< read-inline-code)) ;; @deffn {Procedure} uninstall-inline-language-evaluator ;; Clear the reader macro @code{#<}. ;; @end deffn (define (uninstall-inline-language-evaluator) "- Procedure: uninstall-inline-language-evaluator Clear the reader macro '#<'." (read-hash-extend #\< #f)) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/nx-load.scm0000644000175100000240000003434113605250515020322 0ustar mwettedialout;;; nyacc/lang/nx-load.scm - loading Guile extension languages ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see ;; (define-module (nyacc lang nx-load) #:export (nx-load nx-compile-file nx-compile-and-load ) #:use-module (system base language) #:use-module (system base message) #:use-module (ice-9 receive) ) ;; === new stuff ======================= ;; or save to (define (skip-whitespace port) (let loop ((ch (read-char port))) (simple-format (current-error-port) " skip ~S\n" ch) (cond ((eof-object? ch) ch) ((char-whitespace? ch) (loop (read-char port))) (else (unread-char ch port))))) (define (next-word port) (let loop ((chl '()) (ch (read-char port))) (cond ((eof-object? ch) (reverse-list->string chl)) ((char-whitespace? ch) (unread-char ch port) (reverse-list->string chl)) (else (loop (cons ch chl) (read-char port)))))) ;; unread all except one (define (unread-chars-1 chl port) (let loop ((chl chl)) (cond ((null? (cdr chl)) (car chl)) (else (unread-char (car chl) port) (loop (cdr chl)))))) (define (unread-chars chl port) (let loop ((chl chl)) (cond ((null? chl)) (else (unread-char (car chl) port) (loop (cdr chl)))))) (define (make-keyword-reader keyword) (let ((n (string-length keyword))) (lambda (port) (simple-format (current-error-port) "slurp-lang? ~S n=~S\n" port n) (let loop ((ix 0) (chl '()) (ch (read-char port))) (simple-format (current-error-port) " loop ~S ~S\n" ch ix) (cond ((eof-object? ch) (unread-chars-1 chl port) #f) ((= ix n) (unread-char ch port) #t) ((char=? ch (string-ref keyword ix)) (loop (1+ ix) (cons ch chl) (read-char port))) (else (unread-chars chl port) #f)))))) (define slurp-lang? (make-keyword-reader "#lang")) (define (lang-from-port port) (cond ((slurp-lang? port) (skip-whitespace port) (let ((lang (next-word port))) (simple-format #t "lang=~S\n" lang) (let skip-line ((ch (read-char port))) (cond ((eof-object? ch)) ((char=? #\newline ch)) (else (skip-line (read-char))))) (string->symbol lang))) (else #f))) (define %file-extension-map '(("scm" . scheme) ("js" . nx-javascript) ("m" . nx-matlab) ("el" . elisp) ("js" . ecmascript))) (define* (lang-from-file file) (let* ((ix (string-rindex file #\.)) (ext (and ix (substring file (1+ ix))))) (and ext (assoc-ref %file-extension-map ext)))) ;; === compile.scm ================ ;; call-once (define call-with-output-file/atomic (@@ (system base compile) call-with-output-file/atomic)) (define ensure-language (@@ (system base compile) ensure-language)) (define ensure-directory (@@ (system base compile) ensure-directory)) (define compiled-file-name (@@ (system base compile) compiled-file-name)) (define* (compile-file file #:key (output-file #f) (from #f) (to 'bytecode) (env #f) (opts '()) (canonicalization 'relative)) (simple-format (current-error-port) "comile-file\n") (with-fluids ((%file-port-name-canonicalization canonicalization)) (let* ((comp (or output-file (compiled-file-name file) (error "failed to create path for auto-compiled file" file))) (in (open-input-file file)) (enc (file-encoding in))) ;; Choose the input encoding deterministically. (set-port-encoding! in (or enc "UTF-8")) (ensure-directory (dirname comp)) (call-with-output-file/atomic comp (lambda (port) (let* ((from (or from (lang-from-port in) (lang-from-file file) (current-language))) (env (or env (default-environment from)))) ((language-printer (ensure-language to)) (read-and-compile in #:env env #:from from #:to to #:opts (cons* #:to-file? #t opts)) port))) file) comp))) (define* (compile-and-load file #:key (from (current-language)) (to 'value) (env (current-module)) (opts '()) (canonicalization 'relative)) (with-fluids ((%file-port-name-canonicalization canonicalization)) (read-and-compile (open-input-file file) #:from from #:to to #:opts opts #:env env))) (define compile-passes (@@ (system base compile) compile-passes)) (define compile-fold (@@ (system base compile) compile-fold)) (define find-language-joint (@@ (system base compile) find-language-joint)) (define default-language-joiner (@@ (system base compile) default-language-joiner)) (define read-and-parse (@@ (system base compile) read-and-parse)) (define* (read-and-compile port #:key (from (current-language)) (to 'bytecode) (env (default-environment from)) (opts '())) (let ((from (ensure-language from)) (to (ensure-language to))) (let ((joint (find-language-joint from to))) (parameterize ((current-language from)) (let lp ((exps '()) (env #f) (cenv env)) (let ((x (read-and-parse (current-language) port cenv))) (cond ((eof-object? x) (close-port port) (compile ((or (language-joiner joint) (default-language-joiner joint)) (reverse exps) env) #:from joint #:to to ;; env can be false if no expressions were read. #:env (or env (default-environment joint)) #:opts opts)) (else ;; compile-fold instead of compile so we get the env too (receive (jexp jenv jcenv) (compile-fold (compile-passes (current-language) joint opts) x cenv opts) (lp (cons jexp exps) jenv jcenv)))))))))) (define* (compile x #:key (from (current-language)) (to 'value) (env (default-environment from)) (opts '())) (let ((warnings (memq #:warnings opts))) (if (pair? warnings) (let ((warnings (cadr warnings))) ;; Sanity-check the requested warnings. (for-each (lambda (w) (or (lookup-warning-type w) (warning 'unsupported-warning #f w))) warnings)))) (receive (exp env cenv) (compile-fold (compile-passes from to opts) x env opts) exp)) ;; decompile-passes ;; decompile-fold ;; decompile ;; === boot-9.scm ================ (define* (load-in-vicinity dir file-name #:optional reader) "Load source file FILE-NAME in vicinity of directory DIR. Use a pre-compiled version of FILE-NAME when available, and auto-compile one when none is available, reading FILE-NAME with READER." ;; The auto-compilation code will residualize a .go file in the cache ;; dir: by default, $HOME/.cache/guile/2.0/ccache/PATH.go. This ;; function determines the PATH to use as a key into the compilation ;; cache. (define (canonical->suffix canon) (cond ((and (not (string-null? canon)) (file-name-separator? (string-ref canon 0))) canon) ((and (eq? (system-file-name-convention) 'windows) (absolute-file-name? canon)) ;; An absolute file name that doesn't start with a separator ;; starts with a drive component. Transform the drive component ;; to a file name element: c:\foo -> \c\foo. (string-append file-name-separator-string (substring canon 0 1) (substring canon 2))) (else canon))) (define compiled-extension ;; File name extension of compiled files. (cond ((or (null? %load-compiled-extensions) (string-null? (car %load-compiled-extensions))) (warn "invalid %load-compiled-extensions" %load-compiled-extensions) ".go") (else (car %load-compiled-extensions)))) (define (more-recent? stat1 stat2) ;; Return #t when STAT1 has an mtime greater than that of STAT2. (or (> (stat:mtime stat1) (stat:mtime stat2)) (and (= (stat:mtime stat1) (stat:mtime stat2)) (>= (stat:mtimensec stat1) (stat:mtimensec stat2))))) (define (fallback-file-name canon-file-name) ;; Return the in-cache compiled file name for source file ;; CANON-FILE-NAME. ;; FIXME: would probably be better just to append ;; SHA1(canon-file-name) to the %compile-fallback-path, to avoid ;; deep directory stats. (and %compile-fallback-path (string-append %compile-fallback-path (canonical->suffix canon-file-name) compiled-extension))) (define (compile file) ;; Compile source FILE, lazily loading the compiler. ((module-ref (resolve-interface '(system base compile)) 'compile-file) file #:opts %auto-compilation-options #:env (current-module))) (define (load-thunk-from-file file) (let ((loader (resolve-interface '(system vm loader)))) ((module-ref loader 'load-thunk-from-file) file))) ;; Returns a thunk loaded from the .go file corresponding to `name'. ;; Does not search load paths, only the fallback path. If the .go ;; file is missing or out of date, and auto-compilation is enabled, ;; will try auto-compilation, just as primitive-load-path does ;; internally. primitive-load is unaffected. Returns #f if ;; auto-compilation failed or was disabled. ;; ;; NB: Unless we need to compile the file, this function should not ;; cause (system base compile) to be loaded up. For that reason ;; compiled-file-name partially duplicates functionality from (system ;; base compile). (define (fresh-compiled-thunk name scmstat go-file-name) ;; Return GO-FILE-NAME after making sure that it contains a freshly ;; compiled version of source file NAME with stat SCMSTAT; return #f ;; on failure. (false-if-exception (let ((gostat (and (not %fresh-auto-compile) (stat go-file-name #f)))) (if (and gostat (more-recent? gostat scmstat)) (load-thunk-from-file go-file-name) (begin (when gostat (format (current-warning-port) ";;; note: source file ~a\n;;; newer than compiled ~a\n" name go-file-name)) (cond (%load-should-auto-compile (%warn-auto-compilation-enabled) (format (current-warning-port) ";;; compiling ~a\n" name) (let ((cfn (compile name))) (format (current-warning-port) ";;; compiled ~a\n" cfn) (load-thunk-from-file cfn))) (else #f))))) #:warning "WARNING: compilation of ~a failed:\n" name)) (define (sans-extension file) (let ((dot (string-rindex file #\.))) (if dot (substring file 0 dot) file))) (define (load-absolute abs-file-name) ;; Load from ABS-FILE-NAME, using a compiled file or auto-compiling ;; if needed. (define scmstat (false-if-exception (stat abs-file-name) #:warning "Stat of ~a failed:\n" abs-file-name)) (define (pre-compiled) (or-map (lambda (dir) (or-map (lambda (ext) (let ((candidate (string-append (in-vicinity dir file-name) ext))) (let ((gostat (stat candidate #f))) (and gostat (more-recent? gostat scmstat) (false-if-exception (load-thunk-from-file candidate) #:warning "WARNING: failed to load compiled file ~a:\n" candidate))))) %load-compiled-extensions)) %load-compiled-path)) (define (fallback) (and=> (false-if-exception (canonicalize-path abs-file-name)) (lambda (canon) (and=> (fallback-file-name canon) (lambda (go-file-name) (fresh-compiled-thunk abs-file-name scmstat go-file-name)))))) (let ((compiled (and scmstat (or (and (not %fresh-auto-compile) (pre-compiled)) (fallback))))) (if compiled (begin (if %load-hook (%load-hook abs-file-name)) (compiled)) (start-stack 'load-stack (primitive-load abs-file-name))))) (save-module-excursion (lambda () (with-fluids ((current-reader reader) (%file-port-name-canonicalization 'relative)) (cond ((absolute-file-name? file-name) (load-absolute file-name)) ((absolute-file-name? dir) (load-absolute (in-vicinity dir file-name))) (else (load-from-path (in-vicinity dir file-name)))))))) (define-syntax nx-load (make-variable-transformer (lambda (x) (let* ((src (syntax-source x)) (file (and src (assq-ref src 'filename))) (dir (and (string? file) (dirname file)))) (syntax-case x () ((_ arg ...) #`(load-in-vicinity #,(or dir #'(getcwd)) arg ...)) (id (identifier? #'id) #`(lambda args (apply load-in-vicinity #,(or dir #'(getcwd)) args)))))))) ;; === nx-load ======================= (define nx-compile-file compile-file) (define nx-compile-and-load compile-and-load) ;; Local Variables: ;; eval: (put 'call-with-output-file/atomic 'scheme-indent-function 1) ;; End: ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/lua/0000755000175100000240000000000013605250515017030 5ustar mwettedialoutnyacc-1.00.2/examples/nyacc/lang/lua/mach.scm0000644000175100000240000000742713605250515020456 0ustar mwettedialout;; nyacc/lang/lua/mach.scm ;; Copyright (C) 2017,2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see (define-module (nyacc lang lua mach) #:export (lua-spec ) #:use-module (nyacc lang util) #:use-module (nyacc lalr) ) (define lua-spec (lalr-spec (start block) (grammar (block ("{" stmt opt-semi "}" opt-finish)) (opt-semi ($empty) (";")) (opt-finish ("finish" opt-semi)) (stmt (var-list "=" exprs) (call) ("do" block "end") ("while" expr "do" block "end") ("repeat" block "until" expr) ("if" expr "then" block "end") ("if" expr "then" block "else" block "end") ("if" expr "then" block "elseif" expr "then" block "end") ("if" expr "then" block "elseif" expr "then" block "else" block "end") ("for" name "=" expr "," expr "do" block "end") ("for" name "=" expr "," expr "," expr "do" block "end") ("for" name "," name "in" expr "do" block "end") ("function" func-name "(" ")" block "end") ("function" func-name "(" params ")" block "end") ("local" name-list) ("local" name-list "=" exprs) ) (name-list (name) (name-list "," name) ) (finish ("return") ("return" exprs) ("break") ("break" name) ) (func-name (name) (name ":" key) (name key-list) (name key-list ":" key) ) (key (name)) (var-list (var) (var-list "," var) ) (params ("...") (name-list) (name-list "...") ) (exprs (expr) (expr "," expr) ) (expr (primary) (var) (call) (expr binop expr) (unop expr) ) (primary ("nil") (number) (literal) ("%" name) (table-cons) ("function" "(" ")" block "end") ("function" "(" params ")" block "end") ("(" expr ")") ) (var (name) (primary index) (var index) (call index) ) (index ("[" expr "]") ("." key) ) (call (primary ":" key args) (primary args) (var ":" key args) (var args) (call ":" key args) (call args) ) (args ("(" exprs ")") ("(" ")") (table-cons) (literal) ) (table-cons ("{" fields "}") ("{" "}") ) (fields (expr-fields ";" mapping-fields) (expr-fields ";") (expr-fields) (mapping-fields ";" expr-fields) (mapping-fields ";") (mapping-fields) (";" expr-fields) (";" mapping-fields) ) (expr-fields (exprs ",") (exprs) ) (mapping-fields (mapping-field) (mapping-fields "," mapping-field) (mapping-fields ",") ) (mapping-field ("[" expr "]" "=" expr) (key "=" expr) ) (binop ("+") ("-") ("*") ("/") ("^") ("..") ("and") ("or") ("<") ("<=") (">") (">=") ("==") ("~=") ) (unop ("-") ("not") ) (key-hack (name) ("and") ("break") ("do") ("end") ("else") ("elseif") ("for") ("function") ("global") ("if") ("in") ("local") ("nil") ("not") ("or") ("return") ("repeat") ("then") ("until") ("while") ) ))) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/lua/README0000644000175100000240000000504613605250515017715 0ustar mwettedialoutlang/lua/ Copyright (C) 2017 Matthew R. Wette Copying and distribution of this file, with or without modification, are permitted in any medium without royalty provided the copyright notice and this notice are preserved. This file is offered as-is, without any warranty. block --> { stmt [ ';' ] } [ finish [ ';' ] ] stmt --> var { ',' var } '=' exprs | call | DO block END | WHILE expr DO block END | REPEAT block UNTIL expr | IF expr THEN block { ELSEIF expr THEN block } [ ELSE block ] END | FOR name '=' expr ',' expr [ ',' expr ] DO block END | FOR name ',' name IN expr DO block END | FUNCTION func_name '(' [ params ] ')' block END | LOCAL name { ',' name } [ '=' exprs ] finish --> RETURN [ exprs ] | BREAK [ name ] func_name --> name { '.' key } [ ':' key ] key --> name params --> '...' | name { ',' name } [ ',' '...' ] exprs --> expr { ',' expr } expr --> primary | var | call | expr binop expr | unop expr primary --> NIL | number | literal | '%' name | table_cons | FUNCTION '(' [ params ] ')' block END | '(' expr ')' var --> name | primary index | var index | call index index --> '[' expr ']' | '.' key call --> primary [ ':' key ] args | var [ ':' key ] args | call [ ':' key ] args args --> '(' [ exprs ] ')' | table_cons | literal table_cons --> '{' [ fields ] '}' fields --> expr_fields [ ';' [ mapping_fields ] ] | mapping_fields [ ';' [ expr_fields ] ] | ';' [ expr_fields | mapping_fields ] expr_fields --> exprs [ ',' ] mapping_fields --> mapping_field { ',' mapping_field } [ ',' ] mapping_field --> '[' expr ']' '=' expr | key '=' expr binop --> '+' | '-' | '*' | '/' | '^' | '..' | AND | OR | '<' | '<=' | '>' | '>=' | '==' | '~=' unop --> '-' | NOT Note that left parenthesis, left brace, and literals are preferentially treated as arguments rather than as starting a new expression. This rule comes into effect when interpreting a call as a statement, or a primary, variable, or call as an expression. Without this rule, the grammar is ambiguous. This is a change in the Lua 4.1 grammar that I'm not happy about. It makes the ; no longer a pure optional statement terminator. -- ET One can generalize a key to include keywords without ambiguity by replacing the key production with the following. key --> name | AND | BREAK | DO | END | ELSE | ELSEIF | FOR | FUNCTION | GLOBAL | IF | IN | LOCAL | NIL | NOT | OR | RETURN | REPEAT | THEN | UNTIL | WHILE nyacc-1.00.2/examples/nyacc/lang/julia/0000755000175100000240000000000013605250515017353 5ustar mwettedialoutnyacc-1.00.2/examples/nyacc/lang/julia/mach.scm0000644000175100000240000000445313605250515020775 0ustar mwettedialout;;; nyacc/lang/julia/mach.scm - grammar file for Julia ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see . ;;; Notes: ;; Julia has no documented syntax. We will need to scrounge through ;; the manual, example code and the sources to extract something. ;; Everything is an expression. ;;; Code: (define-module (nyacc lang julia mach) #:export (julia-spec ) #:use-module (nyacc lang util) #:use-module (nyacc lalr) #:use-module (nyacc lex) #:use-module (nyacc parse) #:use-module (ice-9 pretty-print) ) (define julia-spec (lalr-spec (notice (string-append "Copyright 2018 Matthew R. Wette" license-lgpl3+)) (start top) (grammar (top (ident "=" expr term) ;;("struct" ident "{" type-list "}" "<:" what) (return-stmt) ) (function-defn ("function" ident "(" arg-list ")" break ) ) (return-stmt ("return" expr)) (compound-expr ("begin" expr-list "end") ("(" expr-list ")") ) (if-expr ("if" expr break expr-list break "end") ("if" expr break expr-list break "else" expr-list break "end") ("if" expr break expr-list break elseif-list break "end") ("if" expr break expr-list break elseif-list "else" expr-list break "end")) (elseif-list-1 ("elseif" expr break expr-list) (elseif-list-1 break "elseif" expr break expr-list)) (expr-list (expr-list-1)) (expr-list-1 (expr) (expr-list-1 break expr) (expr-list-1 ";" expr)) (break ("\n")) ))) ;; === parsers ========================== ;;(define julia-mach ;; (hashify-machine ;; (compact-machine ;; (make-lalr-machine julia-spec)))) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/c99/0000755000175100000240000000000013605250515016653 5ustar mwettedialoutnyacc-1.00.2/examples/nyacc/lang/c99/cxp0000755000175100000240000000436113605250515017377 0ustar mwettedialout#!/usr/bin/env guile !# ;;; examples/nyacc/cxp ;;; ;;; Copyright (C) 2015,2017 Matthew R. Wette ;;; ;;; This program is free software: you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation, either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program. If not, see . ;; usage: cxp -Ic99-exam c99-exam/ex1.c (use-modules (ice-9 pretty-print)) (use-modules (nyacc lang c99 parser)) (use-modules (nyacc lang c99 util)) (define inc-help '(("__builtin" "__builtin_va_list=void*" "__inline=" "__inline__=" "__restrict=" "__THROW=" "__asm(X)=" "__asm__(X)=" "__has_include(X)=__has_include__(X)" "__extension__="))) (define (scan-for-flagged flag argl) (let iter ((res '()) (argl argl)) (if (null? argl) (reverse res) (iter (if (string=? flag (substring (car argl) 0 2)) (cons (substring (car argl) 2) res) res) (cdr argl))))) (define (scan-for-rest argl) (let iter ((res '()) (argl argl)) (if (null? argl) (reverse res) (iter (if (char=? #\- (string-ref (car argl) 0)) res (cons (car argl) res)) (cdr argl))))) (define (split-def def) (let* ((ix (string-index def #\=))) (if ix (cons (string->symbol (substring def 0 ix)) (substring def (1+ ix))) (cons (string->symbol def) " ")))) (let* ((argl (cdr (program-arguments))) (incs (scan-for-flagged "-I" argl)) (incs (append incs (get-gcc-inc-dirs))) (defs (map split-def (scan-for-flagged "-D" argl))) (defs (append defs (get-gcc-cpp-defs))) (files (scan-for-rest argl))) (for-each (lambda (file) (let ((tree (with-input-from-file file (lambda () (parse-c99 #:cpp-defs defs #:inc-dirs incs #:inc-help inc-help))))) (simple-format #t "~A:\n" file) (pretty-print tree))) files) ) ;; last line nyacc-1.00.2/examples/nyacc/lang/c99/Umach.scm0000644000175100000240000000233513605250515020417 0ustar mwettedialout;; Umach.scm - update C99 machines and parser (after editing mach.scm) ;; ;; Copyright (C) 2015,2016,2018 Matthew R. Wette ;; ;; Copying and distribution of this file, with or without modification, ;; are permitted in any medium without royalty provided the copyright ;; notice and this notice are preserved. This file is offered as-is, ;; without any warranty. (define mod-dir "../../../../module/nyacc/lang/c99") (use-modules (nyacc lang c99 mach)) (use-modules (nyacc lang c99 cppmach)) (use-modules (nyacc lang c99 cxmach)) (use-modules (nyacc lalr)) (gen-cpp-files mod-dir) (compile-file (string-append mod-dir "/cpp.scm")) (gen-c99-files mod-dir) (compile-file (string-append mod-dir "/parser.scm")) (with-output-to-file ",file.txt" (lambda () (pp-lalr-notice c99-spec) (pp-lalr-grammar c99-spec) (pp-lalr-machine c99-mach))) (with-output-to-file ",expr.txt" (lambda () (pp-lalr-notice c99x-spec) (pp-lalr-grammar c99x-spec) (pp-lalr-machine c99x-mach))) (gen-c99cx-files mod-dir) (compile-file (string-append mod-dir "/cxeval.scm")) (with-output-to-file ",cexp.txt" (lambda () (pp-lalr-notice c99cx-spec) (pp-lalr-grammar c99cx-spec) (pp-lalr-machine c99cx-mach))) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/c99/hello.c0000644000175100000240000000014613605250515020123 0ustar mwettedialout int printf(const char* fmt, ...); int main(int argc, char *argv[]) { printf("Hello, world.\n"); } nyacc-1.00.2/examples/nyacc/lang/c99/tryit.scm0000644000175100000240000001171213605250515020534 0ustar mwettedialout;; examples/nyacc/lang/c99/tryit.scm ;;(debug-set! stack 750) (use-modules (srfi srfi-1)) (use-modules (nyacc lang c99 parser)) (use-modules (nyacc lang c99 cxeval)) (use-modules (nyacc lang c99 cpp)) (use-modules (nyacc lang c99 pprint)) (use-modules (nyacc lang c99 munge)) (use-modules (nyacc lang c99 cxeval)) (use-modules (nyacc lang c99 util)) (use-modules (nyacc lang sx-util)) (use-modules (nyacc lang util)) (use-modules (nyacc lex)) (use-modules (nyacc util)) (use-modules (ice-9 pretty-print)) (use-modules (sxml xpath)) (define (sf fmt . args) (apply simple-format #t fmt args)) (define pp pretty-print) (define ppsx (lambda (sx) (pretty-print sx #:per-line-prefix " "))) (define pp99 pretty-print-c99) (define cpp-defs (cond ((string-contains %host-type "darwin") '("__GNUC__=6" "__signed=signed")) (else (get-gcc-cpp-defs)))) (define inc-dirs (append `(,(assq-ref %guile-build-info 'includedir) "/usr/include" "c99-exam" "/usr/include/glib-2.0" "/usr/lib/x86_64-linux-gnu/glib-2.0/include" ;;"/usr/include/dbus-1.0" "/usr/lib/x86_64-linux-gnu/dbus-1.0/include" ;; "/usr/include/cairo" "/usr/include/glib-2.0" "/usr/lib/x86_64-linux-gnu/glib-2.0/include" "/usr/include/pixman-1" "/usr/include/freetype2" "/usr/include/libpng12" ) (get-gcc-inc-dirs))) (define inc-help c99-def-help) (define mode 'file) (define mode 'decl) (define mode 'code) (define debug #f) (define xdef? (lambda (name mode) (memq mode '(code decl)))) (define (parse-file file) (with-input-from-file file (lambda () ;;(pp cpp-defs) (pp inc-help) (pp inc-dirs) (parse-c99 #:cpp-defs cpp-defs #:inc-dirs inc-dirs #:inc-help inc-help #:mode mode #:debug debug #:show-incs #t ;;#:xdef? xdef? )))) (define (parse-string str) ;;(simple-format #t "~S => \n" str) (with-input-from-string str (lambda () (parse-c99 #:cpp-defs cpp-defs #:inc-dirs inc-dirs #:inc-help inc-help #:show-incs #f #:mode mode #:debug debug #:xdef? xdef?)))) (define (parse-string-list . str-l) (parse-string (apply string-append str-l))) ;; The standard says: ;; "For two qualified types to be compatible, both shall have the identically ;; qualified version of a compatible type; the order of type qualifiers within ;; a list of specifiers or qualifiers does not affect the specified type." ;;(and=> (parse-file "c99-exam/ex14.c") ppsx) ;;(and=> (parse-c99x "(a*b)+c") ppsx) (define adecl #f) ;;(ppsx cpp-defs) ;;(ppsx inc-dirs) ;;(ppsx inc-help) ;; see c99-06.test (define (expand-typerefs-in-code code indx) (let* ((tree (parse-string code)) (udict (c99-trans-unit->udict tree)) (decl (and=> ((sxpath `((decl ,indx))) tree) car)) (xdecl (expand-typerefs decl udict))) xdecl)) (let* ((code (string-append ;;"struct event { int events; void *data; }\n" ;;" __attribute__ ((__packed__));\n" ;;"typedef int case04 __attribute__ ((__deprecated__));\n" ;;"typedef int *bla_t[2]; bla_t foo(bla_t (*)(bla_t));\n" ;;"struct foo { int a; double b; } __attribute__((__packed__));\n" "struct foo { int a; double b; }" ;;" __attribute__ ((__packed__))" ";\n" "struct foo x;\n" )) (code "int len = sizeof(\"abc\" \"def\");\n") (code "#include \n") (code "int foo[10];") (tree (parse-string code)) ;;(expr (sx-ref* tree 1 2 1 2 1)) ;; for sizeof("abc"...) demo ;;(tree (parse-c99x code #:debug #t)) ;;(tree (parse-file "zz.c")) ;;(udict (c99-trans-unit->udict/deep tree)) ;;(udict (unitize-decl decl1 '())) ;;(udecl (udict-struct-ref udict "epoll_event")) ;;(udecl (stripdown-udecl udecl)) ;;(udecl (expand-typerefs udecl udict)) ;;(mdecl (udecl->mspec/comm udecl)) ;;(udecl (unitize-decl decl)) ;;(xdecl (expand-typerefs-in-code code 2)) ;;(udict (c99-trans-unit->udict/deep tree)) ;;(udict (c99-trans-unit->udict tree)) ;;(udecl (assoc-ref udict '(struct . "epoll_event"))) (rdecl '(decl (decl-spec-list ; raw decl (@ (attributes "__packed__")) (type-spec (struct-def (ident "epoll_event") (field-list (comp-decl (@ (comment " Epoll events ")) (decl-spec-list (type-spec (typename "uint32_t"))) (comp-declr-list (comp-declr (ident "events")))) (comp-decl (@ (comment " User data variable ")) (decl-spec-list (type-spec (typename "epoll_data_t"))) (comp-declr-list (comp-declr (ident "data")))))))))) ;;(udecl (unitize-decl rdecl '())) (udecl (cdar (unitize-decl (sx-ref tree 1) '()))) (mdecl (udecl->mdecl udecl)) ) (pp tree) ;;(pp udict) ;;(pp rdecl) ;;(pp udecl) ;;(pp mdecl) ;;(pp (mdecl->udecl mdecl)) ;;(pp99 (cdar udecl)) ;;(pp mdecl) ;;(pp xdecl) ;;(ppsx udecl) ;;(pp99 tree) ;;(ppsx (eval-c99-cx tree)) ;;(pp (get-gcc-cpp-defs)) ;;(pp (get-gcc-inc-dirs)) #t) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/c99/README0000644000175100000240000000065613605250515017542 0ustar mwettedialoutlang/c99/ Copyright (C) 2015,2017-2018 Matthew R. Wette Copying and distribution of this file, with or without modification, are permitted in any medium without royalty provided the copyright notice and this notice are preserved. This file is offered as-is, without any warranty. NOTES: $ cxp file.c tryit.scm is a file I use for debugging. You can run it also. http://trevorjim.com/c-and-cplusplus-are-not-context-free/ nyacc-1.00.2/examples/nyacc/lang/c99/c99-exam/0000755000175100000240000000000013605250515020207 5ustar mwettedialoutnyacc-1.00.2/examples/nyacc/lang/c99/c99-exam/ex07.c0000644000175100000240000000001013605250515021125 0ustar mwettedialoutint *x; nyacc-1.00.2/examples/nyacc/lang/c99/c99-exam/ex14.c0000644000175100000240000000002313605250515021127 0ustar mwettedialout#include "ex14a.h" nyacc-1.00.2/examples/nyacc/lang/c99/c99-exam/ex04.c0000644000175100000240000000011213605250515021125 0ustar mwettedialout int foo(int k) { do { k = k + 1; } while (k < 10); return k; } nyacc-1.00.2/examples/nyacc/lang/c99/c99-exam/ex05c.c0000644000175100000240000000012513605250515021275 0ustar mwettedialout int foo(int k) { int i; for (; i < 10; i++) { k = k + 1; } return k; } nyacc-1.00.2/examples/nyacc/lang/c99/c99-exam/ex14a.h0000644000175100000240000000007413605250515021303 0ustar mwettedialout#ifndef EX14A_H #define EX14A_H 1 #include "ex14b.h" #endif nyacc-1.00.2/examples/nyacc/lang/c99/c99-exam/ex09.c0000644000175100000240000000003113605250515021132 0ustar mwettedialoutint x1[3]; int x2[3][4]; nyacc-1.00.2/examples/nyacc/lang/c99/c99-exam/inc.h0000644000175100000240000000101013605250515021121 0ustar mwettedialout// inc.h #ifndef __inc_h__ #define __inc_h__ #ifdef A typedef enum { EA_ZERO = 0, EA_ONE, EA_TWO = 2 } eval_t; #elif defined(B) typedef enum { EB_ZERO = 0, EB_ONE, EB_TWO = 2 } eval_t; #else typedef enum { EC_ZERO = 0, EC_ONE, EC_TWO = 2 } eval_t; #endif typedef enum { ZZ_ZERO = 0, /* comment */ ZZ_ONE, ZZ_TWO = 2 } zz_t; typedef struct { int ix; /* comment for ix */ double c[4]; /* comment for c */ } ex1_t; /* Initialize ex1 object. */ int ex1_init(void*); #endif // --- last line --- nyacc-1.00.2/examples/nyacc/lang/c99/c99-exam/ex02.c0000644000175100000240000000012113605250515021123 0ustar mwettedialout int foo(int k) { for (int i = 0; i < 3; i++) { k += i; } return k; } nyacc-1.00.2/examples/nyacc/lang/c99/c99-exam/ex14b.h0000644000175100000240000000007413605250515021304 0ustar mwettedialout#ifndef EX14B_H #define EX14B_H 1 #include "ex14a.h" #endif nyacc-1.00.2/examples/nyacc/lang/c99/c99-exam/ex05d.c0000644000175100000240000000012413605250515021275 0ustar mwettedialout int foo(int k) { int i; for (i = 0; ; i++) { k = k + 1; } return k; } nyacc-1.00.2/examples/nyacc/lang/c99/c99-exam/ex13.c0000644000175100000240000000022713605250515021134 0ustar mwettedialouttypedef signed int t; typedef int plain; struct tag { unsigned t:4; const t:5; plain r:5; }; int foo() { t f(t(t)); long t; return 1; } nyacc-1.00.2/examples/nyacc/lang/c99/c99-exam/ex10.c0000644000175100000240000000012713605250515021130 0ustar mwettedialout// bug C99-001 #define ABC 123 /* this is a var */ #if ABC > 100 # error "bla" #endif nyacc-1.00.2/examples/nyacc/lang/c99/c99-exam/ex12.c0000644000175100000240000000011113605250515021123 0ustar mwettedialouttypedef struct foo { int x; /** * A * B */ double y; } foo_t; nyacc-1.00.2/examples/nyacc/lang/c99/c99-exam/ex06.c0000644000175100000240000000004213605250515021131 0ustar mwettedialoutenum abc { A = 0, B, C } x; nyacc-1.00.2/examples/nyacc/lang/c99/c99-exam/MANIFEST0000644000175100000240000000072713605250515021346 0ustar mwettedialoutcairo01.scm demo for ffi.d/cairo/cairo.scm cairo02.scm demo for ffi.d/cairo/cairo.scm cairo03.scm demo for ffi.d/cairo/cairo.scm ex01.c complex file ex02.c for-loop ex03.c switch ex04.c do-while ex05a.c for loop w/ decl ex05b.c for loop w/ no decl ex05c.c for-loop w/ missing first arg ex05d.c for-loop w/missing second arg ex05e.c for-loop w/missing third arg ex06.c enum def ex07.c pointer ex08.c fctn-decl ex09.c array defn ex10.c bug C99-001 solved ex11.c struct's nyacc-1.00.2/examples/nyacc/lang/c99/c99-exam/ex05e.c0000644000175100000240000000012613605250515021300 0ustar mwettedialout int foo(int k) { int i; for (i = 0; i < 10;) { k = k + 1; } return k; } nyacc-1.00.2/examples/nyacc/lang/c99/c99-exam/ex08.c0000644000175100000240000000003513605250515021135 0ustar mwettedialoutint foo1(int y); int foo2(); nyacc-1.00.2/examples/nyacc/lang/c99/c99-exam/ex05a.c0000644000175100000240000000012513605250515021273 0ustar mwettedialout int foo(int k) { for (int i = 0; i < 10; i++) { k = k + 1; } return k; } nyacc-1.00.2/examples/nyacc/lang/c99/c99-exam/ex11.c0000644000175100000240000000017513605250515021134 0ustar mwettedialout// typedef struct { int a[23],c[13]; /* this is a and c */ int *b; /* this is b */ double d[10]; } foo_t; foo_t abc; nyacc-1.00.2/examples/nyacc/lang/c99/c99-exam/ex03.c0000644000175100000240000000017613605250515021136 0ustar mwettedialout int foo(int k) { switch (k) { case 1: k = 11; break; case 2: k = 12; break; default: k = 0; break; } return k; } nyacc-1.00.2/examples/nyacc/lang/c99/c99-exam/ex01.c0000644000175100000240000000120113605250515021122 0ustar mwettedialout// ex1.c #ifdef __cplusplus__ extern "C" { #endif #include "inc.h" #define A 1 #ifdef A int y; #elif defined(B) double y; #else #error "foo" #endif eval_t x; struct foo; int d = 0x123; /* d comment */ float f = 0.0; #define OFFSET(T,V) (((T*)0)->V) typedef struct { /* hello */ eval_t x; /* comment */ int y; } xyz_t; int foo(int y) { int i, j, k; for (j = 1, k = 2, i = 0; i < 10; i++) { j = j + 1; } if (y > 0) { k = +1; } else if (y == 0) { k = OFFSET(xyz_t,y); } else { k = -1; } return 1 + x->foo(k + y); } /* this is lone comment */ #ifdef __cplusplus__ } #endif /* --- last line --- */ nyacc-1.00.2/examples/nyacc/lang/c99/c99-exam/ex05b.c0000644000175100000240000000013213605250515021272 0ustar mwettedialout int foo(int k) { int i; for (i = 0; i < 10; i++) { k = k + 1; } return k; } nyacc-1.00.2/examples/nyacc/lang/nx-util.scm0000644000175100000240000003704113605250515020360 0ustar mwettedialout;;; nyacc/lang/nx-util.scm - utilities for Guile extension languages ;; Copyright (C) 2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see ;;; Notes: ;; 1) should make a (make-return expr) ;;; Code: (define-module (nyacc lang nx-util) #:export (genxsym nx-undefined-xtil nx-push-scope nx-pop-scope nx-top-level? nx-add-toplevel nx-add-lexical nx-add-lexicals nx-add-symbol nx-lookup-in-env nx-lookup rtail singleton? make-and make-or make-thunk make-defonce with-escape/handler with-escape/arg with-escape/expr with-escape rev/repl make-handler opcall-generator block vblock make-loop make-do-while make-while lookup-gensym ) ) (define (genxsym name) (gensym (string-append (if (string? name) name (symbol->string name)) "-"))) (define nx-undefined-xtil `(const ,(if #f #f))) ;; @deffn {Procedure} nx-push-scope dict ;; Push scope level of dict, returning new dict. ;; @end deffn (define (nx-push-scope dict) "- Procedure: nx-push-scope dict Push scope level of dict, returning new dict." (list (cons '@P dict))) ;; @deffn {Procedure} nx-push-scope dict ;; Pop scope level of dictionary @var{dict}, returning dictionary ;; for popped scope. ;; @end deffn (define (nx-pop-scope dict) "- Procedure: nx-push-scope dict Pop scope level of dictionary DICT, returning dictionary for popped scope." (or (assq-ref dict '@P) (error "coding error: too many pops"))) ;; @deffn {Procedure} nx-top-level? dict ;; This is a predicate to indicate if @var{dict}'s scope top-level. ;; for popped scope. ;; @end deffn (define (nx-top-level? dict) "- Procedure: nx-top-level? dict This is a predicate to indicate if DICT's scope top-level. for popped scope." (assoc-ref dict '@top)) ;; @deffn {Procedure} nx-add-toplevel name dict ;; Given a string @var{name} and dictionary @var{dict} return a new ;; dictionary with a top-level reference for name added. This can be ;; retrieved with @code{nx-lookup name dict} where @code{dict} is the ;; return value. ;; @example ;; (let ((dict (nx-add-toplevel "foo" dict))) ;; (nx-lookup "foo" dict)) => (toplevel foo) ;; @end example ;; @end deffn (define (nx-add-toplevel name dict) "- Procedure: nx-add-toplevel name dict Given a string NAME and dictionary DICT return a new dictionary with a top-level reference for name added. This can be retrieved with 'nx-lookup name dict' where 'dict' is the return value. (let ((dict (nx-add-toplevel \"foo\" dict))) (nx-lookup \"foo\" dict)) => (toplevel foo)" (acons name `(toplevel ,(string->symbol name)) dict)) ;; @deffn {Procedure} nx-add-lexical name dict ;; Given a string @var{name} and dictionary @var{dict} return a new ;; dictionary with a lexical reference added. The reference can be ;; retrieved with @code{nx-lookup name dict} where @code{dict} is the ;; return value. ;; @example ;; (let ((dict (nx-add-lexical "foo" dict))) ;; (nx-lookup "foo" dict)) => (lexical foo foo-123) ;; @end example ;; @end deffn (define (nx-add-lexical name dict) "- Procedure: nx-add-lexical name dict Given a string NAME and dictionary DICT return a new dictionary with a lexical reference added. The reference can be retrieved with 'nx-lookup name dict' where 'dict' is the return value. (let ((dict (nx-add-lexical \"foo\" dict))) (nx-lookup \"foo\" dict)) => (lexical foo foo-123)" (acons name `(lexical ,(string->symbol name) ,(genxsym name)) dict)) ;; @deffn {Procedure} nx-add-lexicals name1 ... nameN dict ;; A fold-right with @code{nx-add-lexical}, equivalent to ;; @example ;; (fold-right nx-add-lexical dict (name1 ... nameN)) ;; @end example ;; @end deffn (define (nx-add-lexicals . args) "- Procedure: nx-add-lexicals name1 ... nameN dict A fold-right with 'nx-add-lexical', equivalent to (fold-right nx-add-lexical dict (name1 ... nameN))" (let iter ((args args)) (if (null? (cddr args)) (nx-add-lexical (car args) (cadr args)) (nx-add-lexical (car args) (iter (cdr args)))))) ;; Add lexical or toplevel based on level. (define (nx-add-symbol name dict) (if (nx-top-level? dict) (nx-add-toplevel name dict) (nx-add-lexical name dict))) (define (nx-lookup-in-env name env) (let ((sym (if (string? name) (string->symbol name) name))) (if (and env (module-variable env sym)) `(@@ ,(module-name env) ,sym) #f))) ;; @deffn {Procedure} x_y->x-y a_string => a-string ;; Convert a C-like name to a Scheme-like name. ;; @end deffn (define (x_y->x-y name) (string-map (lambda (ch) (if (char=? ch #\_) #\- ch)) name)) (define (nx-lookup name dict) (cond ((not dict) #f) ((null? dict) #f) ((assoc-ref dict name)) ; => value ((assoc-ref dict '@P) => ; parent level (lambda (dict) (nx-lookup name dict))) ((nx-lookup-in-env name (assoc-ref dict '@M))) ((nx-lookup-in-env (x_y->x-y name) (assoc-ref dict '@M))) (else #f))) (define (rtail kseed) (cdr (reverse kseed))) (define (singleton? expr) (and (pair? expr) (null? (cdr expr)))) ;; (and a b c) => (if a (if b (if c #t #f) #f) #f) (define (make-and . args) (let iter ((args args)) (if (null? args) '(const #t) `(if ,(car args) ,(iter (cdr args)) (const #f))))) ;; (or a b c) => (if a #t (if b #t (if c #t #f))) (define (make-or . args) (let iter ((args args)) (if (null? args) '(const #f) `(if ,(car args) (const #t) ,(iter (cdr args)))))) ;; reverse list but replace new head with @code{head} ;; @example ;; (rev/repl 'a '(4 3 2 1)) => '(a 2 3 4) ;; @end example (define rev/repl (case-lambda ((arg0 revl) (let iter ((res '()) (inp revl)) (if (null? (cdr inp)) (cons arg0 res) (iter (cons (car inp) res) (cdr inp))))) ((arg0 arg1 revl) (let iter ((res '()) (inp revl)) (if (null? (cdr inp)) (cons* arg0 arg1 res) (iter (cons (car inp) res) (cdr inp))))) )) (define (opcall-generator xlib) (define (xlib-ref name) `(@@ ,xlib ,name)) (lambda (op seed kseed kdict) (values (cons (rev/repl 'call (xlib-ref op) kseed) seed) kdict))) ;; @deffn {Procedure} make-thunk expr [#:name name] [#:lang lang] ;; Generate a thunk @code{`(lambda ...)}. ;; @end deffn (define* (make-thunk expr #:key name lang) (let* ((meta '()) (meta (if lang (cons `(language . ,lang) meta) meta)) (meta (if name (cons `(name . ,name) meta) meta))) `(lambda ,meta (lambda-case ((() #f #f #f () ()) ,expr))))) ;; @deffn {Procedure} make-defonce name value ;; Generate a TIL expression that will ensure the toplevel name is defined. ;; If a define needs to be issues the value is @code{(void)}. Generates ;; @example ;; (if (defined? 'a) undefined (define a undefined)) ;; @end example ;; @noindent ;; where @code{undefined} is like @code{(if #f #f)}. ;; @end deffn (define (make-defonce symbol value) `(define ,symbol (if (call (toplevel module-variable) (call (toplevel current-module)) (const ,symbol)) (toplevel ,symbol) ,value))) ;; === Using Prompts ;; @deffn {Procedure} make-handler args body ;; Generate an escape @code{lambda} for a prompt. The continuation arg ;; is not used. @var{args} is a list of lexical references and @var{body} ;; is an expression that may reference the args. ;; @end deffn (define (make-handler args body) "- Procedure: make-handler args body Generate an escape 'lambda' for a prompt. The continuation arg is not used. ARGS is a list of lexical references and BODY is an expression that may reference the args." (call-with-values (lambda () (let iter ((names '()) (gsyms '()) (args args)) (if (null? args) (values (reverse names) (reverse gsyms)) (iter (cons (cadar args) names) (cons (caddar args) gsyms) (cdr args))))) (lambda (names gsyms) `(lambda () (lambda-case ((,(cons 'k names) #f #f #f () ,(cons (genxsym "k") gsyms)) ,body)))))) ;; @deffn {Procedure} with-escape tag-ref body ;; @deffnx {Procedure} with-escape/arg tag-ref body ;; @deffnx {Procedure} with-escape/expr tag-ref body ;; This is used to generate return and break where break is passed '(void). ;; @var{tag-ref} is of the form @code{(lexical name gensym)} and ;; @var{expr} is an expression. ;; @end deffn (define (with-escape/handler tag-ref body hdlr) (let ((tag-name (cadr tag-ref)) (tag-gsym (caddr tag-ref))) `(let (,tag-name) (,tag-gsym) ((primcall make-prompt-tag (const ,tag-name))) (prompt #t ,tag-ref ,body ,hdlr)))) (define (with-escape/arg tag-ref body) (let ((arg-gsym (genxsym "arg"))) (with-escape/handler tag-ref body `(lambda () (lambda-case (((k arg) #f #f #f () (,(genxsym "k") ,arg-gsym)) (lexical arg ,arg-gsym))))))) (define (with-escape/expr tag-ref body expr) (with-escape/handler tag-ref body `(lambda () (lambda-case (((k) #f #f #f () (,(genxsym "k"))) ,expr))))) (define (with-escape tag-ref body) (with-escape/expr tag-ref body '(void))) ;; @deffn {Procedure} block expr-or-expr-list => expr | (seq ex1 (seq ... exN)) ;; Return an expression or build a seq-train returning last expression. ;; @end deffn (define (block expr-or-expr-list) (if (pair? (car expr-or-expr-list)) ;; expr list (let iter ((xl expr-or-expr-list)) (if (null? (cdr xl)) (car xl) `(seq ,(car xl) ,(iter (cdr xl))))) expr-or-expr-list)) ;; @deffn {Procedure} vblock expr-list => (seq ex1 (seq ... (void))) ;; Return an expression or build a seq-train returning undefined. ;; @end deffn (define (vblock expr-list) "- Procedure: vblock expr-list => (seq ex1 (seq ... (void))) Return an expression or build a seq-train returning undefined." (let iter ((xl expr-list)) (if (null? xl) '(void) `(seq ,(car xl) ,(iter (cdr xl)))))) ;; @deffn {Procedure} lookup-gensym name dict [label] => gensym ;; lookup up nearest parent lexical and return gensym ;; (lookup-gensym "foo" dict) => JS~1234 ;; (lookup-gensym "foo" dict #:label "oloop") => JS~432 ;; @end deffn (define* (lookup-gensym name dict #:key label) "- Procedure: lookup-gensym name dict [label] => gensym lookup up nearest parent lexical and return gensym (lookup-gensym \"foo\" dict) => JS~1234 (lookup-gensym \"foo\" dict #:label \"oloop\") => JS~432" (if label (let iter ((cdict dict) (pdict (assoc-ref dict '@P))) (if (not pdict) #f (if (and (assoc-ref pdict label) (assoc-ref "~exit" cdict)) (assoc-ref name cdict) (iter pdict (assoc-ref pdict '@P))))) (let* ((sym (nx-lookup name dict))) (if (not sym) (error "javascript: not found:" name)) (caddr sym)))) ;; @deffn {Procedure} make-loop expr body dict ilsym tbody ;; This is a helper procedure for building loops like the following: ;; @example ;; "do" body "where" expr ;; "while" body "do" expr ;; "for" i "in" range "do" body ;; @end example ;; @noindent ;; The argument @var{expr} is the conditional, @var{body} is the code to ;; execute, which may contain @code{abort-to-prompt} given by @code{break} ;; or @code{continue}. ;; The code generated is based on the following pattern: ;; @example ;; (let ((break! (make-prompt-tag 'break)) ;; (continue! (make-prompt-tag 'continue))) ;; (letrec ((iloop (lambda () (body) (if (expr) (iloop)))) ;; (oloop ;; (lambda () ;; (call-with-prompt continue! ;; thunk ;; (lambda (k) (if (expr) (oloop))))))) ;; (call-with-prompt break! ;; oloop ;; (lambda (k) (if #f #f)))))) ;; @end example ;; @noindent ;; where @code{break!} and @code{continue!} are lexicals generated for ;; the code and @code{thunk} is @* ;; @code{(lambda () (iloop))} for do-while and @* ;; @code{(lambda () (if (expr) (iloop)))} for while-do. ;; @end deffn ;; TODO #:key (break "break") (continue "continue") (define* (make-loop expr body dict ilsym tbody) "- Procedure: make-loop expr body dict ilsym tbody This is a helper procedure for building loops like the following: \"do\" body \"where\" expr \"while\" body \"do\" expr \"for\" i \"in\" range \"do\" body The argument EXPR is the conditional, BODY is the code to execute, which may contain 'abort-to-prompt' given by 'break' or 'continue'. The code generated is based on the following pattern: (let ((break! (make-prompt-tag 'break)) (continue! (make-prompt-tag 'continue))) (letrec ((iloop (lambda () (body) (if (expr) (iloop)))) (oloop (lambda () (call-with-prompt continue! thunk (lambda (k) (if (expr) (oloop))))))) (call-with-prompt break! oloop (lambda (k) (if #f #f)))))) where 'break!' and 'continue!' are lexicals generated for the code and 'thunk' is '(lambda () (iloop))' for do-while and '(lambda () (if (expr) (iloop)))' for while-do." (let* ((olsym (genxsym "oloop")) (bsym (lookup-gensym "break" dict)) (csym (lookup-gensym "continue" dict)) (icall `(call (lexical iloop ,ilsym))) (ocall `(call (lexical oloop ,olsym))) (iloop (make-thunk `(seq ,body (if ,expr ,icall (void))) #:name 'iloop)) (ohdlr `(lambda () (lambda-case (((k) #f #f #f () (,(genxsym "k"))) (if ,expr ,ocall (void)))))) (oloop (make-thunk `(prompt #t (lexical continue ,csym) ,tbody ,ohdlr) #:name 'oloop)) (hdlr `(lambda () (lambda-case (((k) #f #f #f () (,(genxsym "k"))) (void)))))) `(let (break continue) (,bsym ,csym) ((primcall make-prompt-tag (const break)) (primcall make-prompt-tag (const continue))) (letrec (iloop oloop) (,ilsym ,olsym) (,iloop ,oloop) (prompt #t (lexical break ,bsym) ,ocall ,hdlr))))) ;; @deffn {Procedure} make-do-while expr body dict ;; This generates code for do-while loops where @var{expr} is the condtional ;; expression, @var{body} is the body, @var{dict} is the scope dictionary ;; which must contain the labels for @code{break} and @code{continue}. ;; @end deffn (define (make-do-while expr body dict) "- Procedure: make-do-while expr body dict This generates code for do-while loops where EXPR is the condtional expression, BODY is the body, DICT is the scope dictionary which must contain the labels for 'break' and 'continue'." (let ((ilsym (genxsym "iloop"))) (make-loop expr body dict ilsym `(call (lexical iloop ,ilsym))))) ;; @deffn {Procedure} make-while expr body dict ;; This generates code for the following source: ;; where @var{expr} is the condtional expression, @var{body} is the body, ;; and is the scope dictionary which must contain the labels for ;; @code{break} and @code{continue}. ;; @end deffn (define (make-while expr body dict) "- Procedure: make-while expr body dict This generates code for the following source: where EXPR is the condtional expression, BODY is the body, and is the scope dictionary which must contain the labels for 'break' and 'continue'." (let ((ilsym (genxsym "iloop"))) (make-loop expr body dict ilsym `(if ,expr (call (lexical iloop ,ilsym)) (void))))) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/README0000644000175100000240000000612513605250515017133 0ustar mwettedialoutnyacc/lang/README Copyright (C) 2015-2019 Matthew R. Wette Copying and distribution of this file, with or without modification, are permitted in any medium without royalty provided the copyright notice and this notice are preserved. This file is offered as-is, without any warranty. The intention of this directory is to provide parsers for languages. The parsers will be built with attributed grammar semantics. The parse tree will be in SXML format. # Manifest File | Description ----------------|------------ README | This file TMPL | directory of template files for new parsers | nx-devel.texi | documentation for "NX" languages nx-lib.scm | run-time library for nx-languages nx-load.scm | nx-util.scm | compile-time utilities for nx-languages | c99 | demo and test routines for the C99 parser ffi-help | demo and test routines for the FFI helper | calc | calc demo parser and interpreter | javascript | parser and partial interpreter octave | parser and partial interpreter for Octave (like Matlab) tcl | parser and partial interpreter for TCL | ecmascript | immature replacment parser for Guile's emcascript julia | partial parser for the Julia langauge lua | partial parser for the Lua language python | partial parser for python # Examples The examples should compile with 2.0.13 and later. The typical contents are: mach.scm the grammar specification, dev parser and table generator mach.d a directory containing files of actions and tables generated from procedures in mach.scm body.scm code included in parser.scm and sometimes mach.scm parser.scm provides the parser procedure, includes mach.d/* and body.scm pprint.scm pretty-printer Umach.scm code to rerun table generation and generate parsers When Umach.scm is run it may generate: ,file.txt file parser output tables, for debugging ,expr.txt expression parser output tables, for debugging The output is typically an AST with SXML syntax. This has the grammar @example sexp => (symbol expr ...) expr => sexp | string @end example @noindent That is, the tree consists of s-expressions with the first element always symbol. The first symbol in such a list may be referred to as the @dfn{tag}. The remaining elements are either lists or text strings. The parsers will identifty numbers for example, but they will appear as symbols with the source text string (e.g., @code{(float "2.13e4")}). Tags may not consist of any of the characters @code{!"#$%&'()*+,/;<=>?@@[\]^`@{|@}~,} and may not start with @code{.} or @code{-}. The second element of a s-expression can be a list with the special tag @code{@@}. This indicates a list of attributes. For example, if a parser returned the following s-exp @example (add (fixed "12") (float "2.3")) @end example @noindent then a type checker may convert it to the following: @example (add (@ (type "float")) (fixed-to-float (fixed "12")) (float "2.3")) @end example element conventions: (name "." ident) -> `(sel ,$3 ,$1) selection (expr "+" expr) -> `(add ,$1 ,$3) arithmatic (ex ":" ex ":" ex) -> `(colon ,$1 ,$5 ,$3) (id "=" ex) -> `(assign ,$1 ,$3) (id "+=" ex) -> `(add-assign ,$1 ,$3) nyacc-1.00.2/examples/nyacc/lang/calc/0000755000175100000240000000000013605250515017151 5ustar mwettedialoutnyacc-1.00.2/examples/nyacc/lang/calc/calc.scm0000644000175100000240000000317313605250515020563 0ustar mwettedialout;; calc.scm - calculator ;; ;; Copyright (C) 2015,2017,2019 Matthew R. Wette ;; ;; Copying and distribution of this file, with or without modification, ;; are permitted in any medium without royalty provided the copyright ;; notice and this notice are preserved. This file is offered as-is, ;; without any warranty. ;;; Usage: ;; $ guile calc.scm ;; > 2 + 2 ;; 4 ;; See the NYACC User's Manual for further information. ;;; Code: (use-modules (nyacc lalr)) (use-modules (nyacc lex)) (use-modules (nyacc parse)) (define (next) (newline) (display "> ") (force-output)) (define spec (lalr-spec (prec< (left "+" "-") (left "*" "/")) (start prog) (grammar (prog (stmt-list)) (stmt-list (stmt) (stmt-list "\n" stmt)) (stmt ($empty ($$ (next))) (expr ($$ (display $1) (next))) (assn ($$ (module-define! (current-module) (car $1) (cdr $1)) (display (cdr $1)) (next)))) (expr (expr "+" expr ($$ (+ $1 $3))) (expr "-" expr ($$ (- $1 $3))) (expr "*" expr ($$ (* $1 $3))) (expr "/" expr ($$ (/ $1 $3))) ($fixed ($$ (string->number $1))) ($float ($$ (string->number $1))) ($ident ($$ (module-ref (current-module) (string->symbol $1)))) ("(" expr ")" ($$ $2))) (assn ($ident "=" expr ($$ (cons (string->symbol $1) $3))))))) (define mach (make-lalr-machine spec)) (define mtab (lalr-match-table mach)) (define gen-lexer (make-lexer-generator mtab #:space-chars " \t")) ;; ^ Define space chars to not include "\n" (define raw-parse (make-lalr-parser mach)) (define (parse) (raw-parse (gen-lexer) #:debug #f)) (next) (parse) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/calc/mach.scm0000644000175100000240000000460713605250515020574 0ustar mwettedialout;; mach.scm - calculator ;; ;; Copyright (C) 2019 Matthew R. Wette ;; ;; Copying and distribution of this file, with or without modification, ;; are permitted in any medium without royalty provided the copyright ;; notice and this notice are preserved. This file is offered as-is, ;; without any warranty. ;;; Notes: ;; This is the same grammar as in the calc.scm file, but instead of ;; immediate execution, the parse tables are generated. ;;; Code: (define-module (nyacc lang calc mach) #:export (full-spec full-mach stmt-spec stmt-mach gen-calc-files) #:use-module (nyacc lalr) #:use-module (nyacc lex) #:use-module (nyacc parse)) (define full-spec (lalr-spec (prec< (left "+" "-") (left "*" "/")) (start prog) (grammar (prog (stmt-list ($$ (tl->list $1)))) (stmt-list (stmt ($$ (make-tl 'stmt-list $1))) (stmt-list stmt ($$ (tl-append $1 $2)))) (stmt ("\n" ($$ `(empty-stmt))) (expr "\n" ($$ `(expr-stmt ,$1))) (assn "\n" ($$ `(assn-stmt ,$1)))) (expr (expr "+" expr ($$ `(add ,$1 ,$3))) (expr "-" expr ($$ `(sub ,$1 ,$3))) (expr "*" expr ($$ `(mul ,$1 ,$3))) (expr "/" expr ($$ `(div ,$1 ,$3))) ($fixed ($$ `(num ,$1))) ($float ($$ `(num ,$1))) ($ident ($$ `(ident ,$1))) ("(" expr ")" ($$ $2))) (assn ($ident "=" expr ($$ `(assn (ident ,$1) ,$3))))))) ;; Build an automaton for the full language (i.e., list of statements). ;; This is hashed, so tokens are represented by integers. (define full-mach (compact-machine (hashify-machine (make-lalr-machine full-spec)))) ;; Build an automaton for expressions to be used as Guile language. ;; Guile wants to see one statement at a time, so replace 'prog' start ;; with 'stmt' start. (define stmt-spec (restart-spec full-spec 'stmt)) ;; For purpose of demo, do not hashify the interactive one. ;; But the machine must have compacted tables! (define stmt-mach (compact-machine (make-lalr-machine stmt-spec))) ;; Procedure to generate actions and tables. (define (gen-calc-files) (write-lalr-actions full-mach "mach.d/calc-full-act.scm" #:prefix "calc-full-") (write-lalr-tables full-mach "mach.d/calc-full-tab.scm" #:prefix "calc-full-") (write-lalr-actions stmt-mach "mach.d/calc-stmt-act.scm" #:prefix "calc-stmt-") (write-lalr-tables stmt-mach "mach.d/calc-stmt-tab.scm" #:prefix "calc-stmt-") ) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/calc/full.txt0000644000175100000240000001343013605250515020655 0ustar mwettedialout0 $start => prog 1 prog => stmt-list 2 stmt-list => stmt 3 stmt-list => stmt-list stmt 4 stmt => "\n" 5 stmt => expr "\n" 6 stmt => assn "\n" 7 expr => expr "+" expr 8 expr => expr "-" expr 9 expr => expr "*" expr 10 expr => expr "/" expr 11 expr => '$fixed 12 expr => '$float 13 expr => '$ident 14 expr => "(" expr ")" 15 assn => '$ident "=" expr 0: $start => . prog prog => . stmt-list stmt-list => . stmt stmt-list => . stmt-list stmt stmt => . "\n" stmt => . expr "\n" stmt => . assn "\n" expr => . expr "+" expr expr => . expr "-" expr expr => . expr "*" expr expr => . expr "/" expr expr => . '$fixed expr => . '$float expr => . '$ident expr => . "(" expr ")" assn => . '$ident "=" expr "(" => shift 1 '$ident => shift 2 '$float => shift 3 '$fixed => shift 4 assn => shift 5 expr => shift 6 "\n" => shift 7 stmt => shift 8 stmt-list => shift 9 prog => shift 10 1: expr => "(" . expr ")" expr => . expr "+" expr expr => . expr "-" expr expr => . expr "*" expr expr => . expr "/" expr expr => . '$fixed expr => . '$float expr => . '$ident expr => . "(" expr ")" "(" => shift 1 '$ident => shift 19 '$float => shift 3 '$fixed => shift 4 expr => shift 20 2: assn => '$ident . "=" expr expr => '$ident . "=" => shift 18 $default => reduce 13 3: expr => '$float . $default => reduce 12 4: expr => '$fixed . $default => reduce 11 5: stmt => assn . "\n" "\n" => shift 17 6: expr => expr . "/" expr expr => expr . "*" expr expr => expr . "-" expr expr => expr . "+" expr stmt => expr . "\n" "\n" => shift 12 "+" => shift 13 "-" => shift 14 "*" => shift 15 "/" => shift 16 7: stmt => "\n" . $default => reduce 4 8: stmt-list => stmt . $default => reduce 2 9: stmt-list => stmt-list . stmt stmt => . "\n" stmt => . expr "\n" stmt => . assn "\n" expr => . expr "+" expr expr => . expr "-" expr expr => . expr "*" expr expr => . expr "/" expr expr => . '$fixed expr => . '$float expr => . '$ident expr => . "(" expr ")" assn => . '$ident "=" expr prog => stmt-list . "(" => shift 1 '$ident => shift 2 '$float => shift 3 '$fixed => shift 4 assn => shift 5 expr => shift 6 "\n" => shift 7 stmt => shift 11 $default => reduce 1 10: $start => prog . '$end => accept 0 11: stmt-list => stmt-list stmt . $default => reduce 3 12: stmt => expr "\n" . $default => reduce 5 13: expr => expr "+" . expr expr => . expr "+" expr expr => . expr "-" expr expr => . expr "*" expr expr => . expr "/" expr expr => . '$fixed expr => . '$float expr => . '$ident expr => . "(" expr ")" "(" => shift 1 '$ident => shift 19 '$float => shift 3 '$fixed => shift 4 expr => shift 26 14: expr => expr "-" . expr expr => . expr "+" expr expr => . expr "-" expr expr => . expr "*" expr expr => . expr "/" expr expr => . '$fixed expr => . '$float expr => . '$ident expr => . "(" expr ")" "(" => shift 1 '$ident => shift 19 '$float => shift 3 '$fixed => shift 4 expr => shift 25 15: expr => expr "*" . expr expr => . expr "+" expr expr => . expr "-" expr expr => . expr "*" expr expr => . expr "/" expr expr => . '$fixed expr => . '$float expr => . '$ident expr => . "(" expr ")" "(" => shift 1 '$ident => shift 19 '$float => shift 3 '$fixed => shift 4 expr => shift 24 16: expr => expr "/" . expr expr => . expr "+" expr expr => . expr "-" expr expr => . expr "*" expr expr => . expr "/" expr expr => . '$fixed expr => . '$float expr => . '$ident expr => . "(" expr ")" "(" => shift 1 '$ident => shift 19 '$float => shift 3 '$fixed => shift 4 expr => shift 23 17: stmt => assn "\n" . $default => reduce 6 18: assn => '$ident "=" . expr expr => . expr "+" expr expr => . expr "-" expr expr => . expr "*" expr expr => . expr "/" expr expr => . '$fixed expr => . '$float expr => . '$ident expr => . "(" expr ")" "(" => shift 1 '$ident => shift 19 '$float => shift 3 '$fixed => shift 4 expr => shift 22 19: expr => '$ident . $default => reduce 13 20: expr => expr . "/" expr expr => expr . "*" expr expr => expr . "-" expr expr => expr . "+" expr expr => "(" expr . ")" ")" => shift 21 "+" => shift 13 "-" => shift 14 "*" => shift 15 "/" => shift 16 21: expr => "(" expr ")" . $default => reduce 14 22: expr => expr . "/" expr expr => expr . "*" expr expr => expr . "-" expr expr => expr . "+" expr assn => '$ident "=" expr . "+" => shift 13 "-" => shift 14 "*" => shift 15 "/" => shift 16 $default => reduce 15 23: expr => expr . "/" expr expr => expr . "*" expr expr => expr . "-" expr expr => expr . "+" expr expr => expr "/" expr . $default => reduce 10 ["+" => shift 13] REMOVED by precedence ["-" => shift 14] REMOVED by precedence ["*" => shift 15] REMOVED by associativity ["/" => shift 16] REMOVED by associativity 24: expr => expr . "/" expr expr => expr . "*" expr expr => expr . "-" expr expr => expr . "+" expr expr => expr "*" expr . $default => reduce 9 ["+" => shift 13] REMOVED by precedence ["-" => shift 14] REMOVED by precedence ["*" => shift 15] REMOVED by associativity ["/" => shift 16] REMOVED by associativity 25: expr => expr . "/" expr expr => expr . "*" expr expr => expr . "-" expr expr => expr . "+" expr expr => expr "-" expr . "*" => shift 15 "/" => shift 16 $default => reduce 8 ["+" => shift 13] REMOVED by associativity ["-" => shift 14] REMOVED by associativity ["*" => reduce 8] REMOVED by precedence ["/" => reduce 8] REMOVED by precedence 26: expr => expr . "/" expr expr => expr . "*" expr expr => expr . "-" expr expr => expr . "+" expr expr => expr "+" expr . "*" => shift 15 "/" => shift 16 $default => reduce 7 ["+" => shift 13] REMOVED by associativity ["-" => shift 14] REMOVED by associativity ["*" => reduce 7] REMOVED by precedence ["/" => reduce 7] REMOVED by precedence nyacc-1.00.2/examples/nyacc/lang/calc/Umach.scm0000644000175100000240000000146413605250515020717 0ustar mwettedialout;; Umach.scm - update calculator automata ;; ;; Copyright (C) 2018 Matthew R. Wette ;; ;; Copying and distribution of this file, with or without modification, ;; are permitted in any medium without royalty provided the copyright ;; notice and this notice are preserved. This file is offered as-is, ;; without any warranty. (use-modules (nyacc lang calc mach)) (use-modules (nyacc lalr)) (gen-calc-files) (compile-file "parser.scm") (with-output-to-file "full.txt" (lambda () (pp-lalr-grammar full-spec) (pp-lalr-machine full-mach))) (with-output-to-file "stmt.txt" (lambda () (pp-lalr-grammar stmt-spec) (pp-lalr-machine stmt-mach))) ;; to see equivalent bison input file ;;(use-modules (nyacc export)) ;;(with-output-to-file "calc.y" ;; (lambda () (lalr->bison spec))) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/calc/mach.d/0000755000175100000240000000000013605250515020303 5ustar mwettedialoutnyacc-1.00.2/examples/nyacc/lang/calc/mach.d/calc-stmt-tab.scm0000644000175100000240000000456613605250515023455 0ustar mwettedialout;; mach.d/calc-stmt-tab.scm (define calc-stmt-mtab '(($start . stmt) ("=" . $:=) (")" . #{$:\x29;}#) ("(" . #{$:\x28;}#) ($ident . $ident) ($float . $float) ($fixed . $fixed) ("/" . $:/) ("*" . $:*) ("-" . $:-) ("+" . $:+) ("\n" . #{$:\xa;}#) ($error . $error) ($end . $end))) (define calc-stmt-ntab '((assn . assn) (expr . expr) (stmt . stmt) (stmt-list . stmt-list) (prog . prog))) (define calc-stmt-len-v #(1 1 1 2 1 2 2 3 3 3 3 1 1 1 3 3)) (define calc-stmt-rto-v #($start prog stmt-list stmt-list stmt stmt stmt expr expr expr expr expr expr expr expr assn)) (define calc-stmt-pat-v #(((#{$:\x28;}# shift . 1) ($ident shift . 2) ($float shift . 3) ($fixed shift . 4) (assn shift . 5) (expr shift . 6) (#{$:\xa;}# shift . 7) (stmt shift . 8)) ((#{$:\x28;}# shift . 1) ($ident shift . 16) ($float shift . 3) ($fixed shift . 4) (expr shift . 17)) (($:= shift . 15) ($default reduce . 13)) (($default reduce . 12)) (($default reduce . 11)) ((#{$:\xa;}# shift . 14)) ((#{$:\xa;}# shift . 9) ($:+ shift . 10) ($:- shift . 11) ($:* shift . 12) ($:/ shift . 13)) (($default reduce . 4) ) (($end accept . 0)) (($default reduce . 5)) ((#{$:\x28;}# shift . 1) ($ident shift . 16) ($float shift . 3) ($fixed shift . 4) (expr shift . 23 )) ((#{$:\x28;}# shift . 1) ($ident shift . 16) ($float shift . 3) ($fixed shift . 4) (expr shift . 22)) ((#{$:\x28;}# shift . 1) ($ident shift . 16) ($float shift . 3) ($fixed shift . 4) (expr shift . 21)) ((#{$:\x28;}# shift . 1) ($ident shift . 16) ($float shift . 3) ($fixed shift . 4) (expr shift . 20)) (($default reduce . 6)) ((#{$:\x28;}# shift . 1) ($ident shift . 16) ($float shift . 3) ($fixed shift . 4) (expr shift . 19)) (($default reduce . 13)) ((#{$:\x29;}# shift . 18) ($:+ shift . 10) ($:- shift . 11) ($:* shift . 12) ($:/ shift . 13)) (($default reduce . 14 )) (($:+ shift . 10) ($:- shift . 11) ($:* shift . 12) ($:/ shift . 13) ($default reduce . 15)) (($default reduce . 10)) (($default reduce . 9)) (($:* shift . 12) ($:/ shift . 13) ($default reduce . 8)) (($:* shift . 12 ) ($:/ shift . 13) ($default reduce . 7)))) (define calc-stmt-tables (list (cons 'mtab calc-stmt-mtab) (cons 'ntab calc-stmt-ntab) (cons 'len-v calc-stmt-len-v) (cons 'rto-v calc-stmt-rto-v) (cons 'pat-v calc-stmt-pat-v) )) ;;; end tables nyacc-1.00.2/examples/nyacc/lang/calc/mach.d/calc-full-tab.scm0000644000175100000240000000306613605250515023422 0ustar mwettedialout;; mach.d/calc-full-tab.scm (define calc-full-mtab '(($start . 20) ("=" . 3) (")" . 4) ("(" . 5) ($ident . 6) ($float . 7) ($fixed . 8) ("/" . 9) ("*" . 10) ("-" . 11) ("+" . 12) ("\n" . 13) ($error . 2) ($end . 15))) (define calc-full-ntab '((16 . assn) (17 . expr) (18 . stmt) (19 . stmt-list) (20 . prog))) (define calc-full-len-v #(1 1 1 2 1 2 2 3 3 3 3 1 1 1 3 3)) (define calc-full-rto-v #(#f 20 19 19 18 18 18 17 17 17 17 17 17 17 17 16)) (define calc-full-pat-v #(((5 . 1) (6 . 2) (7 . 3) (8 . 4) (16 . 5) (17 . 6) (13 . 7) (18 . 8) (19 . 9) (20 . 10)) ((5 . 1) (6 . 19) (7 . 3) (8 . 4) (17 . 20)) ((3 . 18) (1 . -13)) ((1 . -12)) ((1 . -11)) ((13 . 17)) ((13 . 12) (12 . 13) (11 . 14) (10 . 15) (9 . 16)) ((1 . -4)) ((1 . -2)) ((5 . 1) (6 . 2) (7 . 3) (8 . 4) (16 . 5) (17 . 6) (13 . 7) (18 . 11) (1 . -1)) ((15 . 0)) ((1 . -3)) ((1 . -5)) ((5 . 1) (6 . 19) (7 . 3) (8 . 4) (17 . 26)) ((5 . 1) (6 . 19) (7 . 3) (8 . 4) (17 . 25)) ((5 . 1) (6 . 19) (7 . 3) (8 . 4) (17 . 24)) ((5 . 1) (6 . 19) (7 . 3) (8 . 4) (17 . 23)) ((1 . -6)) ((5 . 1) (6 . 19) (7 . 3) (8 . 4) (17 . 22)) ((1 . -13)) ((4 . 21) (12 . 13) (11 . 14) (10 . 15) (9 . 16)) ((1 . -14)) ((12 . 13) (11 . 14) (10 . 15) (9 . 16) (1 . -15)) ((1 . -10)) ((1 . -9)) ((10 . 15) (9 . 16) (1 . -8)) ((10 . 15) (9 . 16) (1 . -7)))) (define calc-full-tables (list (cons 'mtab calc-full-mtab) (cons 'ntab calc-full-ntab) (cons 'len-v calc-full-len-v) (cons 'rto-v calc-full-rto-v) (cons 'pat-v calc-full-pat-v) )) ;;; end tables nyacc-1.00.2/examples/nyacc/lang/calc/mach.d/calc-full-act.scm0000644000175100000240000000222213605250515023414 0ustar mwettedialout;; mach.d/calc-full-act.scm (define calc-full-act-v (vector ;; $start => prog (lambda ($1 . $rest) $1) ;; prog => stmt-list (lambda ($1 . $rest) (tl->list $1)) ;; stmt-list => stmt (lambda ($1 . $rest) (make-tl 'stmt-list $1)) ;; stmt-list => stmt-list stmt (lambda ($2 $1 . $rest) (tl-append $1 $2)) ;; stmt => "\n" (lambda ($1 . $rest) `(empty-stmt)) ;; stmt => expr "\n" (lambda ($2 $1 . $rest) `(expr-stmt ,$1)) ;; stmt => assn "\n" (lambda ($2 $1 . $rest) `(assn-stmt ,$1)) ;; expr => expr "+" expr (lambda ($3 $2 $1 . $rest) `(add ,$1 ,$3)) ;; expr => expr "-" expr (lambda ($3 $2 $1 . $rest) `(sub ,$1 ,$3)) ;; expr => expr "*" expr (lambda ($3 $2 $1 . $rest) `(mul ,$1 ,$3)) ;; expr => expr "/" expr (lambda ($3 $2 $1 . $rest) `(div ,$1 ,$3)) ;; expr => '$fixed (lambda ($1 . $rest) `(num ,$1)) ;; expr => '$float (lambda ($1 . $rest) `(num ,$1)) ;; expr => '$ident (lambda ($1 . $rest) `(ident ,$1)) ;; expr => "(" expr ")" (lambda ($3 $2 $1 . $rest) $2) ;; assn => '$ident "=" expr (lambda ($3 $2 $1 . $rest) `(assn (ident ,$1) ,$3)) )) ;;; end tables nyacc-1.00.2/examples/nyacc/lang/calc/mach.d/calc-stmt-act.scm0000644000175100000240000000222213605250515023441 0ustar mwettedialout;; mach.d/calc-stmt-act.scm (define calc-stmt-act-v (vector ;; $start => stmt (lambda ($1 . $rest) $1) ;; prog => stmt-list (lambda ($1 . $rest) (tl->list $1)) ;; stmt-list => stmt (lambda ($1 . $rest) (make-tl 'stmt-list $1)) ;; stmt-list => stmt-list stmt (lambda ($2 $1 . $rest) (tl-append $1 $2)) ;; stmt => "\n" (lambda ($1 . $rest) `(empty-stmt)) ;; stmt => expr "\n" (lambda ($2 $1 . $rest) `(expr-stmt ,$1)) ;; stmt => assn "\n" (lambda ($2 $1 . $rest) `(assn-stmt ,$1)) ;; expr => expr "+" expr (lambda ($3 $2 $1 . $rest) `(add ,$1 ,$3)) ;; expr => expr "-" expr (lambda ($3 $2 $1 . $rest) `(sub ,$1 ,$3)) ;; expr => expr "*" expr (lambda ($3 $2 $1 . $rest) `(mul ,$1 ,$3)) ;; expr => expr "/" expr (lambda ($3 $2 $1 . $rest) `(div ,$1 ,$3)) ;; expr => '$fixed (lambda ($1 . $rest) `(num ,$1)) ;; expr => '$float (lambda ($1 . $rest) `(num ,$1)) ;; expr => '$ident (lambda ($1 . $rest) `(ident ,$1)) ;; expr => "(" expr ")" (lambda ($3 $2 $1 . $rest) $2) ;; assn => '$ident "=" expr (lambda ($3 $2 $1 . $rest) `(assn (ident ,$1) ,$3)) )) ;;; end tables nyacc-1.00.2/examples/nyacc/lang/calc/parser.scm0000644000175100000240000000640013605250515021151 0ustar mwettedialout;;; nyacc/lang/calc/parser ;; Copyright (C) 2015-2019 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see . (define-module (nyacc lang calc parser) #:export (parse-calc read-calc) ; parse full, read stmt #:use-module (nyacc lalr) #:use-module (nyacc lex) #:use-module (nyacc parse) #:use-module (nyacc lang util)) ;;; Full parser ;; Include the reduction actions that get called when a production ;; rule is reduced. This is a separate file to it could be changed ;; by hand and place in lexical context with routines called. (include-from-path "nyacc/lang/calc/mach.d/calc-full-act.scm") ;; Include the automaton tables. These are used by the parser defined ;; in nyacc/parser.scm. (include-from-path "nyacc/lang/calc/mach.d/calc-full-tab.scm") ;; Generate a lexer. Look in nyacc/lex.scm to see how this is formulated. ;; The object calc-mtab is defined in mach.d/calc-tab.scm. (define gen-full-lexer (make-lexer-generator calc-full-mtab #:space-chars " \t")) ;; The raw parser is a procecure that parses (current-input-port) ;; given a lexical analyzer procedure. See parse-calc below. (define raw-full-parser (make-lalr-parser (acons 'act-v calc-full-act-v calc-full-tables))) ;; This is nominal procedure called by the user. If called with ;; @code{#:debug #t} a trace of parser shifts and reductions will ;; be echoed to (current-error-port). (define* (parse-calc #:key debug) (catch 'nyacc-error (lambda () (raw-full-parser (gen-full-lexer) #:debug debug)) (lambda (key fmt . args) (apply simple-format (current-error-port) fmt args)))) ;;; Stmt parser (include-from-path "nyacc/lang/calc/mach.d/calc-stmt-act.scm") (include-from-path "nyacc/lang/calc/mach.d/calc-stmt-tab.scm") (define gen-stmt-lexer (make-lexer-generator calc-stmt-mtab #:space-chars " \t")) ;; This is interactive so that input does not have to end in eof-object. (define raw-stmt-parser (make-lalr-parser (acons 'act-v calc-stmt-act-v calc-stmt-tables) #:interactive #t)) (define (parse-stmt) (catch 'nyacc-error (lambda () (raw-stmt-parser (gen-stmt-lexer) #:debug #t)) (lambda (key fmt . args) (apply simple-format (current-error-port) fmt args) (newline (current-error-port)) #f))) ;; This is defined for use by Guile's extension language facility. ;; See ../../../language/spec.scm and compiler.scm. (define (read-calc port env) (define (flush-input port) (let loop ((ch (read-char port))) (if (char=? #\newline) #f (loop (read-char port))))) (if (eof-object? (peek-char port)) (read-char port) (let ((elt (with-input-from-port port parse-stmt))) (or elt (flush-input port))))) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/calc/README0000644000175100000240000000236013605250515020032 0ustar mwettedialoutnyacc/lang/README Copyright (C) 2017,2019 Matthew R. Wette Copying and distribution of this file, with or without modification, are permitted in any medium without royalty provided the copyright notice and this notice are preserved. This file is offered as-is, without any warranty. To run the demos in this directory please navigate up do the examples/ directory and source the file env.sh. # Manifest calc.scm interactive parser, quick and dirty $ guile calc.scm > 1 + 2 3 > mach.scm spec for parser; tables in mach.d/ created via $ guile Umach.scm Umach.scm will also generate ,file.txt and ,expr.txt parser.scm parse-calc (for full language) and read-calc for expressions compiler.scm compiles output of read-calc to Tree-IL see spec.scm ../../../language/spec.scm spec file for Guile's language support; see below depends on parser.scm and compiler.scm # Using calc as Guile extension language. Currently, debug is defined in compiler.scm and parser.scm so that you can see the parser and compiler at work. scheme@(guile-user)> ,L calc calc@(guile-user)> 1 + 1 ... $1 = 2 calc@(guile-user)> a = 4 + 4 ... $2 = 8 calc@(guile-user> ,L scheme scheme@(guile-user)> a $3 = 8 Enjoy! nyacc-1.00.2/examples/nyacc/lang/calc/compiler.scm0000644000175100000240000001752013605250515021474 0ustar mwettedialout;;; nyacc/lang/calc/compiler ;; Copyright (C) 2015,2018,2019 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see . ;;; Description: ;; This module provides two methods to compile `calc'S. The first compiles ;; to Tree-IL, and then uses compile to get to CPS. The second compiles to ;; CPS directly. You can pick which implementation is used in the file ;; spec.scm which lives in the language/ directory. ;;; Code: (define-module (nyacc lang calc compiler) #:export (compile-tree-il compile-cps)) (use-modules (sxml match)) (define show-code? #t) ; to show intermediate code in output (use-modules (ice-9 pretty-print)) (define (pp exp) (pretty-print exp #:per-line-prefix " ")) (define (sf fmt . args) (apply simple-format #t fmt args)) ;; === Compile `calc' to Tree-IL ============================================== (use-modules (language tree-il)) (use-modules (system base compile)) (use-modules (sxml fold)) (define (mkseq expr-list) (let loop ((xl expr-list)) (if (null? xl) '((void)) (cons* 'seq (car expr-list) (loop (cdr expr-list)))))) (define (show/til expr) `(seq (call (toplevel display) ,expr) (seq (call (toplevel newline)) (void)))) (define (fup-til tree) (sxml-match tree ((*TOP* ,tree) tree) ((assn-stmt ,assn) assn) ((expr-stmt ,expr) expr) ((empty-stmt) '(void)) ((add ,lt ,rt) `(primcall + ,lt ,rt)) ((sub ,lt ,rt) `(primcall - ,lt ,rt)) ((mul ,lt ,rt) `(primcall * ,lt ,rt)) ((div ,lt ,rt) `(primcall / ,lt ,rt)) ((num ,nv) `(const ,(string->number nv))) ((ident ,name) `(toplevel ,(string->symbol name))) ((assn ,toplevel ,expr) `(seq (define ,(cadr toplevel) ,expr) ,toplevel)) (,otherwise (error "missed" tree)))) (define (compile-tree-il exp env opts) (when show-code? (sf "SXML:\n") (pp exp)) (let* ((xtil (foldt fup-til identity `(*TOP* ,exp))) ; external Tree-IL (itil (parse-tree-il xtil))) ; internal Tree-IL (when show-code? (sf "Tree-IL:\n") (pp xtil)) (values itil env env))) ;; === Compile `calc' to CPS. ================================================== ;; To try this fix the #:compiler key in ../../language/calc/spec.scm ;; unfinished work: use of variables doesn't yet work; 1 + 2 does (use-modules (language cps)) (use-modules (language cps intmap)) (use-modules (language cps with-cps)) (use-modules (language cps utils)) ; counters (use-modules (ice-9 match)) ;; Thanks to Mark Weaver for helping on some of the concepts here. ;; The parameters @code{label-counter} and @code{var-counter} are defined ;; in @code{(cps utils)}; @code{compile-cps} uses also @code{scope-counter}. ;; Within the form @code{with-cps} procedures invoked by $ must return ;; @code{(values cps val)}. ;; sytab (subst in tree-il/compile-cps) is a map of (unique) symbol names ;; to cps variable index. In tree-il the entries are (sym ix boxed?). ;; @deffn {Procedure} cnvt-arg cps exp kc => cps term ;; Convert an expression in the source language to an index. ;; As a side effect add the evaluation to the soup. (???) ;; The continuation @var{kc} here is a procedure @code{(kc cps vx)} that ;; takes the cps and associated variable index for the argument. ;; The coding style here is copied from tree-il/compile-cps.scm. ;; @end deffn (define (cnvt-arg cps exp kc) (with-cps cps (letv arg) (let$ body (kc arg)) (letk karg ($kargs ('arg) (arg) ,body)) ($ (cnvt exp karg)))) ;; @deffn {Procedure} cnvt-argl cps expl kc => cps term. ;; Convert a list of expressions in the source language to a list of (integer) ;; names. As a side effect, generate a string of continuations in the cps to ;; evaluate the arguments and assign to the names. The argument @var{kc} is a ;; continuation procedure of the form @code{(kc cps expl}} where @code{expl} ;; is the converted expression list. ;; @end deffn (define (cnvt-argl cps expl kc) (match expl (() (kc cps '())) ((exp . expl) (cnvt-arg cps exp (lambda (cps name) (cnvt-argl cps expl (lambda (cps namel) (kc cps (cons name namel))))))))) ;; @deffn {Procedure} mkrecv cps kx ;; @end deffn (define (mkrecv cps kx) (with-cps cps (letv res) (letk ky ($kreceive (list res) 'rest kx)) ky)) (define (mktop sym) (assq-ref '((add . +) (sub . -) (mul . *) (div . /)) sym)) ;; @deffn {Procedure} cnvt cps exp kx ;; @var{kx} is the cps-index of the continuation for the expression. ;; @end deffn (define (cnvt cps exp kx) ;; => (values cps term) (match exp (`(num ,value) (let ((numval (string->number value))) ;; Constants are legal expressions in $continue term. (values cps (build-term ($continue kx #f ($const numval)))))) (`(ident ,name) (cnvt cps `(sym ,(string->symbol name)) kx)) (`(sym ,sym) (with-cps cps ;; Here we create an identifier for symbol and #t, and then use ;; 'resolve to generate a boxed object for the top-level identifier. ($ (with-cps-constants ((sym sym) (t #t)) (build-term ($continue kx #f ($primcall 'resolve (sym t)))))))) (`(unbox ,box) ; where box is a top-level var (with-cps cps (letv bx) ; ident returns var object (letk kc ($kargs ('bx) (bx) ($continue kx #f ($primcall 'box-ref (bx))))) ($ (cnvt box kc)))) ; cnvt id to box and continue (((or 'add 'sub 'mul 'div) lt rt) ;; This is basically from tree-il/compile-cps.scm. ;; The $call must continue to a $ktail or $kreceive. (cnvt-argl cps (list `(unbox (sym ,(mktop (car exp)))) lt rt) (match-lambda* ((cps (proc . args)) (call-with-values (lambda () ;; If not a $ktail, then wrap in a $kreceive. (match (intmap-ref cps kx) (($ $ktail) (values cps kx)) (else (mkrecv cps kx)))) (lambda (cps kx) (with-cps cps (letv res) (build-term ($continue kx #f ($call proc args)))))))))) (`(assn-stmt (assn (ident ,name) ,expr)) (newline) (sf "name:\n") (pp name) (sf "expr:\n") (pp expr) (sleep 1) (newline) (error "not done yet")) (`(expr-stmt ,expr) (cnvt cps expr kx)) (_ (error "missed" exp)))) (define (calc->cps exp) ;; => cps (parameterize ((label-counter 0) (var-counter 0)) (with-cps empty-intmap (letv init) ; variable for closure (???) (letk kinit ,#f) ; reserve ix 0 for program start (letk ktail ($ktail)) ; like halt in Kennedy paper ? (let$ body (cnvt exp ktail)) ; term for @var{exp} (letk kbody ($kargs () () ,body)) ; it's corresponding continuation (letk kclause ; thunk clause for program ($kclause ('() '() #f '() #f) kbody #f)) ($ ((lambda (cps) (let ((init (build-cont ($kfun #f '() init ktail kclause)))) ;; Set the initial thunk-continuation at index 0 and return ;; a persistent cps. (See wingolog blog post on intmaps.) (persistent-intmap (intmap-replace! cps kinit init))))))))) (define (showit cps) (for-each (lambda (x) (sf " ~S\n" x)) (intmap-fold-right acons cps '()))) (define (compile-cps exp env opts) (when show-code? (sf "SXML:\n") (pp exp)) (let* ((code (calc->cps exp))) (when show-code? (sf "CPS:\n") (showit code)) (values code env env))) ;; Local Variables: ;; eval: (put 'cnvt-arg 'scheme-indent-function 2) ;; eval: (put 'cnvt-argl 'scheme-indent-function 2) ;; End: ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/calc/stmt.txt0000644000175100000240000001210713605250515020702 0ustar mwettedialout0 $start => stmt 1 prog => stmt-list 2 stmt-list => stmt 3 stmt-list => stmt-list stmt 4 stmt => "\n" 5 stmt => expr "\n" 6 stmt => assn "\n" 7 expr => expr "+" expr 8 expr => expr "-" expr 9 expr => expr "*" expr 10 expr => expr "/" expr 11 expr => '$fixed 12 expr => '$float 13 expr => '$ident 14 expr => "(" expr ")" 15 assn => '$ident "=" expr 0: $start => . stmt stmt => . "\n" stmt => . expr "\n" stmt => . assn "\n" expr => . expr "+" expr expr => . expr "-" expr expr => . expr "*" expr expr => . expr "/" expr expr => . '$fixed expr => . '$float expr => . '$ident expr => . "(" expr ")" assn => . '$ident "=" expr "(" => shift 1 '$ident => shift 2 '$float => shift 3 '$fixed => shift 4 assn => shift 5 expr => shift 6 "\n" => shift 7 stmt => shift 8 1: expr => "(" . expr ")" expr => . expr "+" expr expr => . expr "-" expr expr => . expr "*" expr expr => . expr "/" expr expr => . '$fixed expr => . '$float expr => . '$ident expr => . "(" expr ")" "(" => shift 1 '$ident => shift 16 '$float => shift 3 '$fixed => shift 4 expr => shift 17 2: assn => '$ident . "=" expr expr => '$ident . "=" => shift 15 $default => reduce 13 3: expr => '$float . $default => reduce 12 4: expr => '$fixed . $default => reduce 11 5: stmt => assn . "\n" "\n" => shift 14 6: expr => expr . "/" expr expr => expr . "*" expr expr => expr . "-" expr expr => expr . "+" expr stmt => expr . "\n" "\n" => shift 9 "+" => shift 10 "-" => shift 11 "*" => shift 12 "/" => shift 13 7: stmt => "\n" . $default => reduce 4 8: $start => stmt . '$end => accept 0 9: stmt => expr "\n" . $default => reduce 5 10: expr => expr "+" . expr expr => . expr "+" expr expr => . expr "-" expr expr => . expr "*" expr expr => . expr "/" expr expr => . '$fixed expr => . '$float expr => . '$ident expr => . "(" expr ")" "(" => shift 1 '$ident => shift 16 '$float => shift 3 '$fixed => shift 4 expr => shift 23 11: expr => expr "-" . expr expr => . expr "+" expr expr => . expr "-" expr expr => . expr "*" expr expr => . expr "/" expr expr => . '$fixed expr => . '$float expr => . '$ident expr => . "(" expr ")" "(" => shift 1 '$ident => shift 16 '$float => shift 3 '$fixed => shift 4 expr => shift 22 12: expr => expr "*" . expr expr => . expr "+" expr expr => . expr "-" expr expr => . expr "*" expr expr => . expr "/" expr expr => . '$fixed expr => . '$float expr => . '$ident expr => . "(" expr ")" "(" => shift 1 '$ident => shift 16 '$float => shift 3 '$fixed => shift 4 expr => shift 21 13: expr => expr "/" . expr expr => . expr "+" expr expr => . expr "-" expr expr => . expr "*" expr expr => . expr "/" expr expr => . '$fixed expr => . '$float expr => . '$ident expr => . "(" expr ")" "(" => shift 1 '$ident => shift 16 '$float => shift 3 '$fixed => shift 4 expr => shift 20 14: stmt => assn "\n" . $default => reduce 6 15: assn => '$ident "=" . expr expr => . expr "+" expr expr => . expr "-" expr expr => . expr "*" expr expr => . expr "/" expr expr => . '$fixed expr => . '$float expr => . '$ident expr => . "(" expr ")" "(" => shift 1 '$ident => shift 16 '$float => shift 3 '$fixed => shift 4 expr => shift 19 16: expr => '$ident . $default => reduce 13 17: expr => expr . "/" expr expr => expr . "*" expr expr => expr . "-" expr expr => expr . "+" expr expr => "(" expr . ")" ")" => shift 18 "+" => shift 10 "-" => shift 11 "*" => shift 12 "/" => shift 13 18: expr => "(" expr ")" . $default => reduce 14 19: expr => expr . "/" expr expr => expr . "*" expr expr => expr . "-" expr expr => expr . "+" expr assn => '$ident "=" expr . "+" => shift 10 "-" => shift 11 "*" => shift 12 "/" => shift 13 $default => reduce 15 20: expr => expr . "/" expr expr => expr . "*" expr expr => expr . "-" expr expr => expr . "+" expr expr => expr "/" expr . $default => reduce 10 ["+" => shift 10] REMOVED by precedence ["-" => shift 11] REMOVED by precedence ["*" => shift 12] REMOVED by associativity ["/" => shift 13] REMOVED by associativity 21: expr => expr . "/" expr expr => expr . "*" expr expr => expr . "-" expr expr => expr . "+" expr expr => expr "*" expr . $default => reduce 9 ["+" => shift 10] REMOVED by precedence ["-" => shift 11] REMOVED by precedence ["*" => shift 12] REMOVED by associativity ["/" => shift 13] REMOVED by associativity 22: expr => expr . "/" expr expr => expr . "*" expr expr => expr . "-" expr expr => expr . "+" expr expr => expr "-" expr . "*" => shift 12 "/" => shift 13 $default => reduce 8 ["+" => shift 10] REMOVED by associativity ["-" => shift 11] REMOVED by associativity ["*" => reduce 8] REMOVED by precedence ["/" => reduce 8] REMOVED by precedence 23: expr => expr . "/" expr expr => expr . "*" expr expr => expr . "-" expr expr => expr . "+" expr expr => expr "+" expr . "*" => shift 12 "/" => shift 13 $default => reduce 7 ["+" => shift 10] REMOVED by associativity ["-" => shift 11] REMOVED by associativity ["*" => reduce 7] REMOVED by precedence ["/" => reduce 7] REMOVED by precedence nyacc-1.00.2/examples/nyacc/lang/javascript/0000755000175100000240000000000013605250515020415 5ustar mwettedialoutnyacc-1.00.2/examples/nyacc/lang/javascript/mach.scm0000644000175100000240000005212213605250515022033 0ustar mwettedialout;;; lang/javascript/mach.scm ;; Copyright (C) 2015-2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see . (define-module (nyacc lang javascript mach) #:export (javascript-spec javascript-mach javascript-ia-spec javascript-ia-mach dev-parse-js gen-javascript-files) #:use-module (nyacc lang util) #:use-module (nyacc lalr) #:use-module (nyacc parse) #:use-module (nyacc lex) #:use-module (nyacc util) #:use-module ((srfi srfi-43) #:select (vector-map))) ;; This was started with EcmaScript v3 sped. ;; Some v5 2011 items are added as comments. ;; Also added "let". ;; Added: "var" not allowed in blocks, only "let" ;; The 'NoIn' variants are needed to avoid confusing the in operator ;; in a relational expression with the in operator in a for statement. ;; Exclusion of ObjectLiteral and FunctionExpression at statement scope ;; is implemented using precedence for reduction. ;; NSI = "no semi-colon insertion" ;; @subheading Deviations from Ecmascript ;; @itemize ;; @item Supports @code{let} in block context ;; @item @code{var} is not allowed in block context ;; @end itemize (define javascript-spec (lalr-spec (notice (string-append "Copyright (c) 2015-2018 Matthew R. Wette" license-lgpl3+)) (reserve "abstract" "boolean" "byte" "char" "class" "const" "debugger" "double" "enum" "export" "extends" "final" "float" "goto" "implements" "import" "int" "interface" "long" "native" "package" "private" "protected" "public" "short" "static" "super" "synchronized" "throws" "transient" "volatile") (prec< 'then "else") (prec< 'expr 'stmt) (expect 1) ; shift-reduce on ":" (start Program) (grammar (Literal (NullLiteral) (BooleanLiteral) (NumericLiteral) (StringLiteral)) (NullLiteral ("null" ($$ '(NullLiteral)))) (BooleanLiteral ("true" ($$ `(BooleanLiteral ,$1))) ("false" ($$ `(BooleanLiteral ,$1)))) (NumericLiteral ($fixed ($$ `(NumericLiteral ,$1))) ($float ($$ `(NumericLiteral ,$1)))) (StringLiteral ($string ($$ `(StringLiteral ,$1)))) ;;(DoubleStringCharacters ($string)) ;;(SingleStringCharacters ($string)) (Identifier ($ident ($$ `(Identifier ,$1)))) ;; A.3 (PrimaryExpression ("this" ($$ `(PrimaryExpression (this)))) (Identifier ($$ `(PrimaryExpression ,$1))) (Literal ($$ `(PrimaryExpression ,$1))) (ArrayLiteral ($$ `(PrimaryExpression ,$1))) (ObjectLiteral ($$ `(PrimaryExpression ,$1))) ("(" Expression ")" ($$ $2)) ) (ArrayLiteral ("[" Elision "]" ($$ `(ArrayLiteral (Elision ,(number->string $2))))) ("[" "]" ($$ `(ArrayLiteral))) ("[" ElementList "]" ($$ `(ArrayLiteral ,(tl->list $2)))) ("[" ElementList "," Elision "]" ($$ `(ArrayLiteral (Elision ,(number->string $2))))) ("[" ElementList "," "]" ($$ `(ArrayLiteral ,(tl->list $2)))) ) (ElementList (Elision AssignmentExpression ($$ (make-tl 'ElementList `(Elision ,(number->string $2))))) (AssignmentExpression ($$ (make-tl 'ElementList $1))) (ElementList "," Elision AssignmentExpression ($$ (tl-append $1 `(Elision ,(number->string $3)) $4))) (ElementList "," AssignmentExpression ($$ (tl-append $1 $3))) ) (Elision ("," ($$ 1)) (Elision "," ($$ (1+ $1))) ) (ObjectLiteral ("{" "}" ($prec 'expr) ($$ `(ObjectLiteral))) ("{" PropertyNameAndValueList "}" ($prec 'expr) ($$ `(ObjectLiteral ,(tl->list $2)))) ("{" PropertyNameAndValueList "," "}" ($prec 'expr) ($$ `(ObjectLiteral ,(tl->list $2)))) ) (PropertyNameAndValueList (PropertyName ":" AssignmentExpression ($$ (make-tl `PropertyNameAndValueList `(PropertyNameAndValue ,$1 ,$3)))) (PropertyNameAndValueList "," PropertyName ":" AssignmentExpression ($$ (tl-append $1 `(PropertyNameAndValue ,$3 ,$5)))) ) ;; from v5.1 #| (PropertyAssignment (PropertyName ":" AssignmentExpression) ("get" PropertyName "(" ")" "{" FunctionBody "}") ("set" PropertyName "(" PropertySetParametersList ")" "{" FunctionBody "}") ) |# (PropertyName (Identifier) (StringLiteral) (NumericLiteral) ) (MemberExpression (PrimaryExpression) (FunctionExpression) (MemberExpression "[" Expression "]" ($$ `(ooa-ref ,$1 ,$3))) (MemberExpression "." Identifier ($$ `(obj-ref ,$1 ,$3))) ("new" MemberExpression Arguments ($$ `(new ,$2 ,$3))) ) (NewExpression (MemberExpression) ("new" NewExpression ($$ `(new ,$2))) ) (CallExpression (MemberExpression Arguments ($$ `(CallExpression ,$1 ,$2))) (CallExpression Arguments ($$ `(CallExpression ,$1 ,$2))) (CallExpression "[" Expression "]" ($$ `(ooa-ref ,$1 ,$3))) (CallExpression "." Identifier ($$ `(obj-ref ,$1 ,$3))) ) (Arguments ("(" ")" ($$ '(ArgumentList))) ("(" ArgumentList ")" ($$ (tl->list $2))) ) (ArgumentList (AssignmentExpression ($$ (make-tl 'ArgumentList $1))) (ArgumentList "," AssignmentExpression ($$ (tl-append $1 $3))) ) (LeftHandSideExpression (NewExpression) (CallExpression) ) (PostfixExpression (LeftHandSideExpression) (LeftHandSideExpression ($$ (NSI)) "++" ($$ `(post-inc ,$1))) (LeftHandSideExpression ($$ (NSI)) "--" ($$ `(post-dec ,$1))) ) (UnaryExpression (PostfixExpression) ("delete" UnaryExpression ($$ `(delete ,$2))) ("void" UnaryExpression ($$ `(void ,$2))) ("typeof" UnaryExpression ($$ `(typeof ,$2))) ("++" UnaryExpression ($$ `(pre-inc ,$2))) ("--" UnaryExpression ($$ `(pre-dec ,$2))) ("+" UnaryExpression ($$ `(pos ,$2))) ("-" UnaryExpression ($$ `(neg ,$2))) ("~" UnaryExpression ($$ `(bitwise-not?? ,$2))) ("!" UnaryExpression ($$ `(not ,$2))) ) (MultiplicativeExpression (UnaryExpression) (MultiplicativeExpression "*" UnaryExpression ($$ `(mul ,$1 ,$3))) (MultiplicativeExpression "/" UnaryExpression ($$ `(div ,$1 ,$3))) (MultiplicativeExpression "%" UnaryExpression ($$ `(mod ,$1 ,$3))) ) (AdditiveExpression (MultiplicativeExpression) (AdditiveExpression "+" MultiplicativeExpression ($$ `(add ,$1 ,$3))) (AdditiveExpression "-" MultiplicativeExpression ($$ `(sub ,$1 ,$3))) ) (ShiftExpression (AdditiveExpression) (ShiftExpression "<<" AdditiveExpression ($$ `(lshift ,$1 ,$3))) (ShiftExpression ">>" AdditiveExpression ($$ `(rshift ,$1 ,$3))) (ShiftExpression ">>>" AdditiveExpression ($$ `(rrshift ,$1 ,$3))) ) (RelationalExpression (ShiftExpression) (RelationalExpression "<" ShiftExpression ($$ `(lt ,$1 ,$3))) (RelationalExpression ">" ShiftExpression ($$ `(gt ,$1 ,$3))) (RelationalExpression "<=" ShiftExpression ($$ `(le ,$1 ,$3))) (RelationalExpression ">=" ShiftExpression ($$ `(ge ,$1 ,$3))) (RelationalExpression "instanceof" ShiftExpression ($$ `(instanceof ,$1 ,$3))) (RelationalExpression "in" ShiftExpression ($$ `(in ,$1 ,$3))) ) (RelationalExpressionNoIn (ShiftExpression) (RelationalExpressionNoIn "<" ShiftExpression ($$ `(lt ,$1 ,$3))) (RelationalExpressionNoIn ">" ShiftExpression ($$ `(gt ,$1 ,$3))) (RelationalExpressionNoIn "<=" ShiftExpression ($$ `(le ,$1 ,$3))) (RelationalExpressionNoIn ">=" ShiftExpression ($$ `(ge ,$1 ,$3))) (RelationalExpressionNoIn "instanceof" ShiftExpression ($$ `(instanceof ,$1 ,$3))) ) (EqualityExpression (RelationalExpression) (EqualityExpression "==" RelationalExpression ($$ `(eq ,$1 ,$3))) (EqualityExpression "!=" RelationalExpression ($$ `(neq ,$1 ,$3))) (EqualityExpression "===" RelationalExpression ($$ `(eq-eq ,$1 ,$3))) (EqualityExpression "!==" RelationalExpression ($$ `(neq-eq ,$1 ,$3))) ) (EqualityExpressionNoIn (RelationalExpressionNoIn) (EqualityExpressionNoIn "==" RelationalExpressionNoIn ($$ `(eq ,$1 ,$3))) (EqualityExpressionNoIn "!=" RelationalExpressionNoIn ($$ `(neq ,$1 ,$3))) (EqualityExpressionNoIn "===" RelationalExpressionNoIn ($$ `(eq-eq ,$1 ,$3))) (EqualityExpressionNoIn "!==" RelationalExpressionNoIn ($$ `(neq-eq ,$1 ,$3))) ) (BitwiseANDExpression (EqualityExpression) (BitwiseANDExpression "&" EqualityExpression ($$ `(bit-and ,$1 ,$3))) ) (BitwiseANDExpressionNoIn (EqualityExpressionNoIn) (BitwiseANDExpressionNoIn "&" EqualityExpressionNoIn ($$ `(bit-and ,$1 ,$3))) ) (BitwiseXORExpression (BitwiseANDExpression) (BitwiseXORExpression "^" BitwiseANDExpression ($$ `(bit-xor ,$1 ,$3))) ) (BitwiseXORExpressionNoIn (BitwiseANDExpressionNoIn) (BitwiseXORExpressionNoIn "^" BitwiseANDExpressionNoIn ($$ `(bit-xor ,$1 ,$3))) ) (BitwiseORExpression (BitwiseXORExpression) (BitwiseORExpression "|" BitwiseXORExpression ($$ `(bit-or ,$1 ,$3))) ) (BitwiseORExpressionNoIn (BitwiseXORExpressionNoIn) (BitwiseORExpressionNoIn "|" BitwiseXORExpressionNoIn ($$ `(bit-or ,$1 ,$3))) ) (LogicalANDExpression (BitwiseORExpression) (LogicalANDExpression "&&" BitwiseORExpression ($$ `(and ,$1 ,$3))) ) (LogicalANDExpressionNoIn (BitwiseORExpressionNoIn) (LogicalANDExpressionNoIn "&&" BitwiseORExpressionNoIn ($$ `(and ,$1 ,$3))) ) (LogicalORExpression (LogicalANDExpression) (LogicalORExpression "||" LogicalANDExpression ($$ `(or ,$1 ,$3))) ) (LogicalORExpressionNoIn (LogicalANDExpressionNoIn) (LogicalORExpressionNoIn "||" LogicalANDExpressionNoIn ($$ `(or ,$1 ,$3))) ) (ConditionalExpression (LogicalORExpression) (LogicalORExpression "?" AssignmentExpression ":" AssignmentExpression ($$ `(ConditionalExpression ,$1 ,$3 ,$5))) ) (ConditionalExpressionNoIn (LogicalORExpressionNoIn) (LogicalORExpressionNoIn "?" AssignmentExpression ":" AssignmentExpressionNoIn ($$ `(ConditionalExpression ,$1 ,$3 ,$5))) ) (AssignmentExpression (ConditionalExpression) (LeftHandSideExpression AssignmentOperator AssignmentExpression ($$ `(AssignmentExpression ,$1 ,$2 ,$3))) ) (AssignmentExpressionNoIn (ConditionalExpressionNoIn) (LeftHandSideExpression AssignmentOperator AssignmentExpressionNoIn ($$ `(AssignmentExpression ,$1 ,$2 ,$3))) ) (AssignmentOperator ("=" ($$ `(assign ,$1))) ("*=" ($$ `(mul-assign ,$1))) ("/=" ($$ `(div-assign ,$1))) ("%=" ($$ `(mod-assign ,$1))) ("+=" ($$ `(add-assign ,$1))) ("-=" ($$ `(sub-assign ,$1))) ("<<=" ($$ `(lshift-assign ,$1))) (">>=" ($$ `(rshift-assign ,$1))) (">>>=" ($$ `(rrshift-assign ,$1))) ("&=" ($$ `(and-assign ,$1))) ("^=" ($$ `(xor-assign ,$1))) ("|=" ($$ `(or-assign ,$1)))) (Expression (AssignmentExpression) (Expression "," AssignmentExpression ($$ (if (and (pair? (car $1)) (eqv? 'expr-list (caar $1))) (tl-append $1 $3) (make-tl 'expr-list $1 $3))))) (ExpressionNoIn (AssignmentExpressionNoIn) (ExpressionNoIn "," AssignmentExpressionNoIn ($$ (if (and (pair? (car $1)) (eqv? 'expr-list (caar $1))) (tl-append $1 $3) (make-tl 'expr-list $1 $3))))) ;; A.4 (Statement (Block) (VariableStatement) (EmptyStatement) (ExpressionStatement) (IfStatement) (IterationStatement) (ContinueStatement) (BreakStatement) (ReturnStatement) (WithStatement) (LabelledStatement) (SwitchStatement) (ThrowStatement) (TryStatement) ;;(DebuggerStatement) v5.1 ) ;; Allow "var" statements in block but only at beginning and only ;; at function block entry, by static semantics so we can generate ;; error messages. (Block ;;("{" StatementList "}" ($prec 'stmt) ($$ `(Block . ,(cdr (tl->list $2))))) ("{" LetStatementList StatementList "}" ($prec 'stmt) ($$ `(Block . ,(append (sx-tail (tl->list $2)) (sx-tail (tl->list $3)))))) ("{" StatementList "}" ($prec 'stmt) ($$ `(Block . ,(sx-tail (tl->list $2))))) ("{" "}" ($prec 'stmt) ($$ '(Block))) ) (LetStatementList (LetStatement ($$ (make-tl 'LetStatementList $1))) (LetStatementList LetStatement ($$ (tl-append $1 $2)))) (LetStatement ("let" DeclarationList ";" ($$ `(LetStatement ,(tl->list $2))))) (StatementList (Statement ($$ (make-tl 'StatementList $1))) (StatementList Statement ($$ (tl-append $1 $2)))) (VariableStatement ("var" DeclarationList ";" ($$ `(VariableStatement ,(tl->list $2))))) (DeclarationList (VariableDeclaration ($$ (make-tl 'DeclarationList $1))) (DeclarationList "," VariableDeclaration ($$ (tl-append $1 $3)))) (DeclarationListNoIn (VariableDeclarationNoIn ($$ (make-tl 'DeclarationList $1))) (DeclarationListNoIn "," VariableDeclarationNoIn ($$ (tl-append $1 $3)))) (VariableDeclaration (Identifier Initializer ($$ `(VariableDeclaration ,$1 ,$2))) (Identifier ($$ `(VariableDeclaration ,$1))) ) (VariableDeclarationNoIn (Identifier InitializerNoIn ($$ `(VariableDeclaration ,$1 ,$2))) (Identifier ($$ `(VariableDeclaration ,$1))) ) (Initializer ("=" AssignmentExpression ($$ `(Initializer ,$2))) ) (InitializerNoIn ("=" AssignmentExpressionNoIn ($$ `(Initializer ,$2))) ) (EmptyStatement (";" ($$ '(EmptyStatement))) ) (ExpressionStatement (Expression ";" ($$ `(ExpressionStatement ,$1))) ) (IfStatement ("if" "(" Expression ")" Statement "else" Statement ($$ `(IfStatement ,$3 ,$5 ,$7))) ("if" "(" Expression ")" Statement ($prec 'then) ($$ `(IfStatement ,$3 ,$5))) ) (IterationStatement ("do" Statement "while" "(" Expression ")" ";" ;; <= spec has ';' here ($$ `(do ,$2 ,$5))) ("while" "(" Expression ")" Statement ($$ `(while ,$3 ,$5))) ("for" "(" OptExprStmtNoIn OptExprStmt OptExprClose Statement ($$ `(for $3 $4 $5 $6))) ("for" "(" "var" DeclarationListNoIn ";" OptExprStmt OptExprClose Statement ($$ `(for $4 $6 $7 $8))) ; ??? ("for" "(" LeftHandSideExpression "in" Expression ")" Statement ($$ `(for-in $3 $5 $7))) ; ??? ("for" "(" "var" VariableDeclarationNoIn "in" Expression ")" Statement ($$ `(for-in $4 $6 $8))) ; ??? ) (OptExprStmtNoIn (":" ($$ '(NoExpression))) (ExpressionNoIn ";") ) (OptExprStmt (";" ($$ '(NoExpression))) (Expression ";") ) (OptExprClose (";" ($$ '(NoExpression))) (Expression ")") ) (ContinueStatement ("continue" ($$ (NSI)) Identifier ";" ($$ `(ContinueStatement ,$3))) ("continue" ";" ($$ '(ContinueStatement))) ) (BreakStatement ("break" ($$ (NSI)) Identifier ";" ($$ `(BreakStatement ,$3))) ("break" ";" ($$ '(BreakStatement))) ) (ReturnStatement ("return" ($$ (NSI)) Expression ";" ($$ `(ReturnStatement ,$3))) ("return" ";" ($$ '(ReturnStatement))) ) (WithStatement ("with" "(" Expression ")" Statement ($$ `(WithStatement ,$3 ,$5)))) (SwitchStatement ("switch" "(" Expression ")" ($$ (NSI)) CaseBlock ($$ `(SwitchStatement ,$3 ,$6)))) (CaseBlock ("{" CaseBlockTail ($$ $2)) ("{" seq-of-semis CaseBlockTail ($$ $3))) (seq-of-semis (";") (seq-of-semis ";")) (CaseBlockTail ("}" ($$ '(CaseBlock))) (CaseClauses "}" ($$ `(CaseBlock ,(tl->list $1)))) (CaseClauses DefaultClause "}" ($$ `(CaseBlock ,(tl->list $1) ,$2))) (CaseClauses DefaultClause CaseClauses "}" ($$ `(CaseBlock ,(tl->list $1) ,$2 ,(tl->list $3)))) (DefaultClause CaseClauses "}" ($$ `(CaseBlock ,$1 ,(tl->list $2)))) (DefaultClause "}" ($$ `(CaseBlock ,$1))) ) (CaseClauses (CaseClause ($$ (make-tl 'CaseClauses $1))) (CaseClauses CaseClause ($$ (tl-append $1 $2))) ) (CaseClause ("case" Expression ":" StatementList ($$ `(CaseClause ,$2 ,(tl->list $4)))) ("case" Expression ":" ($$ `(CaseClause ,$2))) ) (DefaultClause ("default" ":" StatementList ($$ `(DefaultClause ,(tl->list $3)))) ("default" ":" ($$ `(DefaultClause))) ) (LabelledStatement (Identifier ":" Statement ($$ `(LabelledStatement ,$1 ,$3))) ) (ThrowStatement ("throw" ($$ (NSI)) Expression ";" ($$ `(ThrowStatement ,$3))) ) (TryStatement ("try" Block Catch ($$ `(TryStatement ,$2 ,$3))) ("try" Block Finally ($$ `(TryStatement ,$2 ,$3))) ("try" Block Catch Finally ($$ `(TryStatement ,$2 ,$3 ,$4))) ) (Catch ("catch" "(" Identifier ")" Block ($$ `(Catch ,$3 ,$5))) ) (Finally ("finally" Block ($$ `(Finally ,$2))) ) ;;(DebuggerStatement ("debugger" ";")) ;; A.5 (FunctionDeclaration ("function" Identifier "(" FormalParameterList ")" "{" FunctionBody "}" ($prec 'stmt) ($$ `(FunctionDeclaration ,$2 ,(tl->list $4) ,$7))) ("function" Identifier "(" ")" "{" FunctionBody "}" ($prec 'stmt) ($$ `(FunctionDeclaration ,$2 (FormalParameterList) ,$6))) ) (FunctionExpression ("function" Identifier "(" FormalParameterList ")" "{" FunctionBody "}" ($prec 'expr) ($$ `(FunctionExpression ,$2 ,(tl->list $4) ,$7))) ("function" "(" FormalParameterList ")" "{" FunctionBody "}" ($prec 'expr) ($$ `(FunctionExpression ,(tl->list $3) ,$6))) ("function" Identifier "(" ")" "{" FunctionBody "}" ($prec 'expr) ($$ `(FunctionExpression ,$2 (FormalParameterList) ,$6))) ("function" "(" ")" "{" FunctionBody "}" ($prec 'expr) ($$ `(FunctionExpression (FormalParameterList) ,$5))) ) (FormalParameterList (Identifier ($$ (make-tl 'FormalParameterList $1))) (FormalParameterList "," Identifier ($$ (tl-append $1 $3)))) ;; I have duplicated SourceElement as FunctionElement and ProgramElement ;; in order to allow this grammar to be reused for interactive parser. ;; The ia-parser will use ProgramElement as the start symbol. (FunctionBody (FunctionElements ($$ (tl->list $1)))) (FunctionElements (FunctionElement ($$ (make-tl 'FunctionElements $1))) (FunctionElements FunctionElement ($$ (tl-append $1 $2)))) (FunctionElement (Statement) (FunctionDeclaration)) (Program (ProgramElements ($$ `(Program ,(tl->list $1))))) (ProgramElements (ProgramElement ($$ (make-tl 'ProgramElements $1))) (ProgramElements ProgramElement ($$ (tl-append $1 $2)))) (ProgramElement (Statement) (FunctionDeclaration)) ))) ;; === parsers ========================== (define javascript-mach (hashify-machine (compact-machine (make-lalr-machine javascript-spec)))) (include-from-path "nyacc/lang/javascript/body.scm") (define gen-js-lexer (make-js-lexer-generator (assq-ref javascript-mach 'mtab))) (define raw-parser (make-lalr-parser javascript-mach)) (define* (dev-parse-js #:key debug) (catch 'nyacc-error (lambda () (with-fluid* *insert-semi* #t (lambda () (raw-parser (gen-js-lexer) #:debug debug)))) (lambda (key fmt . args) (report-error fmt args) #f))) (define javascript-ia-spec (restart-spec javascript-spec 'ProgramElement)) (define javascript-ia-mach (hashify-machine (compact-machine (make-lalr-machine javascript-ia-spec)))) ;; === automaton file generators ========= (define* (gen-javascript-files #:optional (path ".")) (define (mdir file) (mach-dir path file)) (write-lalr-actions javascript-mach (mdir "js-act.scm.new") #:prefix "js-") (write-lalr-tables javascript-mach (mdir "js-tab.scm.new") #:prefix "js-") (write-lalr-actions javascript-ia-mach (mdir "ia-js-act.scm.new") #:prefix "ia-js-") (write-lalr-tables javascript-ia-mach (mdir "ia-js-tab.scm.new") #:prefix "ia-js-") (let ((a (move-if-changed (mdir "js-act.scm.new") (mdir "js-act.scm"))) (b (move-if-changed (mdir "js-tab.scm.new") (mdir "js-tab.scm"))) (c (move-if-changed (mdir "ia-js-act.scm.new") (mdir "ia-js-act.scm"))) (d (move-if-changed (mdir "ia-js-tab.scm.new") (mdir "ia-js-tab.scm")))) (or a b c d))) ;;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/javascript/pprint.scm0000644000175100000240000001722513605250515022444 0ustar mwettedialout;;; nyacc/lang/javascript/pprint.scm ;; Copyright (C) 2016-2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see . ;; javascript pretty-printer (define-module (nyacc lang javascript pprint) #:export (pretty-print-js) #:use-module ((srfi srfi-1) #:select (pair-for-each)) #:use-module (nyacc lang util) #:use-module (nyacc lang sx-util) ) (define op-prec '((delete void typeof pre-inc pre-dec pos neg not) (mul div mod) (add sub) (lshift rshift rrshift) (lt gt le ge instanceof in) (equal not-equal not-equal-eq) (bit-xor) (bit-or) (and) (or) ;; ... )) (define op-assc '((left mul div mod add sub lshift rshift rrshift lt gt le ge) (right) (nonassoc))) (define protect-lval? #f) (define protect-rval? #f) (let ((protect-expr? (make-protect-expr op-prec op-assc))) (set! protect-lval? (lambda (op lval) (protect-expr? 'left op lval))) (set! protect-rval? (lambda (op rval) (protect-expr? 'right op rval)))) (define* (pretty-print-js tree #:key (indent-level 2)) (define ppx (let* ((fmtr (make-pp-formatter)) (push-il (lambda () (fmtr 'push))) (pop-il (lambda () (fmtr 'pop))) (sf (lambda args (apply fmtr args))) (sf-nl (lambda () (sf "\n"))) (ppx/p (lambda (tree) (sf "(") (ppx tree) (sf ")")))) (lambda (tree) (case (car tree) ((NullLiteral) (sf "null")) ((BooleanLiteral) (sf "~A" (cadr tree))) ((NumericLiteral) (sf "~A" (cadr tree))) ((StringLiteral) (sf "~S" (cadr tree))) ;; Identifier ((Identifier) (sf "~A" (cadr tree))) ;; PrimaryExpression ((PrimaryExpression) (ppx (cadr tree))) ;; ArrayLiteral ;; ElementList ;; Elision ;; ObjectLiteral ;; PropertyNameAndValueList ;; aoo-ref ((aoo-ref) (ppx (sx-ref tree 1)) (sf "[") (ppx (sx-ref tree 2)) (sf "]")) ;; obj-ref ;; new ;; CallExpression ((CallExpression) (ppx (sx-ref tree 1)) (ppx (sx-ref tree 2))) ;; ArgumentList ((ArgumentList) (pair-for-each (lambda (pair) (ppx (car pair)) (if (pair? (cdr pair)) (sf ", "))) (cdr tree))) ;; post-inc ;; post-dec ;; delete ;; void ;; typeof ;; pre-inc ;; pre-dec ;; pos ;; neg ;; ~ ;; not ;; add sub mul div mod ((add sub mul div mod) (let ((op (sx-ref tree 0)) (lval (sx-ref tree 1)) (rval (sx-ref tree 2))) (if (protect-lval? op lval) (ppx/p lval) (ppx lval)) (case (car tree) ((add) (sf " + ")) ((sub) (sf " - ")) ((mul) (sf "*")) ((div) (sf "/")) ((mod) (sf "%"))) (if (protect-rval? op rval) (ppx/p rval) (ppx rval)) )) ;; lshift ;; rshift ;; rrshift ;; lt gt le ge eq neq ((lt gt le ge eq neq) (let ((op (sx-ref tree 0)) (lval (sx-ref tree 1)) (rval (sx-ref tree 2))) (if (protect-lval? op lval) (ppx/p lval) (ppx lval)) (case op ((lt) (sf " < ")) ((gt) (sf " <= ")) ((le) (sf " > ")) ((ge) (sf " >= ")) ((eq) (sf " == ")) ((neq) (sf " != "))) (if (protect-rval? op rval) (ppx/p rval) (ppx rval)) )) ;; instanceof ;; in ;; eq-eq ;; neq-eq ;; bit-and ;; bit-xor ;; bit-or ;; and ;; or ;; ConditionalExpression ;; AssignmentExpression ((AssignmentExpression) (ppx (sx-ref tree 1)) (sf " ~A " (cadr (sx-ref tree 2))) (ppx (sx-ref tree 3))) ;; assign mul-assign div-assign mod-assign add-assign sub-assign ;; lshift-assign rshift-assign rrshift-assign and-assign ;; xor-assign or-assign ((assign) (sf " = ")) ((mul-assign) (sf " *= ")) ((div-assign) (sf " /= ")) ((mod-assign) (sf " %= ")) ((add-assign) (sf " += ")) ((sub-assign) (sf " -= ")) ((lshift-assign) (sf " <<= ")) ((rshift-assign) (sf " >>= ")) ((rrshift-assign) (sf " >>>= ")) ((and-assign) (sf " &= ")) ((xor-assign) (sf " ^= ")) ((or-assign) (sf " |= ")) ;; expr-list ;; Block ((Block) (sf "{\n") (push-il) (ppx (sx-ref tree 1)) (pop-il) (sf "}\n")) ;; VariableStatement ((VariableStatement) (sf "var ") (for-each (lambda (el) (ppx el)) (cdr tree)) (sf-nl)) ;; VariableDeclarationList ;; VariableDeclaration ((VariableDeclarationList) (pair-for-each (lambda (pair) ;;(sf "decl=~S\n" (car pair)) (let* ((decl (car pair)) (id (cadr (sx-ref decl 1))) (val (and (< 2 (length decl)) (sx-ref decl 2)))) (sf "~A" id) (if val (ppx val)) (if (pair? (cdr pair)) (sf ", ") (sf ";")) )) (cdr tree))) ;; Initializer ((Initializer) (sf " = ") (ppx (cadr tree))) ;; EmptyStatement ((EmptyStatement) (sf ";")) ;; ExpressionStatement ((ExpressionStatement) (ppx (sx-ref tree 1)) (sf ";\n")) ;; IfStatement ((IfStatement) (let ((ex (sx-ref tree 1)) (th (sx-ref tree 2)) (el (and (< 3 (length tree)) (sx-ref tree 3))) ) ;;(simple-format #t "\nel=~S\n" el) (sf "if (") (ppx ex) (sf ") {\n") (push-il) (ppx th) (pop-il) (if el (if (eqv? 'IfStatement (car el)) (begin (sf "} else ") (ppx el)) (begin (sf "} else {\n") (push-il) (ppx el) (pop-il) (sf "}\n"))) (sf "}\n")))) ;; do ;; while ;; for ;; for-in ((for-in) (let ((lhsx (sx-ref tree 1)) (expr (sx-ref tree 2)) (stmt (sx-ref tree 3))) ;;(simple-format #t "\n(car stmt)=~S\n" (car stmt)) (sf "for (") (ppx lhsx) (sf " in ") (ppx expr) (if (eqv? 'Block (car stmt)) (begin (sf ") ") (ppx stmt)) (begin (sf ")\n") (push-il) (ppx stmt) (pop-il))))) ;; Expression ;; ExprStmt ;; ContinueStatement ;; ReturnStatement ((ReturnStatement) (sf "return") (when (< 1 (length tree)) (sf " ") (ppx (cadr tree))) (sf ";\n")) ;; WithStatement ;; SwitchStatement ;; CaseBlock ;; CaseClauses ;; CaseClause ;; DefaultClause ;; LabelledStatement ;; ThrowStatement ;; TryStatement ;; Catch ;; Finally ;; FunctionDeclaration (see also fU) ((FunctionDeclaration) (let ((name (sx-ref tree 1)) (parl (sx-ref tree 2)) (body (sx-ref tree 3))) (sf "function ~A(" (cadr name)) (ppx parl) (sf ") {\n") (push-il) (ppx body) (pop-il) (sf "}\n"))) ;; FunctionExpression ;; FormalParameterList ((FormalParameterList) (pair-for-each (lambda (pair) (sf "~A" (cadar pair)) (if (pair? (cdr pair)) (sf ", "))) (cdr tree))) ;; Program ((Program) (ppx (cadr tree))) ; should be start ;; SourceElements ((SourceElements) ;; with spaces around fctn-decl's (pair-for-each (lambda (pair) (let ((selt (car pair)) (not-last (pair? (cdr pair)))) (case (car selt) ((EmptyStatement) #f) ((FunctionDeclaration) (ppx selt) (if not-last (sf-nl))) (else (ppx selt) (if (and not-last (eqv? 'FunctionDeclaration (caadr pair))) (sf-nl)))))) (cdr tree))) (else (simple-format #t "\nnot handled: ~S\n" (car tree)) #f))))) (ppx tree)) ;; --- last line --- nyacc-1.00.2/examples/nyacc/lang/javascript/compile-tree-il.scm0000644000175100000240000011616613605250515024123 0ustar mwettedialout;; compile javascript sxml from parser to tree-il ;; Copyright (C) 2015-2018 Matthew R. Wette ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this library; if not, see ;;; Description: ;; My goal in this development was to get experience with comping SXML trees ;; to tree-il: putting together patterns and utility procedures for converting ;; common structures (e.g, return , break). It might be fun to also try ;; converting to CPS. (But need to read more on this.) -- Matt ;; Building the parser and compiler can be a little tricky. It has to work ;; interactively, for loaded files, and for maybe other stuff. ;; The reader (or parser) needs to be able to parse one top-level form and ;; return. Note that usually parsers are designed to read files, so they ;; look for EOF to stop parsing. In interactive mode, we want to stop ;; when a top-level form ends with "\n". ;; You should look at the source for (ice-9 boot-9) to see how load works, ;; and at the source for (system base compile) to see how compilation gets ;; done. I'm still absorbing those and don't know how much insight I can ;; provide. -- Matt - 15 Jul 2018 ;;; Notes: ;; @itemize ;; @item JS functions will need to be re-implemented as objects, with the ;; `[[Call]]' property used to make calls. ;; @item don't support the arguments property in functions ;; @item could maybe handle this using ;; d.f1 = function... => d.f1 = (let ((this d)) f1) ;; but then d1.f = d0.f does not work ;; @item (void) == (const *unspecified*) i think ;; @item need atomic-box? ;; @end itemize ;; https://developer.mozilla.org/en-US/docs/Web/JavaScript/Guide/\ ;; Details_of_the_Object_Model ;; If Manager: Employee ;; function Manager() { ;; Employee.call(this); ;; this.reports = []; ;; } ;; Manager.prototype = Object.create(Employee.prototype); ;; Manager.prototype.constructor = Manager; ;; TODO: ;; @itemize ;; @item Imeplement @code{with}. ;; @item Imeplement @code{for}. ;; @item Imeplement @code{for-in}. ;; @item Update to es5. ;; @item Implement objects and prototypes correctly. ;; @item Implement unary and binary operators (in xlib-01.scm) correctly. ;; @end itemize ;; ;; DONE: ;; @itemize ;; @item add let only allow var at top-level and function start scope ;; @end itemize ;;; Code: (define-module (nyacc lang javascript compile-tree-il) #:export (compile-tree-il show-javascript-sxml show-javascript-xtil) #:use-module (nyacc lang javascript xlib) #:use-module (nyacc lang sx-util) #:use-module (nyacc lang nx-util) #:use-module ((sxml fold) #:select (foldts*-values)) #:use-module ((srfi srfi-1) #:select (fold append-reverse)) #:use-module (language tree-il) #:use-module (ice-9 match) ) (use-modules (ice-9 pretty-print)) (define (sferr fmt . args) (apply simple-format (current-error-port) fmt args)) (define (pperr tree) (pretty-print tree (current-error-port) #:per-line-prefix " ")) ;; === portability =================== ;; no longer supports guile 2.0: assuming 2.2 (define (jsym) (gensym "JS~")) ;; ======================= ;; @heading variable scope ;; Variables in the compiler are kept in a scope-stack with the highest ;; level being the current module. Why do I convert to xxx? ;; We catch FunctionDecl and VariableDecl's on the way down and generate new ;; lexical scope and variable declartions let forms or function xxx ;; function declarations are always just a list of args; ;; @example ;; function foo(x, y) { return x + y; } ;; => ;; (define foo (lambda @args (+ ;; @end example ;; we just use rest arg and then express each ;; var reference as (list-ref @args index) ;; Another option is to use case-lambda ... ;; CHANGE THIS. Use optional arguments for everything ;; @subheading non-tail return ;; need to use prompts here, I think ... Hey just use let/ec ? ;; @example ;; (let/ec return ((var1 val1) (var2 val2)) ... (return x) ...) ;; @end example ;; ProgramElements occurs in a Program (top-level). ;; We translate Program to seq (aka begin). ;; FunctionElements occurs in a Function. ;; We translate FunctionBody to let. ;; the dictionary will maintain entries with ;; '(lexical var JS~123) ;; variable references are of the forms ;; @table @code ;; @item (toplevel name) ;; top level env ;; @item (@ mod name) ;; exported module refernce ;; @item (@@ mod name) ;; unexported ;; @item (lexical name gensym) ;; lexical scoped variable ;; @end table ;; === symbol table ================ (define xlib-mod '(nyacc lang javascript xlib)) (define (xlib-ref name) `(@@ (nyacc lang javascript xlib) ,name)) (define undefined '(void)) (define null (xlib-ref 'js:null)) ;; may need to push-level (blocks) and push-scope (functions) ;; add label for continue break. The value will be a pair ;; with car the continue ref and cdr the break ref (define (add-label name dict) (acons name (cons #f #f) dict)) ;;(define (c-name->guile name) ;; ;; | scm_ | _ - | ! _x | _to_ -> | _less < | _gr > | _leq <= | _geq >= | ;; (string-map (lambda (ch) (if (char=? ch #\_) #\- ch)) name)) (define xlib-module (resolve-module '(nyacc lang javascript xlib))) #;(define (x-lookup name dict) (cond ((not dict) #f) ((null? dict) #f) ((assoc-ref dict name)) ; => value ((assoc-ref dict '@P) => ; parent level (lambda (dict) (lookup name dict))) ((find-in-env name (assoc-ref dict '@M))) ((find-in-env (c-name->guile name) (assoc-ref dict '@M))) ((find-in-env name xlib-module)) (else #f))) (define push-scope nx-push-scope) (define pop-scope nx-pop-scope) (define top-level? nx-top-level?) (define add-toplevel nx-add-toplevel) (define add-lexical nx-add-lexical) (define add-lexicals nx-add-lexicals) (define add-symbol nx-add-symbol) (define (lookup name dict) (or (nx-lookup name dict) (nx-lookup-in-env name xlib-module))) ;; === codegen procedures ============= ;; @deffn {Procedure} make-let bindings exprs ;; Generates a Tree-IL let form from arguments, where @var{bindings} looks like ;; @noindent ;; and @var{exprs} is a list of expressions, to something like ;; @example ;; (let (v w) (JS~5897 JS~5898) (# (const 3)) . exprs) ;; @end example ;; @end deffn (define (make-let bindings exprs) (let loop ((names '()) (gsyms '()) (vals '()) (bindings bindings)) (if (null? bindings) `(let ,(reverse names) ,(reverse gsyms) ,(reverse vals) ,(block exprs)) (loop (cons (list-ref (car bindings) 1) names) (cons (list-ref (car bindings) 2) gsyms) (cons (list-ref (car bindings) 3) vals) (cdr bindings))))) ;; @deffn {Procedure} wrap-bindings body => body ;; @example ;; (seq (bindings ...) ...) => (let ... (seq ...)) ;; expr => expr ;; @end example ;; @noindent where bindings may look like ;; @example ;; (bindings (bind v v~5897 (void)) (bind w w~5898 (const 3))) ;; @end example ;; @noindent ;; Oh, I think this needs to use @code{letrec*}. ;; @end deffn (define (wrap-bindings body) ;;(sferr "wrap:\n body\n") (pperr body) (let loop1 ((bindings '()) (rest body)) (match rest (`(seq (bindings . ,bnds) ,rst) (loop1 (fold cons bindings bnds) rst)) (_ ;;(sferr " bindings, rest:\n") (pperr bindings) (pperr rest) (if (null? bindings) body (let loop2 ((names '()) (gsyms '()) (inits '()) (binds bindings)) (if (null? binds) `(letrec* ,names ,gsyms ,inits ,rest) (loop2 (cons (list-ref (car binds) 1) names) (cons (list-ref (car binds) 2) gsyms) (cons (list-ref (car binds) 3) inits) (cdr binds))))))))) ;; @deffn {Procedure} make-function name this args body ;; Pass arguments as optional and add @code{this} keyword argument.@* ;; Note: Change this @code{make-arity} (see tcl/c-t-il.scm). ;; @end deffn. (define (make-function name this args body) (unless args (error "no args")) (let* ((meta '((language . nx-javascript))) (meta (if name (cons `(name . ,name) meta) meta))) `(lambda ,meta (lambda-case ((() ; req ,(map car args) ; opt #f ; rest (#f (#:this this ,this)) ; kw (,@(map (lambda (v) undefined) args) ,undefined) ; inits (,@(map cadr args) ,this)) ; syms ,body))))) ;; used in fU for switch cases ;; (let ((key (if key #t (equal? case-key val)))) ;; (if key case-stmts) ;; next) ;; or chained we get ;; (let ((key (if key #t (equal? case-key val)))) ;; (if key case-stmts) ;; (let ((key (if key #t (equal? case-key val)))) ;; (if key case-stmts) ;; next)) (define (make-case val sym psym kseed next) `(let (~key) (,sym) ((if (lexical ~key ,psym) (const #t) (prim-call equal? ,val ,(cadr kseed)))) (seq (if (lexical ~key ,sym) ,(car kseed) (void)) ,next))) ;; NOT USED -- NOT NEEDED ;; @deffn {Procedure} resolve-ref ref => exp ;; WARNING: I think this is more subtle than I am making it.@* ;; Resolve a possible reference (lval) to an expression (rval). ;; Right now this will convert an object-or-array ref to its value ;; via @code{js-ooa-get}. Otherwise just return the value. ;; @end deffn (define (resolve-ref ref) (let ((tag (car ref))) (if (or (vector? tag) (hash-table? tag)) `(call ,(xlib-ref 'js-ooa-get) ,ref) ref))) ;; @deffn {Procedure} op-on-ref ref op ord => `(let ...) ;; This routine generates code for @code{ref++}, etc where @var{ref} is ;; a @code{toplevel}, @code{lexical} or @emph{ooa-ref} (object or array ;; reference). The argument @var{op} is @code{'js:+} or @code{'js:-} and ;; @var{ord} is @code{'pre} or @code{'post}. ;; @end deffn (define (op-on-ref ref op ord) (let* ((sym (jsym)) (val (case (car ref) ((toplevel) ref) ((lexical) ref) (else `(call ,(xlib-ref 'js-ooa-get) ,ref)))) (loc `(lexical ~ref ,sym)) (sum `(call ,(xlib-ref op) (const 1) ,loc)) (set (case (car ref) ((toplevel lexical) `(set! ,ref ,sum)) (else `(call ,(xlib-ref 'js-ooa-put) ,ref ,sum)))) (rval (case ord ((pre) val) ((post) loc)))) `(let (~ref) (,sym) (,val) (seq ,set (seq ,rval (void)))))) ;; for lt + rt, etc (define (op-call op kseed) (rev/repl 'call (xlib-ref op) kseed)) (define (op-call/prim op kseed) (rev/repl 'prim-call op kseed)) ;; @deffn {Procedure} op-assn kseed => `(set! lhs rhs) ;; op-assn: for lhs += rhs etc ;; @end deffn (define op-assn (let ((opmap '((mul-assign . js:*) (div-assign . js:/) (mod-assign . js:%) (add-assign . js:+) (sub-assign . js:-) (lshift-assign . js:lshift) (rshift-assign . js:rshift) (rrshift-assign . js:rrshift) (and-assign . js:and) (xor-assign . js:xor) (or-assign . js:or) (assign . #f)))) (lambda (kseed) (let ((lhs (caddr kseed)) (op (assq-ref opmap (caadr kseed))) (rhs (car kseed))) (if op `(set! ,lhs (call (@@ ,xlib-mod ,op) lhs rhs)) `(set! ,lhs ,rhs)))))) (define (opcall-node op seed kseed kdict) (values (cons (rev/repl 'call (xlib-ref op) kseed) seed) kdict)) (define make-opcall xlib-mod) ;; ==================================== ;; @deffn {Procedure} xlang-sxml->xtil exp env opts ;; Compile extension SXML tree to external Tree-IL representation. ;; This one is public because it's needed for debugging the compiler. ;; @end deffn (define-public (xlang-sxml->xtil exp env opts) ;; In the case where we pick off ``low hanging fruit'' we need to coordinate ;; the actions of the up and down handlers. The down handler will provide ;; a kid-seed in order and generate a null list. The up handler, upon seeing ;; a null list, will just incorporate the kids w/o the normal reverse. ;; @deffn {Procedure} remove-empties elements => elements ;; @end deffn (define (remove-empties elements) (let loop ((elts elements)) (if (null? elts) '() (let ((elt (car elts)) (rest (cdr elts))) (if (eq? (car elt) 'EmptyStatement) (loop rest) (cons elt (loop rest))))))) ;; @deffn {Procedure} labelable-stmt? stmt => #f|stmt ;; This predicate determines if the statement can have a preceeding label. ;; @end deffn (define (labelable-stmt? stmt) (memq (car stmt) '(do while for for-in BreakStatement LabelledStatement))) ;; @deffn {Procedure} cleanup-labels elements => elements ;; The argument @var{elements} is the tail of @code{ProgramElements} ;; or @code{FunctionElements}. This procedure assumes all top-level ;; @code{EmptyStatements} have been removed. This procedure reduces ;; @code{LabelledStatement}s to the form ;; @example ;; @dots{} (LabelledStatement id iter-stmt) @dots{} ;; @dots{} (LabelledStatement id (LabelledStatement id iter-stmt)) @dots{} ;; @end example ;; @noindent ;; where @code{iter-stmt} is @code{do}, @code{while}, @code{for} or ;; @code{switch}, or removes them if not preceeding iteration statement. ;; @end deffn (define (cleanup-labels src-elts-tail) (let loop ((src src-elts-tail)) (if (null? src) '() (if (eq? (caar src) 'LabelledStatement) (call-with-values (lambda () (let* ((elt (car src)) (rest (cdr src)) (id (cadr elt)) (stmt (caddr elt))) (if (eqv? 'EmptyStatement (car stmt)) (if (and (pair? rest) (labelable-stmt? (car rest))) (values id (car rest) (cdr rest)) (values id stmt rest)) (if (labelable-stmt? stmt) (values id stmt rest) (values id '(EmptyStatement) (cons stmt rest)))))) (lambda (id stmt rest) (if (eqv? 'EmptyStatement (car stmt)) (begin (simple-format (current-error-port) "removing misplaced label: ~A\n" (cadr id)) (loop rest)) (cons `(LabelledStatement ,id ,stmt) (loop rest))))) (cons (car src) (loop (cdr src))))))) ;; @deffn {Procedure} hoist-decls elements => elements ;; Move all variable declarations to front and replace old ones with ;; assignment. ;; @end deffn (define hoist-stmts '(VariableStatement LetStatement)) (define (split-dstmt dstmt hoisted rest) ;; => hoisted rest ;; move Let/VariableStatement to hoisted, moving initializers ;; to decls as assignment statements (let loop ((hdecls '()) (rest rest) (decls (cdadr dstmt))) (if (null? decls) (values (cons `(,(car dstmt) (DeclarationList ,hdecls)) hoisted) rest) (let* ((decl (car decls)) (init (if (= 3 (length decl)) (caddr decl) #f)) (decl (if init (list (car decl) (cadr decl)) decl))) (loop (cons decl hdecls) (if init (cons `(ExpressionStatement (AssignmentExpression (PrimaryExpression ,(cadr decl)) (assign "=") ,(cadr init))) rest) rest) (cdr decls)))))) (define (hoist-decls elements) (let ((tail (let loop ((elts elements)) ; tail after Let/VarStatements (cond ((null? elts) elts) ((not (memq (caar elts) hoist-stmts)) elts) (loop (cdr elts)))))) (let loop ((hoisted '()) (rest '()) (elts tail)) (cond ((null? elts) (if (null? hoisted) elements ; nothing hoisted (let loop2 ((elts elements)) ; rebuild statement list (if (eq? elts tail) (append-reverse hoisted (reverse rest)) (cons (car elts) (loop2 (cdr elts))))))) ((memq (caar elts) hoist-stmts) (call-with-values ; decl=>hoisted init=>rest (lambda () (split-dstmt (car elts) hoisted rest)) (lambda (hoisted rest) (loop hoisted rest (cdr elts))))) (else (loop hoisted (cons (car elts) rest) (cdr elts))))))) ;; @deffn {Procedure} fold-in-blocks elts-tail => elts-tail ;; NOTE: THIS IS NOT CORRECT. JS DOES NOT SCOPE BLOCKS.@* ;; Look through source elements. Change every var xxx to a ;; @example ;; (@dots{} (VariableStatement (DeclarationList ...)) @dots{}) ;; @end example ;; @noindent ;; (@dots{} (DeclarationList ...) (Block @dots{})) ;; @example ;; @dots{} @{ var a = 1; @dots{} @} ;; @end example ;; @noindent ;; We assume no elements of @code{FunctionElements} is text. ;; @end deffn (define (x-fold-in-blocks src-elts-tail) (let loop ((src src-elts-tail)) (if (null? src) '() (let ((elt (car src)) (rest (cdr src))) (if (eq? (car elt) 'VariableStatement) (list (cons* 'Block (cadr elt) (loop rest))) (cons elt (loop rest))))))) ;; @deffn {Procedure} check-scoping elements ;; Check blocks to make sure @code{var} is only used in blocks at entry ;; to functions. Otherwise issue an error message. ;; @end deffn (define (check-scoping elements) elements) (define (fD tree seed dict) ;; => tree seed dict ;; This handles branches as we go down the tree. We do two things here: ;; @enumerate ;; @item Pick off low hanging fruit: items we can completely convert ;; @item trap places where variables are declared and maybe bump scope ;; Add symbols to the dictionary, keeping track of lexical scope. ;; @end enumerate ;; declarations: we need to trap ident references and replace them ;;(sferr "fD: tree=~S ...\n" (car tree)) (sx-match tree ((Identifier ,name) (let ((ref (lookup name dict))) (cond (ref (values '() ref dict)) (else ;; maybe not defined, assume toplevel (sferr "javascript: maybe undefined: ~A\n" name) (values '() `(toplevel ,(string->symbol name)) dict))))) ((PrimaryExpression (this)) (let ((ref (lookup "this" dict))) (if (not ref) (error "javascript: not found: \"this\"")) (values '() ref dict))) ((PrimaryExpression (NullLiteral ,null)) (values '() '(const js:null) dict)) ((BooleanLiteral ,true-or-false) (values '() `(const ,(char=? (string-ref true-or-false 0) #\t)) dict)) ((PrimaryExpression (NumericLiteral ,val)) (values '() `(const ,(string->number val)) dict)) ((PrimaryExpression (StringLiteral ,str)) (values '() `(const ,str) dict)) ((CallExpression (obj-ref ,expr (PrimaryExpression (Identifier ,name))) ,arg-list) (sferr "1\n") (values `(obj-CallExpression ,expr ,name ,arg-list) '() dict)) ((CallExpression (obj-ref ,expr (Identifier ,name)) ,arg-list) (sferr "2\n") (values `(obj-CallExpression ,expr ,name ,arg-list) '() dict)) ((CallExpression . ,rest) (values tree '() dict)) ((PropertyNameAndValue (Identifier ,name) ,expr) (values `(PropertyNameAndValue (PropertyName ,name) ,expr) '() dict)) ((obj-ref ,expr (Identifier ,name)) (values `(ooa-ref ,expr ,name) '() dict)) ((Block . ,elts) ;; see comments on FunctionElements below (let* ((elts (remove-empties elts)) (elts (cleanup-labels elts))) (values tree '() dict))) ;; Convert AssignmentExpression to: ;; 1) var-AssignmentExpression => ... (set! ...) ;; 2) obj-AssignmentExpression => ... (hash-set! ...) ;; 3) ooa-AssignmentExpression => ... (vector-set! ...)|(hash-set! ...) ;; TODO: check LeftHandSideExpression ((AssignmentExpression (@ . ,attr) (PrimaryExpression (Identifier ,name)) ,assn ,rhs) (values `(var-AssignmentExpression . ,(cdr tree)) '() dict)) ((AssignmentExpression (@ . ,attr) (obj-ref ,expr (Identifier ,name)) ,assn ,rhs) (values `(obj-AssignmentExpression (@ . ,attr) ,expr ,name ,assn ,rhs) '() dict)) ((AssignmentExpression (@ . ,attr) (ooa-ref ,expr ,expr) ,rhs) (values `(ooa-AssignmentExpression (@ . ,attr) ,expr ,expr ,rhs) '() dict)) ((StatementList . ,stmts) (let* ((stmts (remove-empties stmts)) (stmts (check-scoping stmts))) (values tree '() dict))) ((VariableDeclaration (Identifier ,name) . ,rest) (let* ((dict1 (add-symbol name dict)) (tree1 (lookup name dict1))) (if (not tree1) (error "javascript coding error")) (values `(VariableDeclaration ,tree1 . ,rest) '() dict1))) ((do . ,rest) (values tree '() (add-lexicals "break" "continue" (push-scope dict)))) ((while . ,rest) (values tree '() (add-lexicals "break" "continue" (push-scope dict)))) ((for . ,rest) (values tree '() (add-lexicals "break" "continue" (push-scope dict)))) ((for-in . ,rest) (values tree '() (add-lexicals "break" "continue" (push-scope dict)))) ((SwitchStatement . ,rest) (values tree '() (add-lexicals "swx~val" "break" (push-scope dict)))) ((LabelledStatement (Identifier ,name) ,stmt) (values tree '() (add-label name dict))) ((TryStatement . ,expr) (values tree '() (add-lexical "catch" (push-scope dict)))) ((Catch (Identifier ,name) ,block) (values tree '() (add-lexical name dict))) ((FunctionDeclaration (Identifier ,name) . ,rest) (values tree '() (add-lexicals "this" "return" (push-scope (add-symbol name dict))))) ((FunctionExpression (Identifier ,name) . ,rest) (values tree '() (add-lexicals "this" "return" name (push-scope dict)))) ((FunctionExpression . ,rest) (values tree '() (add-lexicals "this" "return" (push-scope (add-symbol "*anon*" dict))))) ((FormalParameterList . ,idlist) (values tree '() (acons 'arguments-used? #f (add-lexical "arguments" (fold add-lexical dict (map cadr idlist)))))) ((FunctionElements . ,elts) ;; Fix up list of function elements: ;; 1) Remove EmptyStatements. ;; 2) If LabelledStatement has EmptyStatement, merge with following ;; do, while, for or switch. Otherwise remove. ;; 3) Make to DeclList always followed by a Block to end of Elements.??? (let* ((elts (remove-empties elts)) (elts (hoist-decls elts)) (elts (cleanup-labels elts))) (values `(FunctionElements . ,elts) '() dict))) ((ProgramElements . ,elts) ;; a list of top-level statements (values tree '() dict)) (else ;;(sferr "fD: otherwise\n") (pperr tree) (values tree '() dict)) )) (define (fU tree seed dict kseed kdict) ;; => seed dict (when #f (sferr "fU: ~S\n" (if (pair? tree) (car tree) tree)) (sferr " kseed=~S\n seed=~S\n" kseed seed) ;;(pperr tree) ) ;; This routine rolls up processes leaves into the current branch. ;; We have to be careful about returning kdict vs dict. ;; Approach: always return kdict or (pop-scope kdict) (if (null? tree) (values (cons kseed seed) kdict) (case (car tree) ((*TOP*) (values (car kseed) kdict)) ;; Identifier: handled in fD above ;; PrimaryExpression (w/ ArrayLiteral or ObjectLiteral only) ((PrimaryExpression) (values (cons (car kseed) seed) kdict)) ;; ArrayLiteral ;; mkary is just primitive vector ((ArrayLiteral) (let ((exp `(call (@@ ,xlib-mod mkary) (car kseed)))) (values (cons exp seed) kdict))) ;; ElementList ((ElementList) (values (cons (rtail kseed) seed) kdict)) ;; Elision: convert to list of js:undefined ((Elision) (let* ((len (string->number (car kseed))) (avals (make-list len '(void)))) (values (append avals seed) kdict))) ;; ObjectLiteral ((ObjectLiteral) (let* ((tail (rtail kseed))) (values (cons (if (null? tail) `(call (toplevel make-hash-table)) (car tail)) seed) kdict))) ;; PropertyNameAndValueList ((PropertyNameAndValueList) (sferr "prop list\n") (pperr (reverse kseed)) (values (cons `(call (@@ ,xlib-mod mkobj) ,@(rtail kseed)) seed) kdict)) ;; PropertyNameAndValue ((PropertyNameAndValue) (values (cons* (car kseed) (cadr kseed) seed) kdict)) ;; PropertyName ((PropertyName) (values (cons `(const ,(string->symbol (car kseed))) seed) kdict)) ;; ooa-ref (object-or-array ref), a cons cell: (dict name) ;; obj-ref: converted to ooa-ref in fD ;; => (cons ) ;; a bit ugly now ??? ((ooa-ref) (sferr "ooaref:\n") (pperr (rtail kseed)) (let* ((expr `(primcall cons (call ,(xlib-ref 'js-resolve) ,(cadr kseed)) ,(car kseed))) (tail (rtail kseed)) (ooa (list-ref tail 0)) (arg `(const ,(string->symbol (list-ref tail 1)))) (expr `(call ,(xlib-ref 'js:ooa-ref) ,ooa ,arg)) ) (pperr expr) (values (cons expr seed) kdict))) ;; new ((new) (let* ((tail (rtail kseed)) (expr `(call ,(car tail) ,@(cadr tail) (const #:this) (call (toplevel make-hash-table))))) (values (cons expr seed) kdict))) ;; obj-CallExpression obj name args : add args #:this obj ((obj-CallExpression) (let* ((tail (rtail kseed)) (obj (list-ref tail 0)) (mem `(const ,(string->symbol (list-ref tail 1)))) (args (list-ref tail 2)) (args (append args (list `(const #:this) obj))) (expr `(call (call ,(xlib-ref 'js:ooa-ref) ,obj ,mem) . ,args))) ;;(sferr "obj-C\n") (pperr tail) (values (cons expr seed) kdict))) ;; CallExpression ((CallExpression) ;;(pperr (cons* 'apply (cadr kseed) (car kseed))) (values (cons (cons* 'call (cadr kseed) (car kseed)) seed) kdict)) ;; ArgumentList ((ArgumentList) ;; append-reverse-car ??? (values (cons (rtail kseed) seed) kdict)) ;; post-inc ((post-inc) (values (cons (op-on-ref (car kseed) 'js:+ 'post) seed) kdict)) ;; post-dec ((post-dec) (values (cons (op-on-ref (car kseed) 'js:- 'post) seed) kdict)) ;; delete ;; void ;; typeof ;; pre-inc ((pre-inc) (values (cons (op-on-ref (car kseed) 'js:+ 'pre) seed) kdict)) ;; pre-dec ((pre-dec) (values (cons (op-on-ref (car kseed) 'js:- 'pre) seed) kdict)) ;; pos neg ~ not ((pos) (opcall-node 'js:pos seed kseed kdict)) ((neg) (opcall-node 'js:neg seed kseed kdict)) ((lognot) (opcall-node 'js:lognot seed kseed kdict)) ((not) (opcall-node 'js:not seed kseed kdict)) ;; mul div mod add sub ((mul) (opcall-node 'js:* seed kseed kdict)) ((div) (opcall-node 'js:/ seed kseed kdict)) ((mod) (opcall-node 'js:% seed kseed kdict)) ((add) (opcall-node 'js:+ seed kseed kdict)) ((sub) (opcall-node 'js:- seed kseed kdict)) ;; lshift rshift rrshift ((lshift) (opcall-node 'js:lshift seed kseed kdict)) ((rshift) (opcall-node 'js:rshift seed kseed kdict)) ((rrshift) (opcall-node 'js:rrshift seed kseed kdict)) ;; lt gt le ge ((lt) (values (cons (op-call 'js:lt kseed) seed) kdict)) ((gt) (values (cons (op-call 'js:gt kseed) seed) kdict)) ((le) (values (cons (op-call 'js:le kseed) seed) kdict)) ((ge) (values (cons (op-call 'js:ge kseed) seed) kdict)) ;; instanceof ;; in ;; eq neq eq-eq neq-eq ((eq) (values (cons (op-call 'js:eq kseed) seed) kdict)) ((neq) (values (cons (op-call 'js:neq kseed) seed) kdict)) ((eq-eq) (values (cons (op-call 'js:neq-eq kseed) seed) kdict)) ((neq-eq) (values (cons (op-call 'js:neq-eq kseed) seed) kdict)) ;; bit-and bit-xor bit-or ((bit-and) (values (cons (op-call 'js:bit-and kseed) seed) kdict)) ((bit-xor) (values (cons (op-call 'js:bit-xor kseed) seed) kdict)) ((bit-or) (values (cons (op-call 'js:bit-or kseed) seed) kdict)) ;; and or ((and) (values (cons (op-call 'js:and kseed) seed) kdict)) ((or) (values (cons (op-call 'js:or kseed) seed) kdict)) ;; ConditionalExpression => (if expr a b) ((ConditionalExpression) (values (cons `(if ,(caddr kseed) ,(cadr kseed) ,(car kseed)) seed) kdict)) ;; AssignmentExpression ;; assign mul-assign div-assign od-assign add-assign sub-assign ;; lshift-assign rshift-assign rrshift-assign and-assign ;; xor-assign or-assign ;; Note that assignment needs to return the value always ((var-AssignmentExpression) (let* ((tail (rtail kseed)) ) (sferr "obj-Ass\n") (pperr (reverse kseed)) ;;(pperr tail) (values (cons (op-assn kseed) seed) kdict))) ((obj-AssignmentExpression) (let* ((tail (rtail kseed))) (values (cons '(void) seed) dict))) ;; expr-list ;; Block : has same elements as StatementList ;; except decl's will be let (by static semantics) ((Block) (values (cons (wrap-bindings (block (rtail kseed))) seed) kdict)) ((StatementList) (values (cons (block (rtail kseed)) seed) kdict)) ;; LetStatement ((LetStatement) (values (cons (car kseed) seed) kdict)) ;; VariableStatement ((VariableStatement) (values (cons (car kseed) seed) kdict)) ;; DeclarationList ((DeclarationList) (values (acons (if (top-level? dict) 'begin 'bindings) (rtail kseed) seed) kdict)) ;; VariableDeclaration ((VariableDeclaration) (let* ((tail (rtail kseed)) (name (cadar tail)) (gsym (if (eq? 'lexical (caar tail)) (caddar tail) #f)) (init (if (null? (cdr tail)) '(void) (cadr tail)))) ;;(sferr "vdef: name=~S init=~S gsym=~S\n" name init gsym) (values (cons (if (top-level? dict) `(define ,name ,init) `(bind ,name ,gsym ,init)) seed) kdict))) ;; Initializer ((Initializer) ; just grab the single argument (values (cons (car kseed) seed) kdict)) ;; EmptyStatement ((EmptyStatement) ; ignore (values seed dict)) ;; ExpressionStatement ((ExpressionStatement) ; just grab the single argument (values (cons (car kseed) seed) kdict)) ;; IfStatement ((IfStatement) (values (cons (if (= 3 (length kseed)) `(if ,(cadr kseed) ,(car kseed) (void)) `(if ,(caddr kseed) ,(cadr kseed) ,(car kseed))) seed) kdict)) ;; ===================================================================== ;; @subheading Iteration with @code{do}, @code{while} and @code{for} ;; ;; @item During fD we push scope w/ ~exit, the abort tag. ;; @item During fU we use that tag to abort for continue and break ;; @item for "switch" we map the continue handler to (abort #t) with ;; the parent tag ;; do: "do" stmt "while" expr ; ((do) (let* ((expr (car kseed)) (body (cadr kseed))) (values (cons (make-do-while expr body kdict) seed) (pop-scope kdict)))) ;; while: while expr stmt ((while) (let* ((expr (cadr kseed)) (body (car kseed))) (values (cons (make-while expr body kdict) seed) (pop-scope kdict)))) ;; for : pop-scope needed ;; for-in : pop-scope needed ;; NoExpression (used by for and for-in) ((NoExpression) (values (cons '(void) seed) kdict)) ;; ContinueStatement: abort w/ zero args ((ContinueStatement) (if (> (length kseed) 1) (throw 'js-error "unsupported: break