1 files changed, 197 insertions, 0 deletions
diff --git a/src/test/data/parser-test-1.scm b/src/test/data/parser-test-1.scm
new file mode 100644
index 0000000..87c41b5
--- /dev/null
+++ b/src/test/data/parser-test-1.scm
@@ -0,0 +1,197 @@
+;;; bytestructures --- Structured access to bytevector contents.
+
+;; Copyright © 2015, 2016 Taylan Kammer <taylan.kammer@gmail.com>
+
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This is the base of the module, defining the data types and procedures that
+;; make up the bytestructures framework.
+
+
+;;; Code:
+
+;;; Descriptors
+
+(drt <bsd>
+     (%mkbsd size align unwrap getter setter meta)
+     bsd?
+     (size   bsize)
+     (align  balign)
+     (unwrap bunwrp)
+     (getter bgettr)
+     (setter bsettr)
+     (meta   bmeta))
+
+(define mkbsd
+  (clmbda
+   ((size align unwrap getter setter)
+    (%mkbsd
+     size align unwrap getter setter #f))
+   ((size align unwrap getter setter meta)
+    (%mkbsd
+     size align unwrap getter setter meta))))
+
+(define bdsz
+  (clmbda
+   ((dscr) (bdsz dscr #f #f))
+   ((dscr bvec offset)
+    (let ((size (bsize dscr)))
+      (if (proc? size)
+          (size #f bvec offset)
+          size)))))
+
+(define (bdsz/s bvec offset dscr)
+  (let ((size (bsize dscr)))
+    (if (proc? size)
+        (size #t bvec offset)
+        size)))
+
+
+;;; Bstrs
+
+(drt <bstr>
+     (mkbstr bvec offset dscr)
+     bstr?
+     (bvec   bsbvec)
+     (offset bsofst)
+     (dscr   bsdscr))
+
+(define bstr
+  (clmbda ((dscr)        (%bstr dscr #f #f))
+          ((dscr values) (%bstr dscr #t values))))
+
+(define (%bstr dscr init? values)
+  (let ((bvec (mkbvec
+               (bdsz dscr))))
+    (when init?
+      (bspst! bvec 0 dscr values))
+    (mkbstr bvec 0 dscr)))
+
+(define (bssize bstr)
+  (bdsz (bsdscr bstr)
+        (bsbvec bstr)
+        (bsofst bstr)))
+
+(dsr (bsunwp <bstr> <indx> ...)
+     (let ((bstr <bstr>))
+       (let ((bvec   (bsbvec bstr))
+             (offset (bsofst bstr))
+             (dscr   (bsdscr bstr)))
+         (bsunwp bvec offset dscr <indx> ...))))
+
+(defsyn bsnwp*
+  (synrul ()
+          ((_ <bvec> <ofst> <dscr>)
+           (values <bvec> <ofst> <dscr>))
+          ((_ <bvec> <ofst> <dscr> <indx> <idxs> ...)
+           (let ((bvec <bvec>)
+                 (offset <ofst>)
+                 (dscr <dscr>))
+             (let ((unwrap (bunwrp dscr)))
+               (when (not unwrap)
+                 (error "cannot" dscr))
+               (letvls (((bvec* ofst* dscr*)
+                         (unwrap #f bvec offset <indx>)))
+                       (bsnwp*
+                        bvec* ofst* dscr* <idxs> ...)))))))
+
+(defsyr (bsref <bstr> <indx> ...)
+  (letvls (((bvec offset dscr)
+            (bsunwp <bstr> <indx> ...)))
+          (bspref bvec offset dscr)))
+
+(defsyr (bsref*
+         <bvec> <ofst> <dscr> <indx> ...)
+  (letvls (((bvec offset dscr)
+            (bsnwp*
+             <bvec> <ofst> <dscr> <indx> ...)))
+          (bspref bvec offset dscr)))
+
+(define (bspref bvec offset dscr)
+  (let ((getter (bdgtr dscr)))
+    (if getter
+        (getter #f bvec offset)
+        (mkbstr bvec offset dscr))))
+
+(defsyr (bsst! <bstr> <indx> ... <valu>)
+  (letvls (((bvec offset dscr)
+            (bsunwp <bstr> <indx> ...)))
+          (bsps! bvec offset dscr <valu>)))
+
+(defsyr (bsst!*
+         <bvec> <ofst> <dscr> <indx> ... <valu>)
+  (letvls (((bvec offset dscr)
+            (bsnwp*
+             <bvec> <ofst> <dscr> <indx> ...)))
+          (bspst! bvec offset dscr <valu>)))
+
+(define (bspst! bvec offset dscr value)
+  (let ((setter (bdstr dscr)))
+    (if setter
+        (setter #f bvec offset value)
+        (if (bvec? value)
+            (bvecop bvec offset value 0
+                    (bdsz
+                     dscr bvec offset))
+            (error "cannot"
+                   value dscr)))))
+
+(define (bsrf/d bstr . indxs)
+  (letvls (((bvec offset dscr)
+            (bsunwp bstr)))
+          (let loop ((bvec bvec)
+                     (offset offset)
+                     (dscr dscr)
+                     (indxs indxs))
+            (if (null? indxs)
+                (bspref bvec offset dscr)
+                (letvls (((bvec* ofst* dscr*)
+                          (bsnwp*
+                           bvec offset dscr (car indxs))))
+                        (loop bvec*
+                              ofst*
+                              dscr*
+                              (cdr indxs)))))))
+
+(define (bst!/d bstr . args)
+  (letvls (((bvec offset dscr)
+            (bsunwp bstr)))
+          (let loop ((bvec bvec)
+                     (offset offset)
+                     (dscr dscr)
+                     (args args))
+            (if (null? (cdr args))
+                (bset! bvec offset dscr (car args))
+                (letvls (((bvec* ofst* dscr*)
+                          (bsnwp*
+                           bvec offset dscr (car args))))
+                        (loop bvec*
+                              ofst*
+                              dscr*
+                              (cdr args)))))))
+
+(defsyn
+  bnwp/s
+  bref/s
+  bset/s
+  dba)
+
+(cexp
+ (guile  (incfp "bstrs"))
+ (syncas (incld "base"))
+ (else))
+
+;;; base.scm ends here