pax_global_header00006660000000000000000000000064140177172420014517gustar00rootroot0000000000000052 comment=27cadba6b69a01b38b33bb39b9766d713eb90c1b scheme-bytestructures-1.0.10/000077500000000000000000000000001401771724200161475ustar00rootroot00000000000000scheme-bytestructures-1.0.10/.gitignore000066400000000000000000000002051401771724200201340ustar00rootroot00000000000000*.go *.srfi64.log Makefile Makefile.in aclocal.m4 autom4te.cache/ config.log config.status configure install-sh missing pre-inst-env scheme-bytestructures-1.0.10/COPYING000066400000000000000000001045131401771724200172060ustar00rootroot00000000000000 GNU GENERAL PUBLIC LICENSE Version 3, 29 June 2007 Copyright (C) 2007 Free Software Foundation, Inc. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The GNU General Public License is a free, copyleft license for software and other kinds of works. The licenses for most software and other practical works are designed to take away your freedom to share and change the works. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change all versions of a program--to make sure it remains free software for all its users. We, the Free Software Foundation, use the GNU General Public License for most of our software; it applies also to any other work released this way by its authors. You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for them if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs, and that you know you can do these things. To protect your rights, we need to prevent others from denying you these rights or asking you to surrender the rights. Therefore, you have certain responsibilities if you distribute copies of the software, or if you modify it: responsibilities to respect the freedom of others. For example, if you distribute copies of such a program, whether gratis or for a fee, you must pass on to the recipients the same freedoms that you received. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. Developers that use the GNU GPL protect your rights with two steps: (1) assert copyright on the software, and (2) offer you this License giving you legal permission to copy, distribute and/or modify it. For the developers' and authors' protection, the GPL clearly explains that there is no warranty for this free software. For both users' and authors' sake, the GPL requires that modified versions be marked as changed, so that their problems will not be attributed erroneously to authors of previous versions. Some devices are designed to deny users access to install or run modified versions of the software inside them, although the manufacturer can do so. This is fundamentally incompatible with the aim of protecting users' freedom to change the software. The systematic pattern of such abuse occurs in the area of products for individuals to use, which is precisely where it is most unacceptable. Therefore, we have designed this version of the GPL to prohibit the practice for those products. If such problems arise substantially in other domains, we stand ready to extend this provision to those domains in future versions of the GPL, as needed to protect the freedom of users. Finally, every program is threatened constantly by software patents. States should not allow patents to restrict development and use of software on general-purpose computers, but in those that do, we wish to avoid the special danger that patents applied to a free program could make it effectively proprietary. To prevent this, the GPL assures that patents cannot be used to render the program non-free. The precise terms and conditions for copying, distribution and modification follow. TERMS AND CONDITIONS 0. Definitions. "This License" refers to version 3 of the GNU General Public License. "Copyright" also means copyright-like laws that apply to other kinds of works, such as semiconductor masks. "The Program" refers to any copyrightable work licensed under this License. Each licensee is addressed as "you". "Licensees" and "recipients" may be individuals or organizations. To "modify" a work means to copy from or adapt all or part of the work in a fashion requiring copyright permission, other than the making of an exact copy. The resulting work is called a "modified version" of the earlier work or a work "based on" the earlier work. A "covered work" means either the unmodified Program or a work based on the Program. To "propagate" a work means to do anything with it that, without permission, would make you directly or secondarily liable for infringement under applicable copyright law, except executing it on a computer or modifying a private copy. Propagation includes copying, distribution (with or without modification), making available to the public, and in some countries other activities as well. To "convey" a work means any kind of propagation that enables other parties to make or receive copies. Mere interaction with a user through a computer network, with no transfer of a copy, is not conveying. An interactive user interface displays "Appropriate Legal Notices" to the extent that it includes a convenient and prominently visible feature that (1) displays an appropriate copyright notice, and (2) tells the user that there is no warranty for the work (except to the extent that warranties are provided), that licensees may convey the work under this License, and how to view a copy of this License. If the interface presents a list of user commands or options, such as a menu, a prominent item in the list meets this criterion. 1. Source Code. The "source code" for a work means the preferred form of the work for making modifications to it. "Object code" means any non-source form of a work. A "Standard Interface" means an interface that either is an official standard defined by a recognized standards body, or, in the case of interfaces specified for a particular programming language, one that is widely used among developers working in that language. The "System Libraries" of an executable work include anything, other than the work as a whole, that (a) is included in the normal form of packaging a Major Component, but which is not part of that Major Component, and (b) serves only to enable use of the work with that Major Component, or to implement a Standard Interface for which an implementation is available to the public in source code form. A "Major Component", in this context, means a major essential component (kernel, window system, and so on) of the specific operating system (if any) on which the executable work runs, or a compiler used to produce the work, or an object code interpreter used to run it. The "Corresponding Source" for a work in object code form means all the source code needed to generate, install, and (for an executable work) run the object code and to modify the work, including scripts to control those activities. However, it does not include the work's System Libraries, or general-purpose tools or generally available free programs which are used unmodified in performing those activities but which are not part of the work. For example, Corresponding Source includes interface definition files associated with source files for the work, and the source code for shared libraries and dynamically linked subprograms that the work is specifically designed to require, such as by intimate data communication or control flow between those subprograms and other parts of the work. The Corresponding Source need not include anything that users can regenerate automatically from other parts of the Corresponding Source. The Corresponding Source for a work in source code form is that same work. 2. Basic Permissions. All rights granted under this License are granted for the term of copyright on the Program, and are irrevocable provided the stated conditions are met. This License explicitly affirms your unlimited permission to run the unmodified Program. The output from running a covered work is covered by this License only if the output, given its content, constitutes a covered work. This License acknowledges your rights of fair use or other equivalent, as provided by copyright law. You may make, run and propagate covered works that you do not convey, without conditions so long as your license otherwise remains in force. You may convey covered works to others for the sole purpose of having them make modifications exclusively for you, or provide you with facilities for running those works, provided that you comply with the terms of this License in conveying all material for which you do not control copyright. Those thus making or running the covered works for you must do so exclusively on your behalf, under your direction and control, on terms that prohibit them from making any copies of your copyrighted material outside their relationship with you. Conveying under any other circumstances is permitted solely under the conditions stated below. Sublicensing is not allowed; section 10 makes it unnecessary. 3. Protecting Users' Legal Rights From Anti-Circumvention Law. No covered work shall be deemed part of an effective technological measure under any applicable law fulfilling obligations under article 11 of the WIPO copyright treaty adopted on 20 December 1996, or similar laws prohibiting or restricting circumvention of such measures. When you convey a covered work, you waive any legal power to forbid circumvention of technological measures to the extent such circumvention is effected by exercising rights under this License with respect to the covered work, and you disclaim any intention to limit operation or modification of the work as a means of enforcing, against the work's users, your or third parties' legal rights to forbid circumvention of technological measures. 4. Conveying Verbatim Copies. You may convey verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice; keep intact all notices stating that this License and any non-permissive terms added in accord with section 7 apply to the code; keep intact all notices of the absence of any warranty; and give all recipients a copy of this License along with the Program. You may charge any price or no price for each copy that you convey, and you may offer support or warranty protection for a fee. 5. Conveying Modified Source Versions. You may convey a work based on the Program, or the modifications to produce it from the Program, in the form of source code under the terms of section 4, provided that you also meet all of these conditions: a) The work must carry prominent notices stating that you modified it, and giving a relevant date. b) The work must carry prominent notices stating that it is released under this License and any conditions added under section 7. This requirement modifies the requirement in section 4 to "keep intact all notices". c) You must license the entire work, as a whole, under this License to anyone who comes into possession of a copy. This License will therefore apply, along with any applicable section 7 additional terms, to the whole of the work, and all its parts, regardless of how they are packaged. This License gives no permission to license the work in any other way, but it does not invalidate such permission if you have separately received it. d) If the work has interactive user interfaces, each must display Appropriate Legal Notices; however, if the Program has interactive interfaces that do not display Appropriate Legal Notices, your work need not make them do so. A compilation of a covered work with other separate and independent works, which are not by their nature extensions of the covered work, and which are not combined with it such as to form a larger program, in or on a volume of a storage or distribution medium, is called an "aggregate" if the compilation and its resulting copyright are not used to limit the access or legal rights of the compilation's users beyond what the individual works permit. Inclusion of a covered work in an aggregate does not cause this License to apply to the other parts of the aggregate. 6. Conveying Non-Source Forms. You may convey a covered work in object code form under the terms of sections 4 and 5, provided that you also convey the machine-readable Corresponding Source under the terms of this License, in one of these ways: a) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by the Corresponding Source fixed on a durable physical medium customarily used for software interchange. b) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by a written offer, valid for at least three years and valid for as long as you offer spare parts or customer support for that product model, to give anyone who possesses the object code either (1) a copy of the Corresponding Source for all the software in the product that is covered by this License, on a durable physical medium customarily used for software interchange, for a price no more than your reasonable cost of physically performing this conveying of source, or (2) access to copy the Corresponding Source from a network server at no charge. c) Convey individual copies of the object code with a copy of the written offer to provide the Corresponding Source. This alternative is allowed only occasionally and noncommercially, and only if you received the object code with such an offer, in accord with subsection 6b. d) Convey the object code by offering access from a designated place (gratis or for a charge), and offer equivalent access to the Corresponding Source in the same way through the same place at no further charge. You need not require recipients to copy the Corresponding Source along with the object code. If the place to copy the object code is a network server, the Corresponding Source may be on a different server (operated by you or a third party) that supports equivalent copying facilities, provided you maintain clear directions next to the object code saying where to find the Corresponding Source. Regardless of what server hosts the Corresponding Source, you remain obligated to ensure that it is available for as long as needed to satisfy these requirements. e) Convey the object code using peer-to-peer transmission, provided you inform other peers where the object code and Corresponding Source of the work are being offered to the general public at no charge under subsection 6d. A separable portion of the object code, whose source code is excluded from the Corresponding Source as a System Library, need not be included in conveying the object code work. A "User Product" is either (1) a "consumer product", which means any tangible personal property which is normally used for personal, family, or household purposes, or (2) anything designed or sold for incorporation into a dwelling. In determining whether a product is a consumer product, doubtful cases shall be resolved in favor of coverage. For a particular product received by a particular user, "normally used" refers to a typical or common use of that class of product, regardless of the status of the particular user or of the way in which the particular user actually uses, or expects or is expected to use, the product. A product is a consumer product regardless of whether the product has substantial commercial, industrial or non-consumer uses, unless such uses represent the only significant mode of use of the product. "Installation Information" for a User Product means any methods, procedures, authorization keys, or other information required to install and execute modified versions of a covered work in that User Product from a modified version of its Corresponding Source. The information must suffice to ensure that the continued functioning of the modified object code is in no case prevented or interfered with solely because modification has been made. If you convey an object code work under this section in, or with, or specifically for use in, a User Product, and the conveying occurs as part of a transaction in which the right of possession and use of the User Product is transferred to the recipient in perpetuity or for a fixed term (regardless of how the transaction is characterized), the Corresponding Source conveyed under this section must be accompanied by the Installation Information. But this requirement does not apply if neither you nor any third party retains the ability to install modified object code on the User Product (for example, the work has been installed in ROM). The requirement to provide Installation Information does not include a requirement to continue to provide support service, warranty, or updates for a work that has been modified or installed by the recipient, or for the User Product in which it has been modified or installed. Access to a network may be denied when the modification itself materially and adversely affects the operation of the network or violates the rules and protocols for communication across the network. Corresponding Source conveyed, and Installation Information provided, in accord with this section must be in a format that is publicly documented (and with an implementation available to the public in source code form), and must require no special password or key for unpacking, reading or copying. 7. Additional Terms. "Additional permissions" are terms that supplement the terms of this License by making exceptions from one or more of its conditions. Additional permissions that are applicable to the entire Program shall be treated as though they were included in this License, to the extent that they are valid under applicable law. If additional permissions apply only to part of the Program, that part may be used separately under those permissions, but the entire Program remains governed by this License without regard to the additional permissions. When you convey a copy of a covered work, you may at your option remove any additional permissions from that copy, or from any part of it. (Additional permissions may be written to require their own removal in certain cases when you modify the work.) You may place additional permissions on material, added by you to a covered work, for which you have or can give appropriate copyright permission. Notwithstanding any other provision of this License, for material you add to a covered work, you may (if authorized by the copyright holders of that material) supplement the terms of this License with terms: a) Disclaiming warranty or limiting liability differently from the terms of sections 15 and 16 of this License; or b) Requiring preservation of specified reasonable legal notices or author attributions in that material or in the Appropriate Legal Notices displayed by works containing it; or c) Prohibiting misrepresentation of the origin of that material, or requiring that modified versions of such material be marked in reasonable ways as different from the original version; or d) Limiting the use for publicity purposes of names of licensors or authors of the material; or e) Declining to grant rights under trademark law for use of some trade names, trademarks, or service marks; or f) Requiring indemnification of licensors and authors of that material by anyone who conveys the material (or modified versions of it) with contractual assumptions of liability to the recipient, for any liability that these contractual assumptions directly impose on those licensors and authors. All other non-permissive additional terms are considered "further restrictions" within the meaning of section 10. If the Program as you received it, or any part of it, contains a notice stating that it is governed by this License along with a term that is a further restriction, you may remove that term. If a license document contains a further restriction but permits relicensing or conveying under this License, you may add to a covered work material governed by the terms of that license document, provided that the further restriction does not survive such relicensing or conveying. If you add terms to a covered work in accord with this section, you must place, in the relevant source files, a statement of the additional terms that apply to those files, or a notice indicating where to find the applicable terms. Additional terms, permissive or non-permissive, may be stated in the form of a separately written license, or stated as exceptions; the above requirements apply either way. 8. Termination. You may not propagate or modify a covered work except as expressly provided under this License. Any attempt otherwise to propagate or modify it is void, and will automatically terminate your rights under this License (including any patent licenses granted under the third paragraph of section 11). However, if you cease all violation of this License, then your license from a particular copyright holder is reinstated (a) provisionally, unless and until the copyright holder explicitly and finally terminates your license, and (b) permanently, if the copyright holder fails to notify you of the violation by some reasonable means prior to 60 days after the cessation. Moreover, your license from a particular copyright holder is reinstated permanently if the copyright holder notifies you of the violation by some reasonable means, this is the first time you have received notice of violation of this License (for any work) from that copyright holder, and you cure the violation prior to 30 days after your receipt of the notice. Termination of your rights under this section does not terminate the licenses of parties who have received copies or rights from you under this License. If your rights have been terminated and not permanently reinstated, you do not qualify to receive new licenses for the same material under section 10. 9. Acceptance Not Required for Having Copies. You are not required to accept this License in order to receive or run a copy of the Program. Ancillary propagation of a covered work occurring solely as a consequence of using peer-to-peer transmission to receive a copy likewise does not require acceptance. However, nothing other than this License grants you permission to propagate or modify any covered work. These actions infringe copyright if you do not accept this License. Therefore, by modifying or propagating a covered work, you indicate your acceptance of this License to do so. 10. Automatic Licensing of Downstream Recipients. Each time you convey a covered work, the recipient automatically receives a license from the original licensors, to run, modify and propagate that work, subject to this License. You are not responsible for enforcing compliance by third parties with this License. An "entity transaction" is a transaction transferring control of an organization, or substantially all assets of one, or subdividing an organization, or merging organizations. If propagation of a covered work results from an entity transaction, each party to that transaction who receives a copy of the work also receives whatever licenses to the work the party's predecessor in interest had or could give under the previous paragraph, plus a right to possession of the Corresponding Source of the work from the predecessor in interest, if the predecessor has it or can get it with reasonable efforts. You may not impose any further restrictions on the exercise of the rights granted or affirmed under this License. For example, you may not impose a license fee, royalty, or other charge for exercise of rights granted under this License, and you may not initiate litigation (including a cross-claim or counterclaim in a lawsuit) alleging that any patent claim is infringed by making, using, selling, offering for sale, or importing the Program or any portion of it. 11. Patents. A "contributor" is a copyright holder who authorizes use under this License of the Program or a work on which the Program is based. The work thus licensed is called the contributor's "contributor version". A contributor's "essential patent claims" are all patent claims owned or controlled by the contributor, whether already acquired or hereafter acquired, that would be infringed by some manner, permitted by this License, of making, using, or selling its contributor version, but do not include claims that would be infringed only as a consequence of further modification of the contributor version. For purposes of this definition, "control" includes the right to grant patent sublicenses in a manner consistent with the requirements of this License. Each contributor grants you a non-exclusive, worldwide, royalty-free patent license under the contributor's essential patent claims, to make, use, sell, offer for sale, import and otherwise run, modify and propagate the contents of its contributor version. In the following three paragraphs, a "patent license" is any express agreement or commitment, however denominated, not to enforce a patent (such as an express permission to practice a patent or covenant not to sue for patent infringement). To "grant" such a patent license to a party means to make such an agreement or commitment not to enforce a patent against the party. If you convey a covered work, knowingly relying on a patent license, and the Corresponding Source of the work is not available for anyone to copy, free of charge and under the terms of this License, through a publicly available network server or other readily accessible means, then you must either (1) cause the Corresponding Source to be so available, or (2) arrange to deprive yourself of the benefit of the patent license for this particular work, or (3) arrange, in a manner consistent with the requirements of this License, to extend the patent license to downstream recipients. "Knowingly relying" means you have actual knowledge that, but for the patent license, your conveying the covered work in a country, or your recipient's use of the covered work in a country, would infringe one or more identifiable patents in that country that you have reason to believe are valid. If, pursuant to or in connection with a single transaction or arrangement, you convey, or propagate by procuring conveyance of, a covered work, and grant a patent license to some of the parties receiving the covered work authorizing them to use, propagate, modify or convey a specific copy of the covered work, then the patent license you grant is automatically extended to all recipients of the covered work and works based on it. A patent license is "discriminatory" if it does not include within the scope of its coverage, prohibits the exercise of, or is conditioned on the non-exercise of one or more of the rights that are specifically granted under this License. You may not convey a covered work if you are a party to an arrangement with a third party that is in the business of distributing software, under which you make payment to the third party based on the extent of your activity of conveying the work, and under which the third party grants, to any of the parties who would receive the covered work from you, a discriminatory patent license (a) in connection with copies of the covered work conveyed by you (or copies made from those copies), or (b) primarily for and in connection with specific products or compilations that contain the covered work, unless you entered into that arrangement, or that patent license was granted, prior to 28 March 2007. Nothing in this License shall be construed as excluding or limiting any implied license or other defenses to infringement that may otherwise be available to you under applicable patent law. 12. No Surrender of Others' Freedom. If conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot convey a covered work so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not convey it at all. For example, if you agree to terms that obligate you to collect a royalty for further conveying from those to whom you convey the Program, the only way you could satisfy both those terms and this License would be to refrain entirely from conveying the Program. 13. Use with the GNU Affero General Public License. Notwithstanding any other provision of this License, you have permission to link or combine any covered work with a work licensed under version 3 of the GNU Affero General Public License into a single combined work, and to convey the resulting work. The terms of this License will continue to apply to the part which is the covered work, but the special requirements of the GNU Affero General Public License, section 13, concerning interaction through a network will apply to the combination as such. 14. Revised Versions of this License. The Free Software Foundation may publish revised and/or new versions of the GNU General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies that a certain numbered version of the GNU General Public License "or any later version" applies to it, you have the option of following the terms and conditions either of that numbered version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the GNU General Public License, you may choose any version ever published by the Free Software Foundation. If the Program specifies that a proxy can decide which future versions of the GNU General Public License can be used, that proxy's public statement of acceptance of a version permanently authorizes you to choose that version for the Program. Later license versions may give you additional or different permissions. However, no additional obligations are imposed on any author or copyright holder as a result of your choosing to follow a later version. 15. Disclaimer of Warranty. THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. Limitation of Liability. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. 17. Interpretation of Sections 15 and 16. If the disclaimer of warranty and limitation of liability provided above cannot be given local legal effect according to their terms, reviewing courts shall apply local law that most closely approximates an absolute waiver of all civil liability in connection with the Program, unless a warranty or assumption of liability accompanies a copy of the Program in return for a fee. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively state the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 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 . Also add information on how to contact you by electronic and paper mail. If the program does terminal interaction, make it output a short notice like this when it starts in an interactive mode: Copyright (C) This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, your program's commands might be different; for a GUI interface, you would use an "about box". You should also get your employer (if you work as a programmer) or school, if any, to sign a "copyright disclaimer" for the program, if necessary. For more information on this, and how to apply and follow the GNU GPL, see . The GNU General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. But first, please read . scheme-bytestructures-1.0.10/Makefile.am000066400000000000000000000037661401771724200202170ustar00rootroot00000000000000include guile.am moddir=$(prefix)/share/guile/site/$(GUILE_EFFECTIVE_VERSION) godir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache SOURCES = \ bytestructures/guile.scm \ bytestructures/guile/base.scm \ bytestructures/guile/bitfields.scm \ bytestructures/guile/bytevectors.scm \ bytestructures/guile/cstring-pointer.scm \ bytestructures/guile/explicit-endianness.scm \ bytestructures/guile/ffi.scm \ bytestructures/guile/numeric-all.scm \ bytestructures/guile/numeric-data-model.scm \ bytestructures/guile/numeric-metadata.scm \ bytestructures/guile/numeric.scm \ bytestructures/guile/pointer.scm \ bytestructures/guile/string.scm \ bytestructures/guile/struct.scm \ bytestructures/guile/union.scm \ bytestructures/guile/utils.scm \ bytestructures/guile/vector.scm \ bytestructures/r6/bytevectors.scm NOCOMP_SOURCES = \ bytestructures/body/align.scm \ bytestructures/body/base.scm \ bytestructures/body/base.syntactic.scm \ bytestructures/body/bitfields.scm \ bytestructures/body/explicit-endianness.scm \ bytestructures/body/numeric.scm \ bytestructures/body/string.scm \ bytestructures/body/struct.scm \ bytestructures/body/union.scm \ bytestructures/body/utils.scm \ bytestructures/body/vector.scm \ bytestructures/r7/base.exports.sld \ bytestructures/r7/bitfields.exports.sld \ bytestructures/r7/explicit-endianness.exports.sld \ bytestructures/r7/numeric.exports.sld \ bytestructures/r7/numeric-metadata.exports.sld \ bytestructures/r7/string.exports.sld \ bytestructures/r7/struct.exports.sld \ bytestructures/r7/union.exports.sld \ bytestructures/r7/vector.exports.sld EXTRA_DIST += \ COPYING \ README.md \ pre-inst-env.in \ run-tests.body.scm \ run-tests.guile.scm \ run-tests.r7.scm check: $(top_builddir)/pre-inst-env \ $(GUILE) --no-auto-compile \ $(top_srcdir)/run-tests.guile.scm .PHONY: check scheme-bytestructures-1.0.10/README.md000066400000000000000000001035151401771724200174330ustar00rootroot00000000000000# Structured access to bytevector contents ## Example ```scheme ;; define a scheme bytestructure for a C struct (define my-position-struct (bs:struct `((x ,int) (y ,int)))) ;; initialize an instance of `my-position-struct` (define position (bytestructure my-position-struct)) ;; bytestructure-set! (bytestructure-set! position 'x 42) (bytestructure-set! position 'y 101) ;; bytestructure-ref (bytestructure-ref position 'x) ;; => 42 ;; retrieve the underlying bytevector (define bv (bytestructure-bytevector position)) ;; => #vu8(42 0 0 0 101 0 0 0) ;; creating a bytestructure from an existing bytevector (define position2 (make-bytestructure bv 0 my-position-struct)) ``` There is also a faster macro API. ## Introduction This library offers a system imitating the type system of the C programming language, to be used on bytevectors. C's type system works on raw memory, and ours works on bytevectors which are an abstraction over raw memory in Scheme. The system is in fact more powerful than the C type system, elevating types to first-class status. A C type corresponds to a "bytestructure descriptor" object in our system. ```scheme ;; typedef uint8_t uint8_v3_t[3]; (define uint8-v3 (bs:vector 3 uint8)) ;; typedef struct { uint16_t x; uint8_v3_t y; } my_struct_t; (define my-struct (bs:struct `((x ,uint16) (y ,uint8-v3)))) ``` These can then be bundled with a bytevector, yielding a "bytestructure" object on which referencing and assignment work in accordance with the types declared in the descriptor. ```scheme ;; my_struct_t str; (define str (bytestructure my-struct)) ;; my_struct_t str = { 0, 1 }; (define str (bytestructure my-struct #(0 1))) ;; str.y[2] (bytestructure-ref str 'y 2) ;; str.y[2] = 42; (bytestructure-set! str 'y 2 42) ``` If your Scheme implementation supports syntax-case, then a macro-based API is available as well, for when the procedural API is too slow for your purposes. ```scheme (define-bytestructure-accessors my-struct my-struct-unwrap my-struct-ref my-struct-set!) (define foo (make-bytevector ...)) ;; foo.y[2] (my-struct-ref foo y 2) ;; foo.y[2] = 42; (my-struct-set! foo y 2 42) ``` (Note that we don't use the bytestructure data type anymore; we work directly on bytevectors. The struct fields are also implicitly quoted and can't be variable references, since their look-up will happen at compile time. The unwrapper will be explained later.) There are also "dynamic" bytestructure descriptors, whose behavior depends on the bytevector on which they're used. For instance a binary file format may specify that there are tag bytes declaring the lengths of following fields. The system can express this cleanly. ## Supported platforms R7RS and GNU Guile are supported. Detailed instructions per Scheme implementation follow. ### Chibi - Clone the Larceny source repository: ``` git clone https://github.com/larcenists/larceny ``` - Append `$larceny_repo/tools/R6RS` to the Chibi load-path via the `-A` command-line flag. - Append this directory to the Chibi load-path via the `-A` command-line flag. - Import `(bytestructures r7)`. ### Gauche - Clone the Larceny source repository: ``` git clone https://github.com/larcenists/larceny ``` - Go to its `tools/R6RS/r6rs/` sub-directory. - Run the following shell command in that directory and its sub-directories: ```bash for file in *.sld; do name=${file%.sld} ln -s $file $name.scm done ``` - Add `$larceny_repo/tools/R6RS` to `GAUCHE_LOAD_PATH`. - Add this directory to `GAUCHE_LOAD_PATH`. - Import `(bytestructures r7)`. ### Guile - Add this directory to `GUILE_LOAD_PATH`. (You can use the `-L` command line flag instead of augmenting `GUILE_LOAD_PATH`, but don't use it with a relative path, because `include-from-path` doesn't work well with that, which we use.) - Import `(bytestructures guile)`. ### Kawa - Clone the Larceny source repository: ``` git clone https://github.com/larcenists/larceny ``` - Run Kawa with a command line flag such as the following to add `$larceny_repo/tools/R6RS` and this directory to the load path, and to make it look for `.sld` files: ``` -Dkawa.import.path="$bytestructures_repo/*.sld:$larceny_repo/tools/R6RS/*.sld" ``` (The `*` stands for any number of directories, so sub-directories will also be searched for `.sld` files.) - Import `(bytestructures r7)`. ### Larceny - Add this directory to `LARCENY_LIBPATH`. - Run Larceny with the `-r7rs` flag. - Import `(bytestructures r7)`. ## Specification A *bytestructure descriptor*, also called simply a descriptor within this specification, is an object encapsulating information about the layout and meanings of the bytes in a bytevector object. A *bytestructure* is an object bundling a bytevector with a bytestructure descriptor so that values can be extracted from that bytevector conveniently, using the information in the descriptor. A *dynamic descriptor* is a bytestructure descriptor whose `size` and/or `unwrapper` procedures reference their `bytevector` and/or `offset` arguments. (See below.) The argument name `descriptor` signifies that an argument must be a bytestructure descriptor, `bytestructure` signifies that it must be a bytestructure, and `offset` signifies that it must be an exact non-negative integer. Knowledge of the C programming language is recommended for a proper understanding of this specification. Specifically, example code is often annotated with conceptually equivalent C code. ### High-level API A set of predefined bytestructure descriptors, as well as procedures for creating compound descriptors of certain kinds, are provided to the user, mostly obviating the need to work with the bytestructure descriptor API directly, which is explained further below. #### Constructors for compound descriptors ##### bs:vector - `(bs:vector length descriptor)` *procedure* Returns a descriptor for vectors, also called a *vector descriptor*, of length `length` and the *element descriptor* `descriptor`. This corresponds to an *array type* in the C programming language. ```scheme ;; uint16_t vec[3] = { 0, 1, 2 }; (define vec (bytestructure (bs:vector 3 uint16) #(0 1 2))) ;; vec[1] (bytestructure-ref vec 1) ;; vec[1] = 42; (bytestructure-set! vec 1 42) ``` The elements are indexed with exact non-negative integers, and no bounds checking is done; an off-bounds index will either raise an error due to an off-bounds bytevector index, or attempt to decode whatever bytes are found at the relevant place in the bytevector, which might result in a valid value without raising an error. Vector descriptors are normally meant for indexing through, but also allow direct assignment. The value provided for assignment must be a regular Scheme vector of the same length as the vector descriptor. Each element of that vector is assigned to the corresponding element of the vector bytestructure, using the assignment semantics of the element descriptor. ```scheme ;; (Reusing 'vec' from the previous example.) ;; Uses bytevector-u16-set! three times. (bytestructure-set! vec #(21 42 84)) ``` One may also provide a bytevector, in which case as many bytes as the size of the bytestructure will be copied into it. ```scheme ;; The results of this depend on endianness. ;; Only the first 6 bytes from the bytevector will be copied. (bytestructure-set! vec #u8(0 1 2 3 4 5 6 7 8)) ``` These assignment semantics may not be used with the macro API. Vector descriptors don't accept dynamic descriptors as their element descriptor, because they calculate their total size eagerly and thus need to know the size of their element descriptor independently from the bytevector on which they will be used. ##### bs:struct - `(bs:struct fields)` *procedure* - `(bs:struct pack fields)` *procedure* Returns a descriptor for structs, also called a *struct descriptor*. `Fields` must be a list of *field specs* (see below). `Pack` may be `#f`, `#t`, or an exact positive integer. If `pack` is omitted or `#f`, the struct alignment of the platform's C ABI is used. If `pack` is `#t`, there are no padding fields (except for those resulting from bit-fields). If `pack` is an integer, it specifies the maximum alignment value for the fields, similar to the `#pack` directive of the GCC C compiler. A *field spec* is a list of two or three elements. The first element must be a symbol which names the field (or `#f`, see below). Every field must have a distinct name (except if `#f`). The second element must be a bytestructure descriptor which becomes the descriptor of the field. The third element, if present, must be an exact non-negative integer; it signifies that the field is a bit-field of that width. The descriptor of a bit-field must be one that decodes values to exact integers, such as for instance `uint8` or `int32`. The width of a bit-field may be zero, which means padding should be inserted in its place until the next alignment boundary of the descriptor of that bit-field is reached. A zero-width bit-field must have `#f` as its name. ```scheme ;; typedef struct { uint8_t x; uint16_t y; } my_struct_t; (define my-struct (bs:struct `((x ,uint8) (y ,uint16)))) ;; my_struct_t str = { 0, 1 }; (define str (bytestructure my-struct #(0 1))) ;; my_struct_t str = { .y = 1, .x = 0 }; (define str (bytestructure my-struct '((y 1) (x 0)))) ;; str.y (bytestructure-ref str 'y) ;; str.y = 42; (bytestructure-set! str 'y 42) ;; Assuming a 32-bit platform: ;; struct { unsigned int a:16; unsigned int b:16; } (bs:struct `((a ,uint32 16) (b ,uint32 16))) ;; struct { unsigned int a:16; int :0; signed int b:20; } (bs:struct `((a ,uint32 16) (#f ,int32 0) (b ,int32 20))) ``` Struct descriptors are normally meant for indexing through, but also allow direct assignment. The value provided for assignment may be a Scheme vector as long as there are fields in the struct descriptor, which will assign all fields sequentially; or a list of two-element lists, which will assign any number of fields by name. ```scheme ;; (Reusing 'str' from the previous example.) ;; str = (my_struct_t){ 0, 1 }; (bytestructure-set! str #(0 1)) ;; str = (my_struct_t){ .y = 2, .x = 1 }; (bytestructure-set! str '((y 2) (x 1))) ``` One may also provide a bytevector, in which case as many bytes as the size of the bytestructure will be copied into it. ```scheme ;; The field 'x' is set to 0; the value of the field 'y' will ;; depend on endianness. ;; Only the first 3 bytes from the bytevector will be copied. (bytestructure-set! str #u8(0 1 2 3 4 5)) ``` These assignment semantics may not be used with the macro API. Struct descriptors don't accept dynamic descriptors as field descriptors, because they calculate their total size eagerly. When using the macro API, the field names are implicitly quoted and looked up at macro-expand time. ```scheme (define-bytestructure-accessors my-struct my-struct-unwrap my-struct-ref my-struct-set!) ;; foo.y (my-struct-ref foo-bytevector y) ;; foo.y = 42; (my-struct-set! foo-bytevector y 42) ``` ##### bs:union - `(bs:union fields)` *procedure* Returns a descriptor for unions, also called a *union descriptor*. `Fields` has the same format as in `bs:struct`. ``` ;; typedef union { uint8_t x; uint16_t y; } my_union_t; (define my-union (bs:union `((x ,uint8) (y ,uint16)))) ;; my_union_t union = { .y = 42 }; (define union (bytestructure my-union '(y 42))) ;; union.y (bytestructure-ref union 'y) ;; union.y = 42; (bytestructure-set! union 'y 42) ``` Union descriptors are normally meant for indexing through, but also allow direct assignment. The value provided for assignment must be a two-element list, whose first element names the field whose descriptor should be used for the assignment, and the second element provides the value to be actually assigned. ```scheme ;; union.y = 42; (bytestructure-set! union '(y 42)) ``` *Rationale:* This syntax isn't shorter than the normal way of assigning a value into the union, but is supported for reasons that should become apparent after reading the specification of the `bytestructure` constructor procedure. One may also provide a bytevector, in which case as many bytes as the size of the bytestructure will be copied into it. ``` ;; The value of the y field will depend on endianness. ;; Only the first 2 bytes from the bytevector will be copied. (bytestructure-set! union #u8(0 1 2 3 4)) ``` These assignment semantics may not be used with the macro API. Union descriptors don't accept dynamic descriptors as field descriptors, because they calculate their total size eagerly. ##### bs:pointer - `(bs:pointer descriptor)` *procedure* Returns a descriptor for pointers, also called a *pointer descriptor*, with the *content descriptor* `descriptor`. Such a descriptor indicates that the bytes in a given bytevector are to be interpreted as a memory address. The content descriptor is the descriptor for the bytes found at that memory address. ```scheme ;; foo_struct *ptr = 0x12345678; (define ptr (bytestructure (bs:pointer foo-struct) #x12345678)) ``` For void pointers, the symbol `void` may be used in place of a content descriptor: ```scheme ;; void *ptr; (define ptr (bytestructure (bs:pointer 'void))) ``` As a special case, the `descriptor` argument to `bs:pointer` may be a promise, which must evaluate to a descriptor when forced. This is to allow creating self-referencing descriptors: ```scheme ;; typedef struct linked_uint8_list_s { ;; uint8_t head; ;; struct linked_uint8_list_s *tail; ;; } *linked_uint8_list_t; (define linked-uint8-list (bs:pointer (delay (bs:struct `((head ,uint8) (tail ,linked-uint8-list)))))) ``` The symbol `*` can be used as an index to dereference the pointer. (It's implicitly quoted when used in the macro API.) An array of bytes as large as the size of the content descriptor, starting from the memory address of the pointer, are reified into a bytevector object, and bundled with the content descriptor, to yield a new bytestructure object. ```scheme ;; linked_uint8_list_t u8list; (define u8list (bytestructure linked-uint8-list)) ;; (*u8list).head (bytestructure-ref u8list '* 'head) ;; (*u8list).head = 42; (bytestructure-set! u8list '* 'head 42) ``` One may however also provide any other index, which will cause an implicit dereference. ```scheme ;; u8list->head (bytestructure-ref u8list 'head) ;; u8list->head = 42; (bytestructure-set! u8list 'head 42) ``` Since pointers are also values themselves, pointer descriptors also have direct referencing and assignment semantics. Referencing the pointer yields the numeric value of the address. ```scheme ;; linked_uint8_list_t u8lists[3]; (define u8lists (bytestructure (bs:vector 3 linked-uint8-list))) ;; Returns the address stored in u8lists[1]. (bytestructure-ref u8lists 1) ``` Assignment with a pointer descriptor allows a variety of values. Firstly, a numeric value (taken to be a memory address) may be given, which causes that value itself to be written. ```scheme ;; uint8_t (*u8v3-ptr)[3]; (define u8v3-ptr (bytestructure (bs:pointer (bs:vector 3 uint8)))) ;; u8v3-ptr = 0xdeadbeef; (bytestructure-set! u8v3-ptr #xdeadbeef) ``` A bytevector may be given, in which case the memory address of the first byte of the bytevector is written. ```scheme ;; Makes the pointer point to 'a-bytevector'. (bytestructure-set! u8v3-ptr a-bytevector) ``` Lastly, providing a bytestructure is equivalent to providing the bytevector of that bytestructure. ```scheme ;; Makes the pointer point to the bytevector of 'a-bytestructure'. (bytestructure-set! u8v3-ptr a-bytestructure) ``` These assignment semantics may be used with the macro API as well. Pointers don't accept dynamic descriptors as their content descriptor. *Rationale:* The bytevector that is pointed to is reified "on the fly" during referencing operations, for which its size needs to be known in advance. Needing the bytevector to already exist for calculating its size (as is the case for dynamic descriptors) imposes a problem of circularity. *Note:* Having an address written into a bytevector may not protect it from garbage collection. Thus using pointer descriptors might make a Scheme program memory unsafe even if the Scheme implementation is otherwise memory safe. #### Numeric descriptors The following descriptors for numeric types are provided: `[u]int(8,16,32,64)[le,be]`, `float(32,64)[le,be]`, `complex(64,128)[le,be]` On platforms with little-endian byte order, the descriptors whose name ends in `le` are equivalent as per `eqv?` to their variant without an explicit endianness marker. The same applies for the big-endian descriptors on big-endian platforms. The following are each equivalent as per `eqv?` to one of the above listed descriptors, depending on the platform on which the Scheme program is run: `[unsigned-](short,int,long,long-long)`, `[u]intptr_t`, `[s]size_t`, `ptrdiff_t`, `float`, `double` These descriptors cannot be indexed through as for instance vectors and structs can; they can only be used to directly reference or assign values. ```scheme ;; uint32_t x; (define x (bytestructure uint32)) ;; x = 42; (bytestructure-set! x 42) ;; uint32_t xs[3]; (define xs (bytestructure (bs:vector 3 uint32))) ;; xs[1] = 42; (bytestructure-set! xs 1 42) ``` #### String descriptors - `(bs:string size encoding)` *procedure* Returns a descriptor for a string occupying `size` bytes, encoded in `encoding` (a symbol). Currently supported encodings: - `ascii` - `utf8` - `utf16le` - `utf16be` - `utf32le` - `utf32be` If the ASCII encoding is specified, an error is raised if a non-ASCII character is encountered during encoding or decoding. Byte-order marks are not supported (yet). ```scheme (define x (bytestructure (bs:string 8 'utf16le))) (bytestructure-set! x "1234") (bytestructure-ref x) ;=> "1234" ``` When writing a string into a bytevector via such a descriptor, the given string must fit into the given size after encoding, otherwise an error is raised. If the string is shorter than the size, the remaining bytes of the bytevector are zeroed if the specified encoding is variable-width (UTF-8 and UTF-16), otherwise an error is raised. ```scheme (define x (bytestructure (bs:string 4 'utf8))) (bytestructure-set! x "12345") ;error (bytestructure-set! x "123") (bytestructure-ref x) ;=> "123\x00" ``` #### Null-terminated C strings *Currently only supported on Guile.* The `cstring-pointer` descriptor can be used to represent a pointer to a null-terminated string. A reference operation will return that string as a Scheme string. The setter only takes addresses to existing C strings however, due to the difficulty of holding a reference to the associated pointer object in Scheme. ```scheme (import (prefix (system foreign) ffi:)) ;use Guile FFI module (define bs (bytestructure cstring-pointer)) ;; This creates a null-terminated string "foobar\0" in memory, giving ;; us a pointer object holding its address. (define ptr (ffi:string->pointer "foobar")) ;; Write the address of "foobar\0" into the backing bytevector. (bytestructure-set! bs (ffi:pointer-address ptr)) ;; Get the null-terminated string whose address is found in the ;; backing bytevector. (bytestructure-ref bs) ;=> "foobar" ``` #### The bytestructure data type - `(make-bytestructure bytevector offset descriptor)` *procedure* Returns a bytestructure object with the given bytevector, offset into the bytevector, and bytestructure descriptor. *Rationale:* Any bytestructure descriptor can be used with any bytevector to work on it momentarily in accordance with the descriptor, but in most cases a bytevector is dedicated to a certain structure, so it makes sense to bundle a descriptor with the bytevector. Or only a portion of the bytevector, starting from a certain offset, might be dedicated to the structure, so being able to bundle that offset is also useful. - `(bytestructure? obj)` *procedure* Returns a Boolean indicating whether `obj` is a bytestructure. - `(bytestructure-bytevector bytestructure)` *procedure* - `(bytestructure-offset bytestructure)` *procedure* - `(bytestructure-descriptor bytestructure)` *procedure* These procedures return the `bytevector`, `offset`, and `descriptor` values respectively, with which `bytestructure` was created. - `(bytestructure-size bytestructure)` *procedure* Returns the size of the structure contained within `bytestructure`. - `(bytestructure descriptor)` *procedure* - `(bytestructure descriptor initial-value)` *procedure* Creates a bytestructure with a newly allocated bytevector of the right size for `descriptor` and an offset of 0, and optionally initializes it with values. The following two expressions are equivalent: ```scheme (define bs (bytestructure descriptor)) ``` ```scheme (define bs (make-bytestructure (make-bytevector (bytestructure-descriptor-size descriptor)) 0 descriptor)) ``` The optional second argument is passed to `bytestructure-set!` to assign the given values to the bytestructure after creation, meaning the following two expressions are equivalent: ```scheme (define bs (bytestructure descriptor values)) (let ((bs (bytestructure descriptor))) (bytestructure-set! bs values) bs) ``` Since the setter procedures of compound descriptors tend to delegate the assignment of individual elements to their respective descriptors, one can easily initialize structures to arbitrary depth. ```scheme (define my-struct (bs:struct `((x ,uint16) (y ,(bs:vector 3 uint8))))) (define bs (bytestructure my-struct '((x 0) (y #(0 1 2))))) ``` #### Referencing and assignment - `(bytestructure-ref bytestructure index ...)` *syntax* Traverses through `bytestructure` using `bytestructure-unwrap` with the given indices to acquire a triple of a bytevector, offset, and descriptor. Then, applies the `getter` of that descriptor to the bytevector and offset. Or if the getter is `#f`, then a bytestructure encapsulating that bytevector, offset, and descriptor is returned. Note that this means that calling `bytestructure-ref` with zero index arguments will return a bytestructure identical to the one provided. - `(bytestructure-set! bytestructure index ... value)` *syntax* Traverses through `bytestructure` using `bytestructure-unwrap` with the given indices to acquire a triple of a bytevector, offset, and descriptor. Then, applies the `setter` of that descriptor to the bytevector, offset, and `value`. Or if the setter is `#f`, then `value` must be a bytevector; as many bytes as the size of the descriptor are copied from it into the bytevector, starting from the offset. - `(bytestructure-ref* bytevector offset descriptor index ...)` *syntax* - `(bytestructure-set!* bytevector offset descriptor index ... value)` *syntax* These macros have the same semantics as `bytestructure-ref` and `bytestructure-set!` respectively, except that they start the referencing process with the given `bytevector`, `offset`, and `descriptor`, instead of the bytevector, offset, and descriptor of a given bytestructure. - `(bytestructure-unwrap bytestructure index ...)` *syntax* This macro executes the following algorithm: 1. Extract the bytevector, offset, and descriptor of `bytestructure`. Let us call the triple of these values the *working set*. 2. If no indices are left, return the working set as three values. 3. Apply the `unwrapper` procedure of the descriptor to the bytevector, the offset, and the first index. The return values replace the working set. Pop the index from the list of indices. 4. Go to step 2. *Note:* `bytestructure-unwrap` can be used with zero indices to destructure a bytestructure into its contents. ```scheme (let-values (((bytevector offset descriptor) (bytestructure-unwrap bytestructure))) ...) ``` - `(bytestructure-unwrap* bytevector offset descriptor index ...)` *syntax* This macro has the same semantics as `bytestructure-unwrap`, except that it starts the traversal process with the given `bytevector`, `offset`, and `descriptor`, instead of the bytevector, offset, and descriptor of a given bytestructure. When a descriptor is not a dynamic descriptor, `bytestructure-unwrap*` may be given a bogus `bytevector` argument. ```scheme (bytestructure-unwrap* #f 0 uint8-v3-v5 2) => #f, 6, uint8-v3 ;; Two uint8-v3s were skipped, so offset 6. (bytestructure-unwrap* #f 0 uint8-v3-v5 2 1) => #f, 7, uint8 ;; Two uint8-v3s and one uint8 was skipped. ``` - `(bytestructure-ref/dynamic bytestructure index ...)` *procedure* - `(bytestructure-set!/dynamic bytestructure index ... value)` *procedure* These procedures are equivalent to the macros `bytestructure-ref` and `bytestructure-set!` respectively. *Rationale:* Since these procedures take a variable number of arguments, they have to allocate rest-arguments lists, which might be undesirable in the general case. #### Macro-based API For when maximal efficiency is desired, a macro-based API is offered, so that the bulk of the work involved in offset calculation can be offloaded to the macro-expand phase. - `(define-bytestructure-accessors descriptor unwrapper getter setter)` *syntax* The `descriptor` expression is evaluated during the macro-expand phase to yield a bytestructure descriptor. The `unwrapper`, `getter`, and `setter` identifiers are bound to a triple of macros implementing the indexing, referencing, and assignment semantics of the given descriptor. ```scheme (define-bytestructure-accessors (bs:vector 5 (bs:vector 3 uint8)) uint8-v3-v5-unwrap uint8-v3-v5-ref uint8-v3-v5-set!) (uint8-v3-v5-unwrap #f 0 3 2) ;the #f is a bogus bytevector ;the 0 is the initial offset => 11 (3 * 3 + 2) (define bv (apply bytevector (iota 15))) (uint8-v3-v5-ref bv 2 1) => 7 (uint8-v3-v5-set! bv 2 1 42) (uint8-v3-v5-ref bv 2 1) => 42 ``` - `(bytestructure-unwrap/syntax bytevector-syntax offset-syntax descriptor indices-syntax)` *procedure* The semantics are akin to `bytestructure-unwrap*`, except that some arguments are syntax objects, and the return value is a syntax object that would evaluate to two values: the bytevector and offset that are the result of the indexing process. - `(bytestructure-ref/syntax bytevector-syntax offset-syntax descriptor indices-syntax)` *procedure* The semantics are akin to `bytestructure-ref*`, except that some arguments are syntax objects, and the return value is a syntax object that would evaluate to the decoded value. - `(bytestructure-set!/syntax bytevector offset descriptor indices value)` *procedure* The semantics are akin to `bytestructure-set!*`, except that some arguments are syntax objects, and a syntax object is returned that would perform the actual assignment when evaluated. ### The bytestructure descriptors API - `(make-bytestructure-descriptor size alignment unwrapper getter setter)` *procedure* `Size` must be an exact non-negative integer, or a procedure taking three arguments and returning an exact non-negative integer (this is for dynamic descriptors). The first argument to the procedure is a Boolean indicating whether the call to the procedure is happening in the macro-expand phase. If it's false, the other two arguments are a bytevector and an offset into the bytevector respectively. If it's true, then the two arguments are instead syntax objects that would evaluate to a bytevector and an offset respectively. The offset is the position in the bytevector at which the bytes belonging to the descriptor start. The procedure should return the size of the structure described by the descriptor, or return a syntax object that would evaluate to the size. `Alignment` must be an exact positive integer specifying the type's preferred memory alignment. `Unwrapper` must be `#f` or a procedure taking four arguments: a Boolean indicating whether the call to the procedure is happening in the macro-expand phase, a bytevector (or syntax object thereof), an offset (or syntax object thereof), and an index object (or syntax object thereof). The procedure must return three values: the same or another bytevector (or syntax object thereof), a new offset (or syntax object thereof), and a bytestructure descriptor (NOT a syntax object thereof). This procedure implements the indexing semantics of compound types. The bytevector argument is provided to satisfy dynamic descriptors; the `unwrapper` of non-dynamic descriptors should ignore its value and return it back untouched. `Getter` must be `#f` or a procedure taking three arguments: a Boolean indicating whether the call to the procedure is happening in the macro-expand phase, a bytevector (or syntax object thereof), and an offset (or syntax object thereof). The procedure should decode the bytes at the given offset in the given bytevector (or return a syntax object whose evaluation would do this), thus implementing the referencing semantics of the descriptor. `Setter` must be `#f` or a procedure taking four arguments: a Boolean indicating whether the call to the procedure is happening in the macro-expand phase, a bytevector (or syntax object thereof), an offset (or syntax object thereof), and a value (or syntax object thereof). The procedure should encode the given value into given offset in the given bytevector (or return a syntax object whose evaluation would do this), thus implementing the assignment semantics of the descriptor. - `(bytestructure-descriptor-size descriptor)` *procedure* - `(bytestructure-descriptor-size descriptor bytevector offset)` *procedure* Returns the size of `descriptor`. If `descriptor` is a dynamic descriptor, then the `bytevector` and `offset` arguments must be provided, which will be passed to the `size` procedure of `descriptor`, with the macro-expand Boolean argument set to false. ```scheme (bytestructure-descriptor-size uint8-v3-v5) => 15, because 3×5 8-bit integers in total. (bytestructure-descriptor-size a-dynamic-descriptor) ;;; error (bytestructure-descriptor-size a-dynamic-descriptor bytevector offset) => 42 ``` - `(bytestructure-descriptor-size/syntax descriptor)` *procedure* - `(bytestructure-descriptor-size/syntax descriptor bytevector-syntax offset-syntax)` *procedure* Returns a syntax object that would evaluate to the size of `descriptor`. If `descriptor` is a dynamic descriptor, then the `bytevector-syntax` and `offset-syntax` arguments must be provided, which will be passed to the `size` procedure of `descriptor`, with the macro-expand Boolean argument set to true. - `(bytestructure-descriptor-alignment descriptor)` *procedure* - `(bytestructure-descriptor-unwrapper descriptor)` *procedure* - `(bytestructure-descriptor-getter descriptor)` *procedure* - `(bytestructure-descriptor-setter descriptor)` *procedure* These procedures return the `alignment`, `unwrapper`, `getter`, and `setter` values respectively, with which `descriptor` was created. ## Performance ### Macro API The macro API incurs zero run-time overhead for normal referencing and assignment operations, since most things happen in the macro-expand phase. Plain bytevector reference: ```scheme > (define times (iota 1000000)) ;A million > (define bv (make-bytevector 1)) > (define-inlinable (ref x) (bytevector-u8-ref bv 0)) > ,time (for-each ref times) ;; ~0.14s real time ``` Bytestructure reference: ```scheme > (define bv (make-bytevector 1000)) > (define-bytestructure-accessors (bs:vector 5 (bs:vector 5 (bs:struct `((x ,uint8) (y ,uint8) (z ,uint8))))) bs-unwrap bs-ref bs-set!) > (define-inlinable (ref x) (bs-ref bv 4 4 z)) > ,time (for-each ref times) ;; ~0.14s real time ``` (Ignoring the jitter for both.) ### Procedural API When descriptors are statically apparent, an aggressively constant propagating and partial evaluating optimizer might be able to turn bytestructure references into direct bytevector references, yielding identical results to the macro API. That is the most optimal outcome, but more realistic is that most of the work happens at run-time. The offset calculation avoids allocation, which will make its speed predictable. It takes linear time with regard to the depth of a structure. For structs and unions, it's also linear with regard to the position of the referenced field, but the constant factor involved in that is so small that this should usually not be noticed unless you have a very large number of struct or union fields. If performance becomes an issue but you can't or don't want to switch to the macro API, you can improve performance by hoisting as much work to outside of your tight loops or other performance critical sections of your code. E.g. if you were doing `(bytestructure-ref bs x y z)` within a loop, you can instead do ```scheme (let-values (((bytevector offset descriptor) (bytestructure-unwrap bs x y z))) (loop (bytestructure-ref* bytevector offset descriptor))) ``` or if for instance the last index in that example, `z`, changes at every iteration of the loop, you can do ```scheme (let-values (((bytevector offset descriptor) (bytestructure-unwrap bs x y))) (loop (for z in blah) (bytestructure-ref* bytevector offset descriptor z))) ``` so at least you don't repeat the indexing of `x` and `y` at every iteration. Following are some benchmark figures from Guile 2.2.2 on an Intel i5. (These are only meant for a broad comparison against plain bytevector reference.) Prelude: ```scheme (import (bytestructures guile) (rnrs bytevectors)) (define million-times (iota 1000000)) ``` Plain bytevector reference: ```scheme (define bv (make-bytevector 1)) (define-inlinable (ref x) (bytevector-u8-ref bv 0)) ,time (for-each ref million-times) ;; ~0.06s real time ``` Equivalent bytestructure reference: ```scheme (define bs (bytestructure (bs:vector 1 uint8))) (define-inlinable (ref x) (bytestructure-ref bs 0)) ,time (for-each ref million-times) ;; ~0.35s real time (5.8 times of plain bytevector ref) ``` Showcasing the effect of a deeper structure: ```scheme (define bs (bytestructure (bs:vector 1 (bs:vector 1 (bs:vector 1 uint8))))) (define-inlinable (ref x) (bytestructure-ref bs 0 0 0)) ,time (for-each ref million-times) ;; ~0.59s real time (9.8 times of plain bytevector ref) ``` scheme-bytestructures-1.0.10/TODO.org000066400000000000000000000005411401771724200174250ustar00rootroot00000000000000- Allow working with ports (or other open-ended byte sequences) as an alternative to bytevectors. - See what to do with the "meta" field of descriptors. Should it be part of the public API? Should it be removed and guile/ffi.scm dropped? Should we move to a different record system that allows subtyping and obviates the need for the field? scheme-bytestructures-1.0.10/bitfield-tests.scm000077500000000000000000000151601401771724200216030ustar00rootroot00000000000000;;; Warning: nasal demons. ;;; ;;; Will output differences between GCC's behavior and our behavior, but not in ;;; a very nice format. Zero output is good. The C code and Scheme procedure ;;; we generate are fairly straightforward so read the code to understand. (define-module (bytestructures bitfield-tests)) (export run-bitfield-tests) (use-modules (srfi srfi-1) (srfi srfi-9) (ice-9 rdelim) (bytestructures r6 bytevectors) (bytestructures guile)) (define-record-type (make-struct name fields) struct? (name struct-name) (fields struct-fields)) (define-record-type (make-field name int-size bit-size signed? value) struct? (name field-name) (int-size field-int-size) (bit-size field-bit-size) (signed? field-signed?) (value field-value)) (define *keep-files* (make-parameter #f)) (define (run-bitfield-tests count random-seed-string keep-files) (set! *random-state* (seed->random-state random-seed-string)) (parameterize ((*keep-files* keep-files)) (test-structs (generate-structs count)))) (define (generate-structs n) (remove-bad-structs (map random-struct (iota n)))) (define (remove-bad-structs structs) (filter (lambda (struct) (find (lambda (field) (not (zero? (field-bit-size field)))) (struct-fields struct))) structs)) (define (random-struct i) (let ((field-count (+ 1 (random 50)))) (make-struct (format #f "s~a" i) (map random-field (iota field-count))))) (define (random-field i) (let* ((name (format #f "f~a" i)) (int-size (* 8 (expt 2 (random 4)))) (bit-size (random (+ 1 int-size))) (signed? (= 0 (random 2))) (value (random (expt 2 bit-size))) (value (if (and signed? (> value (+ -1 (expt 2 (- bit-size 1))))) (- value (expt 2 bit-size)) value))) (make-field name int-size bit-size signed? value))) (define (test-structs structs) (let* ((c-code (c-code-for-structs structs)) (c-output (get-c-output c-code)) (scm-code (scm-code-for-structs structs)) (scm-output (get-scm-output scm-code))) (diff-outputs c-output scm-output))) (define (c-code-for-structs structs) (string-concatenate (append (list "#include \n" "#include \n" "#include \n" "int main(){\n") (map c-code-for-struct structs) (list "return 0;}")))) (define (c-code-for-struct struct) (let ((name (struct-name struct)) (fields (struct-fields struct))) (string-concatenate (append (list (format #f "struct ~a {\n" name)) (map c-decl-for-field fields) (list "};\n" (format #f "{ struct ~a foo;\n" name) (format #f " bzero((void*)&foo, sizeof(foo));\n")) (map c-assignment-for-field fields) (list (format #f " printf(\"struct ~a:\\n\");\n" name) " uint8_t *ptr = (void*)&foo;\n" " for (int i = 0; i < sizeof(foo); ++i) {\n" " printf(\"%d \", *(ptr+i));\n" " }\n" " printf(\"\\n\");\n" "}\n"))))) (define (c-decl-for-field field) (let ((name (field-name field)) (int-size (field-int-size field)) (bit-size (field-bit-size field)) (signed? (field-signed? field))) (format #f " ~aint~a_t ~a:~a;\n" (if signed? "" "u") int-size (if (zero? bit-size) "" name) bit-size))) (define (c-assignment-for-field field) (let ((name (field-name field)) (bit-size (field-bit-size field)) (signed? (field-signed? field)) (value (field-value field))) (if (zero? bit-size) "" (format #f " foo.~a = ~a~a;\n" name value (if signed? "" "u"))))) (define (get-c-output code) (let* ((port (mkstemp! (string-copy "/tmp/bitfield-XXXXXX"))) (file (port-filename port)) (exe-port (mkstemp! (string-copy "/tmp/bitfield-compiled-XXXXXX"))) (exe-file (port-filename exe-port)) (output-port (mkstemp! (string-copy "/tmp/bitfield-output-XXXXXX"))) (output-file (port-filename output-port))) (close-port exe-port) (close-port output-port) (display code port) (force-output port) (unless (zero? (system* "gcc" "-x" "c" "-std=c11" file "-o" exe-file)) (error "gcc failed")) (unless (zero? (system (format #f "~a > ~a" exe-file output-file))) (error "exe failed")) (let ((out (read-string (open output-file O_RDONLY)))) (unless (*keep-files*) (for-each delete-file (list file exe-file output-file))) out))) (define (scm-code-for-structs structs) (lambda () (string-concatenate (map scm-code-for-struct structs)))) (define (scm-code-for-struct struct) (let* ((name (struct-name struct)) (fields (struct-fields struct)) (descriptor (struct->descriptor struct)) (values (map field-value (filter-nonzero-fields fields))) (bs (bytestructure descriptor (list->vector values)))) (string-concatenate (append (list (format #f "struct ~a:\n" name)) (let ((bv (bytestructure-bytevector bs))) (map (lambda (i) (format #f "~a " (bytevector-u8-ref bv i))) (iota (bytevector-length bv)))) (list "\n"))))) (define (struct->descriptor struct) (let ((fields (struct-fields struct))) (bs:struct (map field->struct-descriptor-field fields)))) (define (field->struct-descriptor-field field) (let ((name (field-name field)) (int-size (field-int-size field)) (bit-size (field-bit-size field)) (signed? (field-signed? field))) (list name (module-ref (resolve-module '(bytestructures bitfield-tests)) (string->symbol (format #f "~aint~a" (if signed? "" "u") int-size))) bit-size))) (define (filter-nonzero-fields fields) (filter (lambda (field) (not (zero? (field-bit-size field)))) fields)) (define (get-scm-output code) (code)) (define (diff-outputs o1 o2) (let* ((p1 (mkstemp! (string-copy "/tmp/bitfield-out1-XXXXXX"))) (f1 (port-filename p1)) (p2 (mkstemp! (string-copy "/tmp/bitfield-out2-XXXXXX"))) (f2 (port-filename p2))) (display o1 p1) (display o2 p2) (flush-all-ports) (close-port p1) (close-port p2) (let ((retval (system* "diff" "-y" "--suppress-common" f1 f2))) (unless (*keep-files*) (for-each delete-file (list f1 f2))) retval))) scheme-bytestructures-1.0.10/bytestructures/000077500000000000000000000000001401771724200212565ustar00rootroot00000000000000scheme-bytestructures-1.0.10/bytestructures/body/000077500000000000000000000000001401771724200222135ustar00rootroot00000000000000scheme-bytestructures-1.0.10/bytestructures/body/align.scm000066400000000000000000000036031401771724200240130ustar00rootroot00000000000000;;; align.scm --- Alignment calculation helpers. ;; Copyright © 2018 Taylan Ulrich Bayırlı/Kammer ;; 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 . ;;; Commentary: ;;; Code: ;;; Either remains at 'position' or rounds up to the next multiple of ;;; 'alignment' depending on whether 'size' (if not greater than 'alignment') ;;; would fit. Returns three values: the chosen position, the start of the ;;; alignment boundary of the chosen position, and the bit offset of the chosen ;;; position from the start of the alignment boundary. A bit is represented by ;;; the value 1/8. (define (align position size alignment) (let* ((integer (floor position)) (fraction (- position integer))) (let-values (((prev-boundary-index offset) (floor/ integer alignment))) (let* ((prev-boundary (* prev-boundary-index alignment)) (next-boundary (+ prev-boundary alignment))) (if (< next-boundary (+ position (min size alignment))) (values next-boundary next-boundary 0) (values position prev-boundary (* 8 (+ offset fraction)))))))) ;;; Returns 'position' if it's already a multiple of 'alignment'; otherwise ;;; returns the next multiple. (define (next-boundary position alignment) (align position +inf.0 alignment)) ;;; align.scm ends here scheme-bytestructures-1.0.10/bytestructures/body/base.scm000066400000000000000000000175341401771724200236430ustar00rootroot00000000000000;;; bytestructures --- Structured access to bytevector contents. ;; Copyright © 2015, 2016 Taylan Ulrich Bayırlı/Kammer ;; 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 . ;;; Commentary: ;; This is the base of the module, defining the data types and procedures that ;; make up the bytestructures framework. ;;; Code: ;;; Descriptors (define-record-type (%make-bytestructure-descriptor size alignment unwrapper getter setter meta) bytestructure-descriptor? (size bd-size) (alignment bd-alignment) (unwrapper bd-unwrapper) (getter bd-getter) (setter bd-setter) (meta bd-meta)) (define make-bytestructure-descriptor (case-lambda ((size alignment unwrapper getter setter) (%make-bytestructure-descriptor size alignment unwrapper getter setter #f)) ((size alignment unwrapper getter setter meta) (%make-bytestructure-descriptor size alignment unwrapper getter setter meta)))) (define bytestructure-descriptor-size (case-lambda ((descriptor) (bytestructure-descriptor-size descriptor #f #f)) ((descriptor bytevector offset) (let ((size (bd-size descriptor))) (if (procedure? size) (size #f bytevector offset) size))))) (define (bytestructure-descriptor-size/syntax bytevector offset descriptor) (let ((size (bd-size descriptor))) (if (procedure? size) (size #t bytevector offset) size))) (define bytestructure-descriptor-alignment bd-alignment) (define bytestructure-descriptor-unwrapper bd-unwrapper) (define bytestructure-descriptor-getter bd-getter) (define bytestructure-descriptor-setter bd-setter) (define bytestructure-descriptor-metadata bd-meta) ;;; Bytestructures (define-record-type (make-bytestructure bytevector offset descriptor) bytestructure? (bytevector bytestructure-bytevector) (offset bytestructure-offset) (descriptor bytestructure-descriptor)) (define bytestructure (case-lambda ((descriptor) (%bytestructure descriptor #f #f)) ((descriptor values) (%bytestructure descriptor #t values)))) (define (%bytestructure descriptor init? values) (let ((bytevector (make-bytevector (bytestructure-descriptor-size descriptor)))) (when init? (bytestructure-primitive-set! bytevector 0 descriptor values)) (make-bytestructure bytevector 0 descriptor))) (define (bytestructure-size bytestructure) (bytestructure-descriptor-size (bytestructure-descriptor bytestructure) (bytestructure-bytevector bytestructure) (bytestructure-offset bytestructure))) (define-syntax-rule (bytestructure-unwrap ...) (let ((bytestructure )) (let ((bytevector (bytestructure-bytevector bytestructure)) (offset (bytestructure-offset bytestructure)) (descriptor (bytestructure-descriptor bytestructure))) (bytestructure-unwrap* bytevector offset descriptor ...)))) (define-syntax bytestructure-unwrap* (syntax-rules () ((_ ) (values )) ((_ ...) (let ((bytevector ) (offset ) (descriptor )) (let ((unwrapper (bd-unwrapper descriptor))) (when (not unwrapper) (error "Cannot index through this descriptor." descriptor)) (let-values (((bytevector* offset* descriptor*) (unwrapper #f bytevector offset ))) (bytestructure-unwrap* bytevector* offset* descriptor* ...))))))) (define-syntax-rule (bytestructure-ref ...) (let-values (((bytevector offset descriptor) (bytestructure-unwrap ...))) (bytestructure-primitive-ref bytevector offset descriptor))) (define-syntax-rule (bytestructure-ref* ...) (let-values (((bytevector offset descriptor) (bytestructure-unwrap* ...))) (bytestructure-primitive-ref bytevector offset descriptor))) (define (bytestructure-primitive-ref bytevector offset descriptor) (let ((getter (bd-getter descriptor))) (if getter (getter #f bytevector offset) (make-bytestructure bytevector offset descriptor)))) (define-syntax-rule (bytestructure-set! ... ) (let-values (((bytevector offset descriptor) (bytestructure-unwrap ...))) (bytestructure-primitive-set! bytevector offset descriptor ))) (define-syntax-rule (bytestructure-set!* ... ) (let-values (((bytevector offset descriptor) (bytestructure-unwrap* ...))) (bytestructure-primitive-set! bytevector offset descriptor ))) (define (bytestructure-primitive-set! bytevector offset descriptor value) (let ((setter (bd-setter descriptor))) (if setter (setter #f bytevector offset value) (if (bytevector? value) (bytevector-copy! bytevector offset value 0 (bytestructure-descriptor-size descriptor bytevector offset)) (error "Cannot write value with this bytestructure descriptor." value descriptor))))) (define (bytestructure-ref/dynamic bytestructure . indices) (let-values (((bytevector offset descriptor) (bytestructure-unwrap bytestructure))) (let loop ((bytevector bytevector) (offset offset) (descriptor descriptor) (indices indices)) (if (null? indices) (bytestructure-primitive-ref bytevector offset descriptor) (let-values (((bytevector* offset* descriptor*) (bytestructure-unwrap* bytevector offset descriptor (car indices)))) (loop bytevector* offset* descriptor* (cdr indices))))))) (define (bytestructure-set!/dynamic bytestructure . args) (let-values (((bytevector offset descriptor) (bytestructure-unwrap bytestructure))) (let loop ((bytevector bytevector) (offset offset) (descriptor descriptor) (args args)) (if (null? (cdr args)) (bytestructure-primitive-set! bytevector offset descriptor (car args)) (let-values (((bytevector* offset* descriptor*) (bytestructure-unwrap* bytevector offset descriptor (car args)))) (loop bytevector* offset* descriptor* (cdr args))))))) (define-syntax-case-stubs bytestructure-unwrap/syntax bytestructure-ref/syntax bytestructure-set!/syntax define-bytestructure-accessors) (cond-expand (guile (include-from-path "bytestructures/body/base.syntactic.scm")) (syntax-case (include "base.syntactic.scm")) (else)) ;;; base.scm ends here scheme-bytestructures-1.0.10/bytestructures/body/base.syntactic.scm000066400000000000000000000112741401771724200256360ustar00rootroot00000000000000;;; bytestructures --- Structured access to bytevector contents. ;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer ;; 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 . ;;; Commentary: ;; This is an extension to the base of the module which allows using the API ;; purely in the macro-expand phase, which puts some limitations on its use but ;; reduces run-time overhead to zero or nearly zero. ;;; Code: (define-syntax-rule (syntax-case-lambda ) (lambda (stx) (syntax-case stx () ( )))) (define syntax-car (syntax-case-lambda (car . cdr) #'car)) (define syntax-cdr (syntax-case-lambda (car . cdr) #'cdr)) (define syntax-null? (syntax-case-lambda stx (null? (syntax->datum #'stx)))) (define (syntactic-unwrap bytevector offset descriptor indices) (let loop ((bytevector bytevector) (offset offset) (descriptor descriptor) (indices indices)) (if (not (syntax-null? indices)) (let ((unwrapper (bd-unwrapper descriptor))) (when (not unwrapper) (error "Cannot index through this descriptor." descriptor)) (let-values (((bytevector* offset* descriptor*) (unwrapper #t bytevector offset (syntax-car indices)))) (loop bytevector* offset* descriptor* (syntax-cdr indices)))) (let ((getter (bd-getter descriptor)) (setter (bd-setter descriptor))) (values bytevector offset descriptor getter setter))))) (define (bytestructure-unwrap/syntax bytevector offset descriptor indices) (let-values (((bytevector* offset* _descriptor _getter _setter) (syntactic-unwrap bytevector offset descriptor indices))) #`(values #,bytevector* #,offset*))) (define (bytestructure-ref/syntax bytevector offset descriptor indices) (let-values (((bytevector* offset* descriptor* getter _setter) (syntactic-unwrap bytevector offset descriptor indices))) (if getter (getter #t bytevector* offset*) (error "The indices given to bytestructure-ref/syntax do not lead to a bytestructure descriptor that can decode values. You must have used the wrong getter macro, forgot to provide some of the indices, or meant to use the unwrapper instead of the getter. The given indices follow." indices)))) (define (bytestructure-set!/syntax bytevector offset descriptor indices value) (let-values (((bytevector* offset* descriptor* _getter setter) (syntactic-unwrap bytevector offset descriptor indices))) (if setter (setter #t bytevector* offset* value) (error "The indices given to bytestructure-set!/syntax do not lead to a bytestructure descriptor that can encode values. You must have used the wrong setter macro, or forgot to provide some of the indices. The given indices follow." indices)))) (define-syntax-rule (define-bytestructure-unwrapper ) (define-syntax (let ((descriptor )) (syntax-case-lambda (_ . ) (bytestructure-unwrap/syntax #' #' descriptor #'))))) (define-syntax-rule (define-bytestructure-getter ) (define-syntax (let ((descriptor )) (syntax-case-lambda (_ . ) (bytestructure-ref/syntax #' 0 descriptor #'))))) (define-syntax-rule (define-bytestructure-setter ) (define-syntax (let ((descriptor )) (syntax-case-lambda (_ (... ...) ) (bytestructure-set!/syntax #' 0 descriptor #'( (... ...)) #'))))) (define-syntax-rule (define-bytestructure-accessors ) (begin (define-bytestructure-unwrapper ) (define-bytestructure-getter ) (define-bytestructure-setter ))) ;; Local Variables: ;; eval: (put (quote syntax-case-lambda) (quote scheme-indent-function) 1) ;; End: ;;; base.syntactic.scm ends here scheme-bytestructures-1.0.10/bytestructures/body/bitfields.scm000066400000000000000000000075431401771724200246750ustar00rootroot00000000000000;;; bitfields.scm --- Struct bitfield constructor. ;; Copyright © 2015, 2016 Taylan Ulrich Bayırlı/Kammer ;; 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 . ;;; Commentary: ;; This module is complementary to the struct module. It isn't used on its own. ;; This code partly uses rational numbers for byte counts and offsets, to ;; represent granularity down to bits. I.e. 1/8 is a size or offset of one bit. ;;; Code: ;;; Only a macro for efficiency reasons. (define-syntax bit-field/signed (syntax-rules () ((_ ) (let ((unsigned-value (bit-field ))) (if (not ) unsigned-value (let ((sign (bit-set? (- 1) unsigned-value))) (if sign (- unsigned-value (expt 2 )) unsigned-value))))))) (define (validate-integer-descriptor descriptor) (when (not (assq descriptor integer-descriptors)) (error "Invalid descriptor for bitfield." descriptor))) (define (integer-descriptor-signed? descriptor) (assq descriptor signed-integer-descriptors)) (define integer-descriptor-signed->unsigned-mapping (map cons (map car signed-integer-descriptors) (map car unsigned-integer-descriptors))) (define (integer-descriptor-signed->unsigned descriptor) (cdr (assq descriptor integer-descriptor-signed->unsigned-mapping))) (define (unsigned-integer-descriptor integer-descriptor) (if (integer-descriptor-signed? integer-descriptor) (integer-descriptor-signed->unsigned integer-descriptor) integer-descriptor)) (define-record-type (make-bitfield-metadata int-descriptor width) bitfield-metadata? (int-descriptor bitfield-metadata-int-descriptor) (width bitfield-metadata-width)) (define (bitfield-descriptor int-descriptor bit-offset width) (validate-integer-descriptor int-descriptor) (let ((signed? (integer-descriptor-signed? int-descriptor)) (uint-descriptor (unsigned-integer-descriptor int-descriptor))) (let ((num-getter (bytestructure-descriptor-getter uint-descriptor)) (num-setter (bytestructure-descriptor-setter uint-descriptor))) (define start bit-offset) (define end (+ start width)) (define (getter syntax? bytevector offset) (let ((num (num-getter syntax? bytevector offset))) (if syntax? (quasisyntax (bit-field/signed (unsyntax num) (unsyntax width) (unsyntax start) (unsyntax end) (unsyntax signed?))) (bit-field/signed num width start end signed?)))) (define (setter syntax? bytevector offset value) (let* ((oldnum (num-getter syntax? bytevector offset)) (newnum (if syntax? (quasisyntax (copy-bit-field (unsyntax oldnum) (unsyntax value) (unsyntax start) (unsyntax end))) (copy-bit-field oldnum value start end)))) (num-setter syntax? bytevector offset newnum))) (define meta (make-bitfield-metadata int-descriptor width)) (make-bytestructure-descriptor #f #f #f getter setter meta)))) ;;; bitfields.scm ends here scheme-bytestructures-1.0.10/bytestructures/body/explicit-endianness.scm000066400000000000000000000065401401771724200266720ustar00rootroot00000000000000;;; explicit-endianness.scm --- Auxiliary bytevector operations. ;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer ;; 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 . ;;; Commentary: ;; The numeric module requires top-level bindings to bytevector procedures with ;; an explicit endianness, instead of the ones that take an endianness ;; argument. This library provides them. ;;; Code: (define-syntax define-explicit-endianness-getters (syntax-rules () ((_ (original le-name be-name) ...) (begin (begin (define (le-name bytevector index) (original bytevector index (endianness little))) (define (be-name bytevector index) (original bytevector index (endianness big)))) ...)))) (define-explicit-endianness-getters (bytevector-ieee-single-ref bytevector-ieee-single-le-ref bytevector-ieee-single-be-ref) (bytevector-ieee-double-ref bytevector-ieee-double-le-ref bytevector-ieee-double-be-ref) (bytevector-s16-ref bytevector-s16le-ref bytevector-s16be-ref) (bytevector-u16-ref bytevector-u16le-ref bytevector-u16be-ref) (bytevector-s32-ref bytevector-s32le-ref bytevector-s32be-ref) (bytevector-u32-ref bytevector-u32le-ref bytevector-u32be-ref) (bytevector-s64-ref bytevector-s64le-ref bytevector-s64be-ref) (bytevector-u64-ref bytevector-u64le-ref bytevector-u64be-ref)) (define-syntax define-explicit-endianness-setters (syntax-rules () ((_ (original le-name be-name) ...) (begin (begin (define (le-name bytevector index value) (original bytevector index value (endianness little))) (define (be-name bytevector index value) (original bytevector index value (endianness big)))) ...)))) (define-explicit-endianness-setters (bytevector-ieee-single-set! bytevector-ieee-single-le-set! bytevector-ieee-single-be-set!) (bytevector-ieee-double-set! bytevector-ieee-double-le-set! bytevector-ieee-double-be-set!) (bytevector-s16-set! bytevector-s16le-set! bytevector-s16be-set!) (bytevector-u16-set! bytevector-u16le-set! bytevector-u16be-set!) (bytevector-s32-set! bytevector-s32le-set! bytevector-s32be-set!) (bytevector-u32-set! bytevector-u32le-set! bytevector-u32be-set!) (bytevector-s64-set! bytevector-s64le-set! bytevector-s64be-set!) (bytevector-u64-set! bytevector-u64le-set! bytevector-u64be-set!)) ;;; explicit-endianness.scm ends here scheme-bytestructures-1.0.10/bytestructures/body/numeric.scm000066400000000000000000000264601401771724200243710ustar00rootroot00000000000000;;; numeric.scm --- Numeric types as supported by (rnrs bytevectors). ;; Copyright © 2015, 2016 Taylan Ulrich Bayırlı/Kammer ;; 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 . ;;; Commentary: ;; This module defines descriptors for numeric types of specific size, and ;; native or specific endianness, as made possible by the bytevector referencing ;; and assigning procedures in the (rnrs bytevectors) module. ;; We use the strange cond-expand/runtime macro to make sure that certain checks ;; for CPU architecture and data model are done at library-load-time and not ;; compile time, since one might cross-compile the library. ;;; Code: (define base-environment (cond-expand (guile-2 (current-module)) (else (environment '(scheme base))))) (define-syntax cond-expand/runtime (syntax-rules () ((_ ( ) ...) (let ((const (eval '(cond-expand ( ') ...) base-environment))) (cond ((equal? const ') ) ...))))) (define i8align 1) (define i16align 2) (define i32align 4) (define i64align (cond-expand/runtime (i386 4) (else 8))) (define f32align 4) (define f64align (cond-expand/runtime (i386 4) (else 8))) (define-syntax-rule (make-numeric-descriptor ) (let () (define size ) (define alignment ) (define (getter syntax? bytevector offset) (if syntax? (quasisyntax ( (unsyntax bytevector) (unsyntax offset))) ( bytevector offset))) (define (setter syntax? bytevector offset value) (if syntax? (quasisyntax ( (unsyntax bytevector) (unsyntax offset) (unsyntax value))) ( bytevector offset value))) (make-bytestructure-descriptor size alignment #f getter setter))) (define-syntax-rule (define-numeric-descriptors ( ) ...) (begin (define (make-numeric-descriptor )) ... (define (list (list ' ) ...)))) (define-numeric-descriptors signed-integer-native-descriptors (int8 1 i8align bytevector-s8-ref bytevector-s8-set!) (int16 2 i16align bytevector-s16-native-ref bytevector-s16-native-set!) (int32 4 i32align bytevector-s32-native-ref bytevector-s32-native-set!) (int64 8 i64align bytevector-s64-native-ref bytevector-s64-native-set!)) (define-numeric-descriptors unsigned-integer-native-descriptors (uint8 1 i8align bytevector-u8-ref bytevector-u8-set!) (uint16 2 i16align bytevector-u16-native-ref bytevector-u16-native-set!) (uint32 4 i32align bytevector-u32-native-ref bytevector-u32-native-set!) (uint64 8 i64align bytevector-u64-native-ref bytevector-u64-native-set!)) (define-numeric-descriptors float-native-descriptors (float32 4 f32align bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!) (float64 8 f64align bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!)) (define-syntax-rule (define-with-endianness ( ) ...) (begin (define (if (equal? (native-endianness)) (make-numeric-descriptor ))) ... (define (list (list ' ) ...)))) (define-with-endianness signed-integer-le-descriptors (endianness little) (int16le 2 i16align int16 bytevector-s16le-ref bytevector-s16le-set!) (int32le 4 i32align int32 bytevector-s32le-ref bytevector-s32le-set!) (int64le 8 i64align int64 bytevector-s64le-ref bytevector-s64le-set!)) (define-with-endianness signed-integer-be-descriptors (endianness big) (int16be 2 i16align int16 bytevector-s16be-ref bytevector-s16be-set!) (int32be 4 i32align int32 bytevector-s32be-ref bytevector-s32be-set!) (int64be 8 i64align int64 bytevector-s64be-ref bytevector-s64be-set!)) (define-with-endianness unsigned-integer-le-descriptors (endianness little) (uint16le 2 i16align uint16 bytevector-u16le-ref bytevector-u16le-set!) (uint32le 4 i32align uint32 bytevector-u32le-ref bytevector-u32le-set!) (uint64le 8 i64align uint64 bytevector-u64le-ref bytevector-u64le-set!)) (define-with-endianness unsigned-integer-be-descriptors (endianness big) (uint16be 2 i16align uint16 bytevector-u16be-ref bytevector-u16be-set!) (uint32be 4 i32align uint32 bytevector-u32be-ref bytevector-u32be-set!) (uint64be 8 i64align uint64 bytevector-u64be-ref bytevector-u64be-set!)) (define-with-endianness float-le-descriptors (endianness little) (float32le 4 f32align float32 bytevector-ieee-single-le-ref bytevector-ieee-single-le-set!) (float64le 8 f64align float64 bytevector-ieee-double-le-ref bytevector-ieee-double-le-set!)) (define-with-endianness float-be-descriptors (endianness big) (float32be 4 f32align float32 bytevector-ieee-single-be-ref bytevector-ieee-single-be-set!) (float64be 8 f64align float64 bytevector-ieee-double-be-ref bytevector-ieee-double-be-set!)) (define-syntax-rule (make-complex-descriptor ) (let () (define size (* 2 )) (define alignment ) (define (getter syntax? bytevector offset) (if syntax? (quasisyntax (let ((real ( (unsyntax bytevector) (unsyntax offset))) (imag ( (unsyntax bytevector) (+ (unsyntax offset) )))) (make-rectangular real imag))) (let ((real ( bytevector offset)) (imag ( bytevector (+ offset )))) (make-rectangular real imag)))) (define (setter syntax? bytevector offset value) (if syntax? (quasisyntax (let ((val (unsyntax value))) (let ((real (real-part val)) (imag (imag-part val))) ( (unsyntax bytevector) (unsyntax offset) real) ( (unsyntax bytevector) (+ (unsyntax offset) ) imag)))) (let ((real (real-part value)) (imag (imag-part value))) ( bytevector offset real) ( bytevector (+ offset ) imag)))) (make-bytestructure-descriptor size alignment #f getter setter))) (define-syntax-rule (define-complex-descriptors ( ) ...) (begin (define (make-complex-descriptor )) ... (define (list (list ' ) ...)))) (define-complex-descriptors complex-native-descriptors (complex64 4 f32align bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!) (complex128 8 f64align bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!)) (define-syntax-rule (define-complex-with-endianness ( ) ...) (begin (define (if (equal? (native-endianness)) (make-complex-descriptor ))) ... (define (list (list ' ) ...)))) (define-complex-with-endianness complex-le-descriptors (endianness little) (complex64le 4 f32align complex64 bytevector-ieee-single-le-ref bytevector-ieee-single-le-set!) (complex128le 8 f64align complex128 bytevector-ieee-double-le-ref bytevector-ieee-double-le-set!)) (define-complex-with-endianness complex-be-descriptors (endianness big) (complex64be 4 f32align complex64 bytevector-ieee-single-be-ref bytevector-ieee-single-be-set!) (complex128be 8 f64align complex128 bytevector-ieee-double-be-ref bytevector-ieee-double-be-set!)) (define signed-integer-descriptors (append signed-integer-native-descriptors signed-integer-le-descriptors signed-integer-be-descriptors)) (define unsigned-integer-descriptors (append unsigned-integer-native-descriptors unsigned-integer-le-descriptors unsigned-integer-be-descriptors)) (define integer-descriptors (append signed-integer-descriptors unsigned-integer-descriptors)) (define float-descriptors (append float-native-descriptors float-le-descriptors float-be-descriptors)) (define complex-descriptors (append complex-native-descriptors complex-le-descriptors complex-be-descriptors)) (define numeric-descriptors (append integer-descriptors float-descriptors complex-descriptors)) (define short int16) (define unsigned-short uint16) (define int (cond-expand/runtime (lp32 int16) (ilp64 int64) (else int32))) (define unsigned-int (cond-expand/runtime (lp32 uint16) (ilp64 uint64) (else uint32))) (define long (cond-expand/runtime (ilp64 int64) (lp64 int64) (else int32))) (define unsigned-long (cond-expand/runtime (ilp64 uint64) (lp64 uint64) (else uint32))) (define long-long int64) (define unsigned-long-long uint64) (define arch32bit? (cond-expand/runtime (lp32 #t) (ilp32 #t) (else #f))) (define intptr_t (if arch32bit? int32 int64)) (define uintptr_t (if arch32bit? uint32 uint64)) (define size_t uintptr_t) (define ssize_t intptr_t) (define ptrdiff_t intptr_t) (define float float32) (define double float64) ;;; numeric.scm ends here scheme-bytestructures-1.0.10/bytestructures/body/string.scm000066400000000000000000000121221401771724200242230ustar00rootroot00000000000000;;; string.scm --- Strings in encodings supported by (rnrs bytevectors). ;; Copyright © 2017 Taylan Ulrich Bayırlı/Kammer ;; 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 . ;;; Commentary: ;; This module defines descriptors for strings encoded in various encodings, as ;; supported by (rnrs bytevectors). ;;; Code: (define (ascii->string bytevector start end) (let ((string (utf8->string bytevector start end))) (when (not (= (string-length string) (bytevector-length bytevector))) (error "Bytevector contains non-ASCII characters." bytevector)) string)) (define (string->ascii string) (let ((bytevector (string->utf8 string))) (when (not (= (string-length string) (bytevector-length bytevector))) (error "String contains non-ASCII characters." string)) bytevector)) (define (bytevector->string bytevector offset size encoding) (case encoding ((ascii) (ascii->string bytevector offset (+ offset size))) ((utf8) (utf8->string bytevector offset (+ offset size))) (else (let ((bytevector (bytevector-copy bytevector offset (+ offset size)))) (case encoding ((utf16le) (utf16->string bytevector 'little #t)) ((utf16be) (utf16->string bytevector 'big #t)) ((utf32le) (utf32->string bytevector 'little #t)) ((utf32be) (utf32->string bytevector 'big #t)) (else (error "Unknown string encoding." encoding))))))) (define (string->bytevector string encoding) (case encoding ((ascii) (string->ascii string)) ((utf8) (string->utf8 string)) ((utf16le) (string->utf16 string 'little)) ((utf16be) (string->utf16 string 'big)) ((utf32le) (string->utf32 string 'little)) ((utf32be) (string->utf32 string 'big)))) ;;; Note: because macro output may not contain raw symbols, we cannot output ;;; (quote foo) for raw symbol foo either, so there's no way to inject symbol ;;; literals into macro output. Hence we inject references to the following ;;; variables instead. (define ascii 'ascii) (define utf8 'utf8) (define utf16le 'utf16le) (define utf16be 'utf16be) (define utf32le 'utf32le) (define utf32be 'utf32be) ;;; Make sure this returns a boolean and not any other type of value, as the ;;; output will be part of macro output. (define (fixed-width-encoding? encoding) (not (not (memq encoding '(ascii utf32le utf32be))))) (define (bytevector-zero! bv start end) (do ((i start (+ i 1))) ((= i end)) (bytevector-u8-set! bv i #x00))) (define (bs:string size encoding) (define alignment 1) (define (getter syntax? bytevector offset) (if syntax? (quasisyntax (bytevector->string (unsyntax bytevector) (unsyntax offset) (unsyntax size) (unsyntax (datum->syntax (syntax utf8) encoding)))) (bytevector->string bytevector offset size encoding))) (define (setter syntax? bytevector offset string) (if syntax? (quasisyntax (let* ((bv (string->bytevector (unsyntax string) (unsyntax (datum->syntax (syntax utf8) encoding)))) (length (bytevector-length bv))) (when (> length (unsyntax size)) (error "String too long." (unsyntax string))) (when (and (unsyntax (fixed-width-encoding? encoding)) (< length (unsyntax size))) (error "String too short." (unsyntax string))) (bytevector-copy! (unsyntax bytevector) (unsyntax offset) bv) (when (not (unsyntax (fixed-width-encoding? encoding))) (bytevector-zero! (unsyntax bytevector) (+ (unsyntax offset) (bytevector-length bv)) (+ (unsyntax offset) (unsyntax size)))))) (let* ((bv (string->bytevector string encoding)) (length (bytevector-length bv))) (when (> length size) (error "String too long." string)) (when (and (fixed-width-encoding? encoding) (< length size)) (error "String too short." string)) (bytevector-copy! bytevector offset bv) (when (not (fixed-width-encoding? encoding)) (bytevector-zero! bytevector (+ offset (bytevector-length bv)) (+ offset size)))))) (make-bytestructure-descriptor size alignment #f getter setter)) ;;; string.scm ends here scheme-bytestructures-1.0.10/bytestructures/body/struct.scm000066400000000000000000000176211401771724200242520ustar00rootroot00000000000000;;; struct.scm --- Struct descriptor constructor. ;; Copyright © 2015, 2016 Taylan Ulrich Bayırlı/Kammer ;; 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 . ;;; Commentary: ;; This constructor allows the creation of struct descriptors with named and ;; ordered fields with a specific content descriptor. ;; This code partly uses rational numbers for byte counts and offsets, to ;; represent granularity down to bits. I.e. 1/8 is a size or offset of one bit. ;;; Code: (define (pack-alignment pack alignment) (case pack ((#t) 1) ((#f) alignment) (else (min pack alignment)))) (define-record-type (make-field name descriptor size alignment position) field? (name field-name) (descriptor field-descriptor) (size field-size) (alignment field-alignment) (position field-position)) (define (construct-field pack position name descriptor) (let*-values (((size) (bytestructure-descriptor-size descriptor)) ((alignment) (pack-alignment pack (bytestructure-descriptor-alignment descriptor))) ((position _boundary _bit-offset) (align position size alignment))) (values (make-field name descriptor size alignment position) (+ position size)))) (define (construct-bit-field pack position name descriptor width) (if (zero? width) (let* ((alignment (bytestructure-descriptor-alignment descriptor)) (position (next-boundary position alignment))) (values (make-field #f descriptor 0 1 position) position)) (let*-values (((int-size) (bytestructure-descriptor-size descriptor)) ((size) (* 1/8 width)) ((int-alignment) (bytestructure-descriptor-alignment descriptor)) ((alignment) (pack-alignment pack int-alignment)) ((position boundary offset) (align position size alignment)) ((descriptor) (bitfield-descriptor descriptor offset width))) (values (make-field name descriptor int-size alignment boundary) (+ position size))))) (define (construct-fields pack field-specs) (let loop ((field-specs field-specs) (position 0) (fields '())) (if (null? field-specs) (reverse fields) (let* ((field-spec (car field-specs)) (field-specs (cdr field-specs)) (name (car field-spec)) (descriptor (cadr field-spec)) (bitfield? (not (null? (cddr field-spec)))) (width (if bitfield? (car (cddr field-spec)) #f))) (let-values (((field next-position) (if bitfield? (construct-bit-field pack position name descriptor width) (construct-field pack position name descriptor)))) (loop field-specs next-position (cons field fields))))))) (define-record-type (make-struct-metadata field-alist) struct-metadata? (field-alist struct-metadata-field-alist)) (define bs:struct (case-lambda ((field-specs) (bs:struct #f field-specs)) ((pack field-specs) (define %fields (construct-fields pack field-specs)) (define fields (filter field-name %fields)) (define field-alist (map (lambda (field) (cons (field-name field) field)) fields)) (define alignment (apply max (map field-alignment fields))) (define size (let* ((field (last %fields)) (end (+ (field-position field) (field-size field)))) (let-values (((size . _) (next-boundary end alignment))) size))) (define (unwrapper syntax? bytevector offset index) (let* ((index (if syntax? (syntax->datum index) index)) (field-entry (assq index field-alist)) (field (if field-entry (cdr field-entry) (error "No such struct field." index)))) (let* ((descriptor (field-descriptor field)) (position (field-position field)) (offset (if syntax? (quasisyntax (+ (unsyntax offset) (unsyntax position))) (+ offset position)))) (values bytevector offset descriptor)))) (define (setter syntax? bytevector offset value) (define (count-error fields values) (error "Mismatch between number of struct fields and given values." fields values)) (when syntax? (error "Writing into struct not supported with macro API.")) (cond ((bytevector? value) (bytevector-copy! bytevector offset value 0 size)) ((vector? value) (let loop ((fields fields) (values (vector->list value))) (if (null? values) (when (not (null? fields)) (count-error fields value)) (begin (when (null? fields) (count-error fields value)) (let* ((field (car fields)) (value (car values)) (descriptor (field-descriptor field)) (position (field-position field)) (offset (+ offset position))) (bytestructure-set!* bytevector offset descriptor value) (loop (cdr fields) (cdr values))))))) ((pair? value) ;; Assumed to be a pseudo-alist like ((k1 v1) (k2 v2) ...). (for-each (lambda (pair) (let ((key (car pair)) (value (cadr pair))) (let-values (((bytevector offset descriptor) (unwrapper #f bytevector offset key))) (bytestructure-set!* bytevector offset descriptor value)))) value)) (else (error "Invalid value for writing into struct." value)))) (define meta (let ((simple-field-alist (map (lambda (field) (cons (field-name field) (field-descriptor field))) fields))) (make-struct-metadata simple-field-alist))) (make-bytestructure-descriptor size alignment unwrapper #f setter meta)))) (define debug-alignment (case-lambda ((fields) (debug-alignment #f fields)) ((pack fields) (let* ((fields (construct-fields pack fields)) (alignment (apply max (map field-alignment fields))) (size (let* ((field (last fields)) (end (+ (field-position field) (field-size field)))) (let-values (((size . _) (next-boundary end alignment))) size)))) (format #t "{\n") (for-each (lambda (field) (let ((name (field-name field)) (pos (* 8 (field-position field))) (size (* 8 (field-size field))) (align (* 8 (field-alignment field)))) (format #t " ~a - ~a: ~a (~a, ~a)\n" pos (+ pos size) name size align))) fields) (format #t "} = ~a\n" (* 8 size)) (values))))) ;;; struct.scm ends here scheme-bytestructures-1.0.10/bytestructures/body/union.scm000066400000000000000000000055041401771724200240530ustar00rootroot00000000000000;;; union.scm --- Union descriptor constructor. ;; Copyright © 2015, 2016 Taylan Ulrich Bayırlı/Kammer ;; 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 . ;;; Commentary: ;; This constructor allows the creation of union descriptors with named fields ;; with a specific content descriptor. ;;; Code: (define make-field cons) (define field-name car) (define field-content cdr) (define find-field assq) (define (construct-fields fields) (map (lambda (field) (make-field (car field) (cadr field))) fields)) (define-record-type (make-union-metadata field-alist) union-metadata? (field-alist union-metadata-field-alist)) (define (bs:union %fields) (define fields (construct-fields %fields)) (define alignment (apply max (map (lambda (field) (bytestructure-descriptor-alignment (field-content field))) fields))) (define size (let ((max-element (apply max (map (lambda (field) (bytestructure-descriptor-size (field-content field))) fields)))) (let-values (((size . _) (next-boundary max-element alignment))) size))) (define (unwrapper syntax? bytevector offset index) (let ((index (if syntax? (syntax->datum index) index))) (values bytevector offset (field-content (find-field index fields))))) (define (setter syntax? bytevector offset value) (when syntax? (error "Writing into union not supported with macro API.")) (cond ((bytevector? value) (bytevector-copy! bytevector offset value 0 size)) ((and (list? value) (= 2 (length value))) (let-values (((bytevector* offset* descriptor) (unwrapper #f bytevector offset (car value)))) (bytestructure-set!* bytevector* offset* descriptor (cadr value)))) (else (error "Invalid value for writing into union." value)))) (define meta (make-union-metadata fields)) (make-bytestructure-descriptor size alignment unwrapper #f setter meta)) ;;; union.scm ends here scheme-bytestructures-1.0.10/bytestructures/body/utils.scm000066400000000000000000000030151401771724200240560ustar00rootroot00000000000000;;; utils.scm --- Utility library for bytestructures. ;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer ;; 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 . ;;; Commentary: ;; Just some utility procedures and macros. ;;; Code: (define-syntax define-syntax-rule (syntax-rules () ((_ ( . ) ) (define-syntax (syntax-rules () ((_ . ) )))))) (cond-expand ((or guile syntax-case) (define-syntax-rule (if-syntax-case ) )) (else (define-syntax-rule (if-syntax-case ) ))) (define-syntax-rule (define-syntax-case-stubs ...) (if-syntax-case (begin) (begin (define ( . rest) (error "Not supported. You need syntax-case.")) ...))) (define-syntax-case-stubs syntax quasisyntax unsyntax unsyntax-splicing syntax->datum datum->syntax) ;;; utils.scm ends here scheme-bytestructures-1.0.10/bytestructures/body/vector.scm000066400000000000000000000046451401771724200242320ustar00rootroot00000000000000;;; vector.scm --- Vector descriptor constructor. ;; Copyright © 2015, 2016 Taylan Ulrich Bayırlı/Kammer ;; 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 . ;;; Commentary: ;; This constructor allows the creation of vector descriptors with a specific ;; length and element descriptor. ;; Be careful with identifier names here; don't confuse vector descriptor and ;; Scheme vector APIs and variables. ;;; Code: (define-record-type (make-vector-metadata length element-descriptor) vector-metadata? (length vector-metadata-length) (element-descriptor vector-metadata-element-descriptor)) (define (bs:vector length descriptor) (define element-size (bytestructure-descriptor-size descriptor)) (define size (* length element-size)) (define alignment (bytestructure-descriptor-alignment descriptor)) (define (unwrapper syntax? bytevector offset index) (values bytevector (if syntax? (quasisyntax (+ (unsyntax offset) (* (unsyntax index) (unsyntax element-size)))) (+ offset (* index element-size))) descriptor)) (define (setter syntax? bytevector offset value) (when syntax? (error "Writing into vector not supported with macro API.")) (cond ((bytevector? value) (bytevector-copy! bytevector offset value 0 size)) ((vector? value) (do ((i 0 (+ i 1)) (offset offset (+ offset element-size))) ((= i (vector-length value))) (bytestructure-set!* bytevector offset descriptor (vector-ref value i)))) (else (error "Invalid value for writing into vector." value)))) (define meta (make-vector-metadata length descriptor)) (make-bytestructure-descriptor size alignment unwrapper #f setter meta)) ;;; vector.scm ends here scheme-bytestructures-1.0.10/bytestructures/guile.scm000066400000000000000000000043241401771724200230720ustar00rootroot00000000000000(define-module (bytestructures guile)) ;;; Note: cstring-pointer import/export hack: Guile 2.0.x has a problem when a ;;; module has the same name as an identifier defined in it, and the identifier ;;; is imported and re-exported. To work around it, we import `cstring-pointer' ;;; with a rename to `_cstring-pointer', define `cstring-pointer' explicitly in ;;; this module, and export that. (import (bytestructures guile base) (bytestructures guile vector) (bytestructures guile struct) (bytestructures guile union) (bytestructures guile pointer) (bytestructures guile numeric) (bytestructures guile string) (rename (bytestructures guile cstring-pointer) (cstring-pointer _cstring-pointer))) (re-export make-bytestructure-descriptor bytestructure-descriptor? bytestructure-descriptor-size bytestructure-descriptor-size/syntax bytestructure-descriptor-alignment bytestructure-descriptor-unwrapper bytestructure-descriptor-getter bytestructure-descriptor-setter bytestructure-descriptor-metadata make-bytestructure bytestructure? bytestructure-bytevector bytestructure-offset bytestructure-descriptor bytestructure-size bytestructure bytestructure-unwrap bytestructure-unwrap* bytestructure-ref bytestructure-ref* bytestructure-set! bytestructure-set!* bytestructure-ref/dynamic bytestructure-set!/dynamic bytestructure-unwrap/syntax bytestructure-ref/syntax bytestructure-set!/syntax define-bytestructure-accessors bs:vector vector-metadata? vector-metadata-length vector-metadata-element-descriptor bs:struct struct-metadata? struct-metadata-field-alist bs:union union-metadata? union-metadata-field-alist bs:pointer pointer-metadata? pointer-metadata-content-descriptor int8 int16 int32 int64 int16le int32le int64le int16be int32be int64be uint8 uint16 uint32 uint64 uint16le uint32le uint64le uint16be uint32be uint64be float32 float64 float32le float64le float32be float64be short unsigned-short int unsigned-int long unsigned-long long-long unsigned-long-long intptr_t uintptr_t size_t ssize_t ptrdiff_t float double complex64 complex128 complex64le complex128le complex64be complex128be bs:string ) (define cstring-pointer _cstring-pointer) (export cstring-pointer) scheme-bytestructures-1.0.10/bytestructures/guile/000077500000000000000000000000001401771724200223635ustar00rootroot00000000000000scheme-bytestructures-1.0.10/bytestructures/guile/base.scm000066400000000000000000000011101401771724200237720ustar00rootroot00000000000000(define-module (bytestructures guile base)) (import (srfi :9) (srfi :11) (ice-9 format) (bytestructures guile bytevectors) (bytestructures guile utils)) (include-from-path "bytestructures/body/base.scm") (include-from-path "bytestructures/r7/base.exports.sld") (import (srfi srfi-9 gnu)) (set-record-type-printer! (lambda (record port) (format port "#" (object-address record)))) (set-record-type-printer! (lambda (record port) (format port "#" (object-address record)))) scheme-bytestructures-1.0.10/bytestructures/guile/bitfields.scm000066400000000000000000000004531401771724200250360ustar00rootroot00000000000000(define-module (bytestructures guile bitfields)) (import (srfi :9) (srfi :60) (bytestructures guile utils) (bytestructures guile base) (bytestructures guile numeric-metadata)) (include-from-path "bytestructures/body/bitfields.scm") (include-from-path "bytestructures/r7/bitfields.exports.sld") scheme-bytestructures-1.0.10/bytestructures/guile/bytevectors.scm000066400000000000000000000060521401771724200254430ustar00rootroot00000000000000;;; Compatibility shim for Guile, because its implementation of utf16->string ;;; and utf32->string doesn't conform to R6RS. (define-module (bytestructures guile bytevectors)) (import (rnrs base) (rnrs control) (bytestructures r6 bytevectors)) (re-export endianness native-endianness bytevector? make-bytevector bytevector-length bytevector=? bytevector-fill! bytevector-copy! bytevector-copy bytevector-u8-ref bytevector-s8-ref bytevector-u8-set! bytevector-s8-set! bytevector->u8-list u8-list->bytevector bytevector-uint-ref bytevector-uint-set! bytevector-sint-ref bytevector-sint-set! bytevector->sint-list bytevector->uint-list uint-list->bytevector sint-list->bytevector bytevector-u16-ref bytevector-s16-ref bytevector-u16-set! bytevector-s16-set! bytevector-u16-native-ref bytevector-s16-native-ref bytevector-u16-native-set! bytevector-s16-native-set! bytevector-u32-ref bytevector-s32-ref bytevector-u32-set! bytevector-s32-set! bytevector-u32-native-ref bytevector-s32-native-ref bytevector-u32-native-set! bytevector-s32-native-set! bytevector-u64-ref bytevector-s64-ref bytevector-u64-set! bytevector-s64-set! bytevector-u64-native-ref bytevector-s64-native-ref bytevector-u64-native-set! bytevector-s64-native-set! bytevector-ieee-single-ref bytevector-ieee-single-set! bytevector-ieee-single-native-ref bytevector-ieee-single-native-set! bytevector-ieee-double-ref bytevector-ieee-double-set! bytevector-ieee-double-native-ref bytevector-ieee-double-native-set! string->utf8 utf8->string string->utf16 string->utf32) (export (r6rs-utf16->string . utf16->string) (r6rs-utf32->string . utf32->string)) (define (read-bom16 bv) (let ((c0 (bytevector-u8-ref bv 0)) (c1 (bytevector-u8-ref bv 1))) (cond ((and (= c0 #xFE) (= c1 #xFF)) 'big) ((and (= c0 #xFF) (= c1 #xFE)) 'little) (else #f)))) (define r6rs-utf16->string (case-lambda ((bv default-endianness) (let ((bom-endianness (read-bom16 bv))) (if (not bom-endianness) (utf16->string bv default-endianness) (substring/shared (utf16->string bv bom-endianness) 1)))) ((bv endianness endianness-mandatory?) (if endianness-mandatory? (utf16->string bv endianness) (r6rs-utf16->string bv endianness))))) (define (read-bom32 bv) (let ((c0 (bytevector-u8-ref bv 0)) (c1 (bytevector-u8-ref bv 1)) (c2 (bytevector-u8-ref bv 2)) (c3 (bytevector-u8-ref bv 3))) (cond ((and (= c0 #x00) (= c1 #x00) (= c2 #xFE) (= c3 #xFF)) 'big) ((and (= c0 #xFF) (= c1 #xFE) (= c2 #x00) (= c3 #x00)) 'little) (else #f)))) (define r6rs-utf32->string (case-lambda ((bv default-endianness) (let ((bom-endianness (read-bom32 bv))) (if (not bom-endianness) (utf32->string bv default-endianness) (substring/shared (utf32->string bv bom-endianness) 1)))) ((bv endianness endianness-mandatory?) (if endianness-mandatory? (utf32->string bv endianness) (r6rs-utf32->string bv endianness))))) scheme-bytestructures-1.0.10/bytestructures/guile/cstring-pointer.scm000066400000000000000000000051671401771724200262270ustar00rootroot00000000000000;;; cstring-pointer.scm --- Pointers to null-terminated strings. ;; Copyright © 2017 Taylan Ulrich Bayırlı/Kammer ;; 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 . ;;; Commentary: ;; The cstring-pointer descriptor represents a pointer to a null-terminated ;; string, and will return the string as a Scheme string upon a reference ;; operation. Its setter however does not take Scheme strings, only addresses ;; to existing strings in memory. The reason is: Guile's string->pointer ;; creates a new C string in memory, returning an FFI pointer object holding its ;; address; the string is freed when the pointer object is garbage collected. ;; We have no means of holding a reference to the FFI pointer object; we can ;; only write the address it holds into our bytevector, which won't protect the ;; pointer object from GC. ;;; Code: (define-module (bytestructures guile cstring-pointer)) (import (bytestructures guile base) (bytestructures guile numeric) (prefix (system foreign) ffi:)) (export cstring-pointer) (define (bytevector-address-ref bv offset) (bytestructure-ref* bv offset uintptr_t)) (define (bytevector-address-set! bv offset address) (bytestructure-set!* bv offset uintptr_t address)) (define cstring-pointer (let () (define size (bytestructure-descriptor-size intptr_t)) (define alignment (bytestructure-descriptor-alignment intptr_t)) (define unwrapper #f) (define (getter syntax? bv offset) (if syntax? #`(let* ((address (bytevector-address-ref #,bv #,offset)) (pointer (ffi:make-pointer address))) (ffi:pointer->string pointer)) (let* ((address (bytevector-address-ref bv offset)) (pointer (ffi:make-pointer address))) (ffi:pointer->string pointer)))) (define (setter syntax? bv offset address) (if syntax? #`(bytevector-address-set! #,bv #,offset #,address) (bytevector-address-set! bv offset address))) (make-bytestructure-descriptor size alignment unwrapper getter setter))) scheme-bytestructures-1.0.10/bytestructures/guile/explicit-endianness.scm000066400000000000000000000004201401771724200270310ustar00rootroot00000000000000(define-module (bytestructures guile explicit-endianness)) (import (bytestructures guile bytevectors) (bytestructures guile utils)) (include-from-path "bytestructures/body/explicit-endianness.scm") (include-from-path "bytestructures/r7/explicit-endianness.exports.sld") scheme-bytestructures-1.0.10/bytestructures/guile/ffi.scm000066400000000000000000000077351401771724200236470ustar00rootroot00000000000000;;; ffi.scm --- Convert bytestructure descriptors to Guile/libffi types. ;; Copyright © 2016 Taylan Ulrich Bayırlı/Kammer ;; 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 . ;;; Commentary: ;; This module offers a way to convert bytestructure descriptors to Guile/libffi ;; type objects. For instance, the bytestructure descriptor created with ;; (bs:struct `((x ,uint8) (y ,uint16))) gets converted into a two-element list ;; containing the libffi codes for uint8 and uint16. ;;; Code: (define-module (bytestructures guile ffi)) (import (ice-9 match) (prefix (system foreign) ffi:) (bytestructures guile base) (bytestructures guile numeric) (bytestructures guile vector) (bytestructures guile struct) (bytestructures guile union) (bytestructures guile pointer) (bytestructures guile bitfields)) (export bytestructure-descriptor->ffi-descriptor bs:pointer->proc ) (define numeric-type-mapping `((,int8 . ,ffi:int8) (,uint8 . ,ffi:uint8) (,int16 . ,ffi:int16) (,uint16 . ,ffi:uint16) (,int32 . ,ffi:int32) (,uint32 . ,ffi:uint32) (,int64 . ,ffi:int64) (,uint64 . ,ffi:uint64) (,float32 . ,ffi:float) (,float64 . ,ffi:double))) (define (bytestructure-descriptor->ffi-descriptor descriptor) (define (convert descriptor) (cond ((assq descriptor numeric-type-mapping) => (match-lambda ((key . val) val))) (else (let ((metadata (bytestructure-descriptor-metadata descriptor))) (cond ((vector-metadata? metadata) (make-list (vector-metadata-length metadata) (convert (vector-metadata-element-descriptor metadata)))) ((struct-metadata? metadata) (map convert (map cdr (struct-metadata-field-alist metadata)))) ((union-metadata? metadata) ;; TODO: Add support once Guile/libffi supports this. (error "Unions not supported." descriptor)) ((pointer-metadata? metadata) '*) ((bitfield-metadata? metadata) ;; TODO: Add support once Guile/libffi supports this. (error "Bitfields not supported." descriptor)) (else (error "Unsupported bytestructure descriptor." descriptor))))))) (cond ((eq? descriptor 'void) ffi:void) ((vector-metadata? (bytestructure-descriptor-metadata descriptor)) '*) (else (convert descriptor)))) (define (bs:pointer->proc ret-type func-ptr arg-types) (define (type->raw-type type) (if (bytestructure-descriptor? type) (bytestructure-descriptor->ffi-descriptor type) type)) (define (value->raw-value value) (if (bytestructure? value) (ffi:bytevector->pointer (bytestructure-bytevector value)) value)) (define (raw-value->value raw-value type) (if (bytestructure-descriptor? type) (make-bytestructure (ffi:pointer->bytevector raw-value (bytestructure-descriptor-size type)) 0 type) raw-value)) (let* ((raw-ret-type (type->raw-type ret-type)) (raw-arg-types (map type->raw-type arg-types)) (raw-proc (ffi:pointer->procedure raw-ret-type func-ptr raw-arg-types))) (lambda args (let* ((raw-args (map value->raw-value args)) (raw-ret-val (apply raw-proc raw-args))) (raw-value->value raw-ret-val ret-type))))) scheme-bytestructures-1.0.10/bytestructures/guile/numeric-all.scm000066400000000000000000000006511401771724200253010ustar00rootroot00000000000000(define-module (bytestructures guile numeric-all)) (import (bytestructures guile bytevectors) (bytestructures guile utils) (bytestructures guile base) (bytestructures guile explicit-endianness) (bytestructures guile numeric-data-model)) (include-from-path "bytestructures/body/numeric.scm") (include-from-path "bytestructures/r7/numeric.exports.sld") (include-from-path "bytestructures/r7/numeric-metadata.exports.sld") scheme-bytestructures-1.0.10/bytestructures/guile/numeric-data-model.scm000066400000000000000000000012561401771724200265420ustar00rootroot00000000000000(define-module (bytestructures guile numeric-data-model)) (import (system foreign)) (import (system base target)) (define architecture (let ((cpu (target-cpu))) (cond ((member cpu '("i386" "i486" "i586" "i686")) 'i386) ((string=? "x86_64" cpu) 'x86-64) ((string-prefix? "arm" cpu) 'arm) ((string-prefix? "aarch64" cpu) 'aarch64)))) (define data-model (if (= 4 (sizeof '*)) (if (= 2 (sizeof int)) 'lp32 'ilp32) (cond ((= 8 (sizeof int)) 'ilp64) ((= 4 (sizeof long)) 'llp64) (else 'lp64)))) (cond-expand-provide (current-module) (list architecture data-model)) scheme-bytestructures-1.0.10/bytestructures/guile/numeric-metadata.scm000066400000000000000000000007671401771724200263210ustar00rootroot00000000000000(define-module (bytestructures guile numeric-metadata)) (import (bytestructures guile numeric-all)) (re-export signed-integer-native-descriptors signed-integer-le-descriptors signed-integer-be-descriptors signed-integer-descriptors unsigned-integer-native-descriptors unsigned-integer-le-descriptors unsigned-integer-be-descriptors unsigned-integer-descriptors float-native-descriptors float-le-descriptors float-be-descriptors integer-descriptors float-descriptors numeric-descriptors ) scheme-bytestructures-1.0.10/bytestructures/guile/numeric.scm000066400000000000000000000010401401771724200245240ustar00rootroot00000000000000(define-module (bytestructures guile numeric)) (import (bytestructures guile numeric-all)) (re-export int8 uint8 int16 uint16 int32 uint32 int64 uint64 int16le uint16le int32le uint32le int64le uint64le int16be uint16be int32be uint32be int64be uint64be float32 float64 float32le float64le float32be float64be short unsigned-short int unsigned-int long unsigned-long long-long unsigned-long-long intptr_t uintptr_t size_t ssize_t ptrdiff_t float double complex64 complex128 complex64le complex128le complex64be complex128be ) scheme-bytestructures-1.0.10/bytestructures/guile/pointer.scm000066400000000000000000000100131401771724200245420ustar00rootroot00000000000000;;; pointer.scm --- Pointer descriptor constructor. ;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer ;; 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 . ;;; Commentary: ;; This constructor allows the creation of pointer descriptors with a specific ;; pointed-to descriptor. ;;; Code: (define-module (bytestructures guile pointer)) (import (srfi :9) (bytestructures guile bytevectors) (bytestructures guile utils) (bytestructures guile base) (prefix (system foreign) ffi:)) (export bs:pointer pointer-metadata? pointer-metadata-content-descriptor ) (define pointer-size (ffi:sizeof '*)) (define bytevector-address-ref (case pointer-size ((1) bytevector-u8-ref) ((2) bytevector-u16-native-ref) ((4) bytevector-u32-native-ref) ((8) bytevector-u64-native-ref))) (define bytevector-address-set! (case pointer-size ((1) bytevector-u8-set!) ((2) bytevector-u16-native-set!) ((4) bytevector-u32-native-set!) ((8) bytevector-u64-native-set!))) (define (pointer-ref bytevector offset content-size) (let ((address (bytevector-address-ref bytevector offset))) (if (zero? address) (error "Tried to dereference null-pointer.") (ffi:pointer->bytevector (ffi:make-pointer address) content-size)))) (define (pointer-set! bytevector offset value) (cond ((exact-integer? value) (bytevector-address-set! bytevector offset value)) ((bytevector? value) (bytevector-address-set! bytevector offset (ffi:bytevector->pointer value))) ((bytestructure? value) (bytevector-address-set! bytevector offset (ffi:bytevector->pointer (bytestructure-bytevector value)))))) (define-record-type (make-pointer-metadata content-descriptor) pointer-metadata? (content-descriptor pointer-metadata-content-descriptor)) (define (bs:pointer %descriptor) (define (get-descriptor) (if (promise? %descriptor) (force %descriptor) %descriptor)) (define size pointer-size) (define alignment size) (define (unwrapper syntax? bytevector offset index) (define (syntax-list id . elements) (datum->syntax id (map syntax->datum elements))) (let ((descriptor (get-descriptor))) (when (eq? 'void descriptor) (error "Tried to follow void pointer.")) (let* ((size (bytestructure-descriptor-size descriptor)) (bytevector* (if syntax? #`(pointer-ref #,bytevector #,offset #,size) (pointer-ref bytevector offset size))) (index-datum (if syntax? (syntax->datum index) index))) (if (eq? '* index-datum) (values bytevector* 0 descriptor) (if syntax? (bytestructure-unwrap/syntax bytevector* 0 descriptor (syntax-list index index)) (bytestructure-unwrap* bytevector* 0 descriptor index)))))) (define (getter syntax? bytevector offset) (if syntax? #`(bytevector-address-ref #,bytevector #,offset) (bytevector-address-ref bytevector offset))) (define (setter syntax? bytevector offset value) (if syntax? #`(pointer-set! #,bytevector #,offset #,value) (pointer-set! bytevector offset value))) (define meta (make-pointer-metadata %descriptor)) (make-bytestructure-descriptor size alignment unwrapper getter setter meta)) ;;; pointer.scm ends here scheme-bytestructures-1.0.10/bytestructures/guile/string.scm000066400000000000000000000004061401771724200243750ustar00rootroot00000000000000(define-module (bytestructures guile string)) (import (bytestructures guile bytevectors) (bytestructures guile utils) (bytestructures guile base)) (include-from-path "bytestructures/body/string.scm") (include-from-path "bytestructures/r7/string.exports.sld") scheme-bytestructures-1.0.10/bytestructures/guile/struct.scm000066400000000000000000000005761401771724200244230ustar00rootroot00000000000000(define-module (bytestructures guile struct)) (import (srfi :1) (srfi :9) (srfi :11) (bytestructures guile bytevectors) (bytestructures guile utils) (bytestructures guile base) (bytestructures guile bitfields)) (include-from-path "bytestructures/body/align.scm") (include-from-path "bytestructures/body/struct.scm") (include-from-path "bytestructures/r7/struct.exports.sld") scheme-bytestructures-1.0.10/bytestructures/guile/union.scm000066400000000000000000000005161401771724200242210ustar00rootroot00000000000000(define-module (bytestructures guile union)) (import (srfi :9) (srfi :11) (bytestructures guile bytevectors) (bytestructures guile utils) (bytestructures guile base)) (include-from-path "bytestructures/body/align.scm") (include-from-path "bytestructures/body/union.scm") (include-from-path "bytestructures/r7/union.exports.sld") scheme-bytestructures-1.0.10/bytestructures/guile/utils.scm000066400000000000000000000002261401771724200242270ustar00rootroot00000000000000(define-module (bytestructures guile utils)) (include-from-path "bytestructures/body/utils.scm") (export if-syntax-case define-syntax-case-stubs ) scheme-bytestructures-1.0.10/bytestructures/guile/vector.scm000066400000000000000000000004211401771724200243660ustar00rootroot00000000000000(define-module (bytestructures guile vector)) (import (srfi :9) (bytestructures guile bytevectors) (bytestructures guile utils) (bytestructures guile base)) (include-from-path "bytestructures/body/vector.scm") (include-from-path "bytestructures/r7/vector.exports.sld") scheme-bytestructures-1.0.10/bytestructures/r6/000077500000000000000000000000001401771724200216055ustar00rootroot00000000000000scheme-bytestructures-1.0.10/bytestructures/r6/bytevectors.scm000066400000000000000000000061331401771724200246650ustar00rootroot00000000000000;;; Compatibility shim for R6RS systems, because R6RS and R7RS have different ;;; semantics for some procedures of the same name. We use R7RS semantics ;;; everywhere, so implement them in terms of R6RS. (library (bytestructures r6 bytevectors) (export endianness native-endianness bytevector? make-bytevector bytevector-length bytevector=? bytevector-fill! (rename (r7rs-bytevector-copy! bytevector-copy!)) (rename (r7rs-bytevector-copy bytevector-copy)) bytevector-u8-ref bytevector-s8-ref bytevector-u8-set! bytevector-s8-set! bytevector->u8-list u8-list->bytevector bytevector-uint-ref bytevector-uint-set! bytevector-sint-ref bytevector-sint-set! bytevector->sint-list bytevector->uint-list uint-list->bytevector sint-list->bytevector bytevector-u16-ref bytevector-s16-ref bytevector-u16-set! bytevector-s16-set! bytevector-u16-native-ref bytevector-s16-native-ref bytevector-u16-native-set! bytevector-s16-native-set! bytevector-u32-ref bytevector-s32-ref bytevector-u32-set! bytevector-s32-set! bytevector-u32-native-ref bytevector-s32-native-ref bytevector-u32-native-set! bytevector-s32-native-set! bytevector-u64-ref bytevector-s64-ref bytevector-u64-set! bytevector-s64-set! bytevector-u64-native-ref bytevector-s64-native-ref bytevector-u64-native-set! bytevector-s64-native-set! bytevector-ieee-single-ref bytevector-ieee-single-set! bytevector-ieee-single-native-ref bytevector-ieee-single-native-set! bytevector-ieee-double-ref bytevector-ieee-double-set! bytevector-ieee-double-native-ref bytevector-ieee-double-native-set! (rename (r7rs-string->utf8 string->utf8)) (rename (r7rs-utf8->string utf8->string)) string->utf16 string->utf32 utf16->string utf32->string ) (import (rnrs base) (rnrs control) (rnrs bytevectors)) (define r7rs-bytevector-copy! (case-lambda ((to at from) (bytevector-copy! from 0 to at (bytevector-length from))) ((to at from start) (bytevector-copy! from start to at (- (bytevector-length from) start))) ((to at from start end) (bytevector-copy! from start to at (- end start))))) (define r7rs-bytevector-copy (case-lambda ((bytevector) (bytevector-copy bytevector)) ((bytevector start) (r7rs-bytevector-copy bytevector start (bytevector-length bytevector))) ((bytevector start end) (let* ((size (- end start)) (bytevector* (make-bytevector size))) (bytevector-copy! bytevector start bytevector* 0 size) bytevector*)))) (define r7rs-string->utf8 (case-lambda ((string) (string->utf8 string)) ((string start) (string->utf8 (substring string start (string-length string)))) ((string start end) (string->utf8 (substring string start end))))) (define r7rs-utf8->string (case-lambda ((bytevector) (utf8->string bytevector)) ((bytevector start) (utf8->string (r7rs-bytevector-copy bytevector start))) ((bytevector start end) (utf8->string (r7rs-bytevector-copy bytevector start end)))))) scheme-bytestructures-1.0.10/bytestructures/r7.scm000077700000000000000000000000001401771724200233412r7.sldustar00rootroot00000000000000scheme-bytestructures-1.0.10/bytestructures/r7.sld000066400000000000000000000010661401771724200223150ustar00rootroot00000000000000(define-library (bytestructures r7) (import (bytestructures r7 base) (bytestructures r7 vector) (bytestructures r7 struct) (bytestructures r7 union) (bytestructures r7 numeric) (bytestructures r7 string)) (include-library-declarations "r7/base.exports.sld") (include-library-declarations "r7/vector.exports.sld") (include-library-declarations "r7/struct.exports.sld") (include-library-declarations "r7/union.exports.sld") (include-library-declarations "r7/numeric.exports.sld") (include-library-declarations "r7/string.exports.sld")) scheme-bytestructures-1.0.10/bytestructures/r7/000077500000000000000000000000001401771724200216065ustar00rootroot00000000000000scheme-bytestructures-1.0.10/bytestructures/r7/base.exports.sld000066400000000000000000000013561401771724200247340ustar00rootroot00000000000000(export make-bytestructure-descriptor bytestructure-descriptor? bytestructure-descriptor-size bytestructure-descriptor-size/syntax bytestructure-descriptor-alignment bytestructure-descriptor-unwrapper bytestructure-descriptor-getter bytestructure-descriptor-setter bytestructure-descriptor-metadata make-bytestructure bytestructure? bytestructure-bytevector bytestructure-offset bytestructure-descriptor bytestructure-size bytestructure bytestructure-unwrap bytestructure-unwrap* bytestructure-ref bytestructure-ref* bytestructure-set! bytestructure-set!* bytestructure-ref/dynamic bytestructure-set!/dynamic bytestructure-unwrap/syntax bytestructure-ref/syntax bytestructure-set!/syntax define-bytestructure-accessors ) scheme-bytestructures-1.0.10/bytestructures/r7/base.scm000077700000000000000000000000001401771724200246352base.sldustar00rootroot00000000000000scheme-bytestructures-1.0.10/bytestructures/r7/base.sld000066400000000000000000000004471401771724200232310ustar00rootroot00000000000000(define-library (bytestructures r7 base) (import (scheme base) (scheme case-lambda) (bytestructures r7 utils)) (cond-expand ((library (rnrs syntax-case)) (import (rnrs syntax-case))) (else)) (include-library-declarations "base.exports.sld") (include "body/base.scm")) scheme-bytestructures-1.0.10/bytestructures/r7/bitfields.exports.sld000066400000000000000000000001571401771724200257650ustar00rootroot00000000000000(export bitfield-descriptor bitfield-metadata? bitfield-metadata-int-descriptor bitfield-metadata-width ) scheme-bytestructures-1.0.10/bytestructures/r7/bitfields.scm000077700000000000000000000000001401771724200267232bitfields.sldustar00rootroot00000000000000scheme-bytestructures-1.0.10/bytestructures/r7/bitfields.sld000066400000000000000000000004231401771724200242560ustar00rootroot00000000000000(define-library (bytestructures r7 bitfields) (import (scheme base) (srfi 60) (bytestructures r7 utils) (bytestructures r7 base) (bytestructures r7 numeric-metadata)) (include-library-declarations "bitfields.exports.sld") (include "body/bitfields.scm")) scheme-bytestructures-1.0.10/bytestructures/r7/body000077700000000000000000000000001401771724200235542../bodyustar00rootroot00000000000000scheme-bytestructures-1.0.10/bytestructures/r7/bytevectors.scm000077700000000000000000000000001401771724200277332bytevectors.sldustar00rootroot00000000000000scheme-bytestructures-1.0.10/bytestructures/r7/bytevectors.sld000066400000000000000000000041071401771724200246650ustar00rootroot00000000000000(define-library (bytestructures r7 bytevectors) (cond-expand ((library (rnrs bytevectors)) (import (except (rnrs bytevectors) bytevector? make-bytevector bytevector-length bytevector-u8-ref bytevector-u8-set! bytevector-copy bytevector-copy! string->utf8 utf8->string))) (else (import (except (r6rs bytevectors) bytevector? make-bytevector bytevector-length bytevector-u8-ref bytevector-u8-set! bytevector-copy bytevector-copy! string->utf8 utf8->string)))) (export endianness native-endianness bytevector=? bytevector-fill! bytevector-s8-ref bytevector-s8-set! bytevector->u8-list u8-list->bytevector bytevector-uint-ref bytevector-sint-ref bytevector-uint-set! bytevector-sint-set! bytevector->uint-list bytevector->sint-list uint-list->bytevector sint-list->bytevector bytevector-u16-ref bytevector-s16-ref bytevector-u16-native-ref bytevector-s16-native-ref bytevector-u16-set! bytevector-s16-set! bytevector-u16-native-set! bytevector-s16-native-set! bytevector-u32-ref bytevector-s32-ref bytevector-u32-native-ref bytevector-s32-native-ref bytevector-u32-set! bytevector-s32-set! bytevector-u32-native-set! bytevector-s32-native-set! bytevector-u64-ref bytevector-s64-ref bytevector-u64-native-ref bytevector-s64-native-ref bytevector-u64-set! bytevector-s64-set! bytevector-u64-native-set! bytevector-s64-native-set! bytevector-ieee-single-native-ref bytevector-ieee-single-ref bytevector-ieee-double-native-ref bytevector-ieee-double-ref bytevector-ieee-single-native-set! bytevector-ieee-single-set! bytevector-ieee-double-native-set! bytevector-ieee-double-set! string->utf16 string->utf32 utf16->string utf32->string )) scheme-bytestructures-1.0.10/bytestructures/r7/explicit-endianness.exports.sld000066400000000000000000000016071401771724200277670ustar00rootroot00000000000000(export bytevector-ieee-single-le-ref bytevector-ieee-single-be-ref bytevector-ieee-single-le-set! bytevector-ieee-single-be-set! bytevector-ieee-double-le-ref bytevector-ieee-double-be-ref bytevector-ieee-double-le-set! bytevector-ieee-double-be-set! bytevector-s16le-ref bytevector-s16be-ref bytevector-s16le-set! bytevector-s16be-set! bytevector-u16le-ref bytevector-u16be-ref bytevector-u16le-set! bytevector-u16be-set! bytevector-s32le-ref bytevector-s32be-ref bytevector-s32le-set! bytevector-s32be-set! bytevector-u32le-ref bytevector-u32be-ref bytevector-u32le-set! bytevector-u32be-set! bytevector-s64le-ref bytevector-s64be-ref bytevector-s64le-set! bytevector-s64be-set! bytevector-u64le-ref bytevector-u64be-ref bytevector-u64le-set! bytevector-u64be-set! ) scheme-bytestructures-1.0.10/bytestructures/r7/explicit-endianness.scm000077700000000000000000000000001401771724200327252explicit-endianness.sldustar00rootroot00000000000000scheme-bytestructures-1.0.10/bytestructures/r7/explicit-endianness.sld000066400000000000000000000004031401771724200262550ustar00rootroot00000000000000(define-library (bytestructures r7 explicit-endianness) (import (scheme base) (bytestructures r7 utils) (bytestructures r7 bytevectors)) (include-library-declarations "explicit-endianness.exports.sld") (include "body/explicit-endianness.scm")) scheme-bytestructures-1.0.10/bytestructures/r7/numeric-all.scm000077700000000000000000000000001401771724200274312numeric-all.sldustar00rootroot00000000000000scheme-bytestructures-1.0.10/bytestructures/r7/numeric-all.sld000066400000000000000000000006171401771724200245260ustar00rootroot00000000000000(define-library (bytestructures r7 numeric-all) (import (scheme base) (scheme complex) (scheme eval) (bytestructures r7 utils) (bytestructures r7 base) (bytestructures r7 bytevectors) (bytestructures r7 explicit-endianness)) (include-library-declarations "numeric.exports.sld") (include-library-declarations "numeric-metadata.exports.sld") (include "body/numeric.scm")) scheme-bytestructures-1.0.10/bytestructures/r7/numeric-metadata.exports.sld000066400000000000000000000007611401771724200272410ustar00rootroot00000000000000(export signed-integer-native-descriptors signed-integer-le-descriptors signed-integer-be-descriptors signed-integer-descriptors unsigned-integer-native-descriptors unsigned-integer-le-descriptors unsigned-integer-be-descriptors unsigned-integer-descriptors float-native-descriptors float-le-descriptors float-be-descriptors complex-native-descriptors complex-le-descriptors complex-be-descriptors integer-descriptors float-descriptors complex-descriptors numeric-descriptors ) scheme-bytestructures-1.0.10/bytestructures/r7/numeric-metadata.scm000077700000000000000000000000001401771724200314512numeric-metadata.sldustar00rootroot00000000000000scheme-bytestructures-1.0.10/bytestructures/r7/numeric-metadata.sld000066400000000000000000000002411401771724200255270ustar00rootroot00000000000000(define-library (bytestructures r7 numeric-metadata) (import (bytestructures r7 numeric-all)) (include-library-declarations "numeric-metadata.exports.sld")) scheme-bytestructures-1.0.10/bytestructures/r7/numeric.exports.sld000066400000000000000000000007061401771724200254620ustar00rootroot00000000000000(export int8 int16 int32 int64 uint8 uint16 uint32 uint64 int16le int32le int64le uint16le uint32le uint64le int16be int32be int64be uint16be uint32be uint64be float32 float64 float32le float64le float32be float64be short unsigned-short int unsigned-int long unsigned-long long-long unsigned-long-long intptr_t uintptr_t size_t ssize_t ptrdiff_t float double complex64 complex128 complex64le complex128le complex64be complex128be ) scheme-bytestructures-1.0.10/bytestructures/r7/numeric.scm000077700000000000000000000000001401771724200261152numeric.sldustar00rootroot00000000000000scheme-bytestructures-1.0.10/bytestructures/r7/numeric.sld000066400000000000000000000002171401771724200237540ustar00rootroot00000000000000(define-library (bytestructures r7 numeric) (import (bytestructures r7 numeric-all)) (include-library-declarations "numeric.exports.sld")) scheme-bytestructures-1.0.10/bytestructures/r7/string.exports.sld000066400000000000000000000002621401771724200253230ustar00rootroot00000000000000(export bs:string) (cond-expand (r6rs (export bytevector->string string->bytevector ascii utf8 utf16le utf16be utf32le utf32be bytevector-zero!)) (else)) scheme-bytestructures-1.0.10/bytestructures/r7/string.sld000066400000000000000000000005241401771724200236210ustar00rootroot00000000000000(define-library (bytestructures r7 string) (import (scheme base) (bytestructures r7 bytevectors) (bytestructures r7 utils) (bytestructures r7 base)) (cond-expand ((library (rnrs syntax-case)) (import (rnrs syntax-case))) (else)) (include-library-declarations "string.exports.sld") (include "body/string.scm")) scheme-bytestructures-1.0.10/bytestructures/r7/struct.exports.sld000066400000000000000000000001051401771724200253350ustar00rootroot00000000000000(export bs:struct struct-metadata? struct-metadata-field-alist ) scheme-bytestructures-1.0.10/bytestructures/r7/struct.scm000077700000000000000000000000001401771724200256612struct.sldustar00rootroot00000000000000scheme-bytestructures-1.0.10/bytestructures/r7/struct.sld000066400000000000000000000005041401771724200236350ustar00rootroot00000000000000(define-library (bytestructures r7 struct) (import (scheme base) (scheme case-lambda) (srfi 1) (srfi 28) (bytestructures r7 utils) (bytestructures r7 base) (bytestructures r7 bitfields)) (include-library-declarations "struct.exports.sld") (include "body/align.scm") (include "body/struct.scm")) scheme-bytestructures-1.0.10/bytestructures/r7/union.exports.sld000066400000000000000000000001021401771724200251360ustar00rootroot00000000000000(export bs:union union-metadata? union-metadata-field-alist ) scheme-bytestructures-1.0.10/bytestructures/r7/union.scm000077700000000000000000000000001401771724200252712union.sldustar00rootroot00000000000000scheme-bytestructures-1.0.10/bytestructures/r7/union.sld000066400000000000000000000003571401771724200234470ustar00rootroot00000000000000(define-library (bytestructures r7 union) (import (scheme base) (bytestructures r7 utils) (bytestructures r7 base)) (include-library-declarations "union.exports.sld") (include "body/align.scm") (include "body/union.scm")) scheme-bytestructures-1.0.10/bytestructures/r7/utils.scm000077700000000000000000000000001401771724200253112utils.sldustar00rootroot00000000000000scheme-bytestructures-1.0.10/bytestructures/r7/utils.sld000066400000000000000000000005421401771724200234530ustar00rootroot00000000000000(define-library (bytestructures r7 utils) (import (scheme base)) (cond-expand ((library (rnrs syntax-case)) (import (rnrs syntax-case))) (else)) (export define-syntax-rule if-syntax-case define-syntax-case-stubs quasisyntax unsyntax unsyntax-splicing syntax->datum datum->syntax ) (include "body/utils.scm")) scheme-bytestructures-1.0.10/bytestructures/r7/vector.exports.sld000066400000000000000000000001441401771724200253160ustar00rootroot00000000000000(export bs:vector vector-metadata? vector-metadata-length vector-metadata-element-descriptor ) scheme-bytestructures-1.0.10/bytestructures/r7/vector.scm000077700000000000000000000000001401771724200256152vector.sldustar00rootroot00000000000000scheme-bytestructures-1.0.10/bytestructures/r7/vector.sld000066400000000000000000000003251401771724200236140ustar00rootroot00000000000000(define-library (bytestructures r7 vector) (import (scheme base) (bytestructures r7 utils) (bytestructures r7 base)) (include-library-declarations "vector.exports.sld") (include "body/vector.scm")) scheme-bytestructures-1.0.10/configure.ac000066400000000000000000000010041401771724200204300ustar00rootroot00000000000000AC_INIT([bytestructures], [1.0.10], [], [], [https://github.com/TaylanUB/scheme-bytestructures/]) AC_CONFIG_SRCDIR(bytestructures) AC_CONFIG_MACRO_DIR([m4]) AM_INIT_AUTOMAKE([-Wall -Werror foreign color-tests]) dnl Enable silent rules by default. AM_SILENT_RULES([yes]) GUILE_PKG([3.0 2.2 2.0]) GUILE_PROGS AC_CONFIG_FILES([Makefile]) AC_CONFIG_FILES([pre-inst-env], [chmod +x pre-inst-env]) if test "$cross_compiling" != no; then GUILE_TARGET="--target=$host_alias" AC_SUBST([GUILE_TARGET]) fi AC_OUTPUT scheme-bytestructures-1.0.10/guile-coverage.scm000077500000000000000000000013701401771724200215550ustar00rootroot00000000000000;;; Use this in the REPL. It produces wrong results when ran as a script. (use-modules (system vm coverage) (system vm vm) (srfi srfi-11)) (let ((output-directory (string-append (getenv "HOME") "/srv/http/htdocs/lcov/scheme-bytestructures"))) (let-values (((data . values) (with-code-coverage (the-vm) (lambda () (load "run-tests.guile.scm"))))) (let* ((port (mkstemp! (string-copy "/tmp/bytestructures-coverage-XXXXXX"))) (file (port-filename port))) (coverage-data->lcov data port) (close port) (when (not (zero? (system* "genhtml" file "-o" output-directory))) (error "genhtml failed")) (delete-file file)))) scheme-bytestructures-1.0.10/guile.am000066400000000000000000000007361401771724200176010ustar00rootroot00000000000000GOBJECTS = $(SOURCES:%.scm=%.go) nobase_mod_DATA = $(SOURCES) $(NOCOMP_SOURCES) nobase_go_DATA = $(GOBJECTS) guile_install_go_files = install-nobase_goDATA $(guile_install_go_files): install-nobase_modDATA CLEANFILES = $(GOBJECTS) EXTRA_DIST = $(SOURCES) $(NOCOMP_SOURCES) GUILE_WARNINGS = -Wunbound-variable -Warity-mismatch -Wformat SUFFIXES = .scm .go .scm.go: $(AM_V_GEN)$(top_builddir)/pre-inst-env $(GUILE_TOOLS) compile $(GUILE_TARGET) $(GUILE_WARNINGS) -o "$@" "$<" scheme-bytestructures-1.0.10/m4/000077500000000000000000000000001401771724200164675ustar00rootroot00000000000000scheme-bytestructures-1.0.10/m4/guile.m4000066400000000000000000000363651401771724200200530ustar00rootroot00000000000000## 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 scheme-bytestructures-1.0.10/pre-inst-env.in000066400000000000000000000006511401771724200210300ustar00rootroot00000000000000#!/bin/sh abs_top_srcdir="`cd "@abs_top_srcdir@" > /dev/null; pwd`" abs_top_builddir="`cd "@abs_top_builddir@" > /dev/null; pwd`" GUILE_LOAD_COMPILED_PATH="$abs_top_builddir${GUILE_LOAD_COMPILED_PATH:+:}$GUILE_LOAD_COMPILED_PATH" GUILE_LOAD_PATH="$abs_top_builddir:$abs_top_srcdir${GUILE_LOAD_PATH:+:}:$GUILE_LOAD_PATH" export GUILE_LOAD_COMPILED_PATH GUILE_LOAD_PATH PATH="$abs_top_builddir:$PATH" export PATH exec "$@" scheme-bytestructures-1.0.10/run-tests.body.scm000066400000000000000000000403441401771724200215600ustar00rootroot00000000000000;;; run-tests.body.scm --- Bytestructures test suite. ;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer ;; 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 . ;;; Commentary: ;; A relatively simple SRFI-64 test suite. ;;; Code: (define-syntax-rule (test-= name expected expr) (test-approximate name expected expr 0)) (define-syntax-rule (maybe-skip-syntax . ) (if-syntax-case (begin . ) (begin))) (test-begin "bytestructures") (test-group "numeric" (define-syntax test-numeric-descriptors (syntax-rules () ((_ ...) (let () (define (destructure-numeric-descriptor-entry descriptor-entry proc) (define descriptor (list-ref descriptor-entry 0)) (define name (list-ref descriptor-entry 1)) (define getter (list-ref descriptor-entry 2)) (define setter (list-ref descriptor-entry 3)) (define size (bytestructure-descriptor-size descriptor)) (define float? (assq descriptor float-descriptors)) (define signed? (or float? (assq descriptor signed-integer-descriptors))) (proc descriptor name getter setter size float? signed?)) (define (get-min/max float? signed? size) (cond (float? (inexact (expt 2 (case size ((4) 24) ((8) 53))))) (signed? (- (expt 256 (- size 1)))) (else (- (expt 256 size) 1)))) (destructure-numeric-descriptor-entry (assq numeric-descriptors) (lambda (descriptor name getter setter size float? signed?) (test-group (symbol->string name) (let ((test-value-1 (if float? 1.0 1)) (test-value-2 (if float? 2.0 1))) (test-group "procedural" (define min/max (get-min/max float? signed? size)) (define bs (bytestructure descriptor)) (test-eqv "size" size (bytevector-length (bytestructure-bytevector bs))) (test-= "ref" test-value-1 (begin (setter (bytestructure-bytevector bs) 0 test-value-1) (bytestructure-ref bs))) (test-= "set" test-value-2 (begin (bytestructure-set! bs test-value-2) (getter (bytestructure-bytevector bs) 0))) (test-= "min/max" min/max (begin (bytestructure-set! bs min/max) (bytestructure-ref bs)))) (maybe-skip-syntax (test-group "syntactic" (define min/max (get-min/max float? signed? size)) ;; Must insert the top-level reference here. (define-bytestructure-accessors bs-unwrapper bs-getter bs-setter) (define bv (make-bytevector size)) (test-= "ref" test-value-1 (begin (setter bv 0 test-value-1) (bs-getter bv))) (test-= "set" test-value-2 (begin (bs-setter bv test-value-2) (getter bv 0))) (test-= "min/max" min/max (begin (bs-setter bv min/max) (bs-getter bv))))))))) ...)))) (test-numeric-descriptors float32 float32le float32be float64 float64le float64be int8 int16 int32 int64 int16le int32le int64le int16be int32be int64be uint8 uint16 uint32 uint64 uint16le uint32le uint64le uint16be uint32be uint64be)) (test-group "vector" (test-assert "create" (bs:vector 3 uint16)) (test-group "procedural" (define bs (bytestructure (bs:vector 3 uint16))) (bytevector-u16-native-set! (bytestructure-bytevector bs) 2 321) (test-eqv "ref" 321 (bytestructure-ref bs 1)) (test-eqv "set" 456 (begin (bytestructure-set! bs 1 456) (bytestructure-ref bs 1))) (test-eqv "init" 321 (let ((bs (bytestructure (bs:vector 3 uint16) '#(321 123 321)))) (bytestructure-ref bs 2)))) (maybe-skip-syntax (test-group "syntactic" (define-bytestructure-accessors (bs:vector 3 uint16) unwrapper getter setter) (define bv (make-bytevector 6)) (bytevector-u16-native-set! bv 2 321) (test-eqv "ref" 321 (getter bv 1)) (test-eqv "set" 456 (begin (setter bv 1 456) (getter bv 1)))))) (test-group "struct" (test-group "aligned" (test-assert "create" (bs:struct `((x ,uint8) (y ,uint16)))) (test-group "procedural" (define bs (bytestructure (bs:struct `((x ,uint8) (y ,uint16))))) (bytevector-u16-native-set! (bytestructure-bytevector bs) 2 321) (test-eqv "ref" 321 (bytestructure-ref bs 'y)) (test-eqv "set" 456 (begin (bytestructure-set! bs 'y 456) (bytestructure-ref bs 'y))) (test-eqv "init" 321 (let ((bs (bytestructure (bs:struct `((x ,uint8) (y ,uint16))) '#(123 321)))) (bytestructure-ref bs 'y)))) (maybe-skip-syntax (test-group "syntactic" (define-bytestructure-accessors (bs:struct `((x ,uint8) (y ,uint16))) unwrapper getter setter) (define bv (make-bytevector 4)) (bytevector-u16-native-set! bv 2 321) (test-eqv "ref" 321 (getter bv y)) (test-eqv "set" 456 (begin (setter bv y 456) (getter bv y)))))) (test-group "packed" (test-assert "create" (bs:struct #t `((x ,uint8) (y ,uint16)))) (test-group "procedural" (define bs (bytestructure (bs:struct #t `((x ,uint8) (y ,uint16))))) ;; u16-native-set! may error on non-aligned access. (guard (err (else (test-skip 3))) (bytevector-u16-native-set! (bytestructure-bytevector bs) 1 321)) (test-eqv "ref" 321 (bytestructure-ref bs 'y)) (test-eqv "set" 456 (begin (bytestructure-set! bs 'y 456) (bytestructure-ref bs 'y))) (test-eqv "init" 321 (let ((bs (bytestructure (bs:struct #t `((x ,uint8) (y ,uint16))) '#(123 321)))) (bytestructure-ref bs 'y)))) (maybe-skip-syntax (test-group "syntactic" (define-bytestructure-accessors (bs:struct #t `((x ,uint8) (y ,uint16))) unwrapper getter setter) (define bv (make-bytevector 4)) ;; u16-native-set! may error on non-aligned access. (guard (err (else (test-skip 2))) (bytevector-u16-native-set! bv 1 321)) (test-eqv "ref" 321 (getter bv y)) (test-eqv "set" 456 (begin (setter bv y 456) (getter bv y))))))) (test-group "union" (test-assert "create" (bs:union `((x ,uint8) (y ,uint16)))) (test-group "procedural" (define bs (bytestructure (bs:union `((x ,uint8) (y ,uint16))))) (bytevector-u16-native-set! (bytestructure-bytevector bs) 0 321) (test-eqv "ref" 321 (bytestructure-ref bs 'y)) (test-eqv "set" 456 (begin (bytestructure-set! bs 'y 456) (bytestructure-ref bs 'y)))) (maybe-skip-syntax (test-group "syntactic" (define-bytestructure-accessors (bs:union `((x ,uint8) (y ,uint16))) unwrapper getter setter) (define bv (make-bytevector 2)) (bytevector-u16-native-set! bv 0 321) (test-eqv "ref" 321 (getter bv y)) (test-eqv "set" 456 (begin (setter bv y 456) (getter bv y)))))) (test-group "string" (test-group "ascii" (test-assert "create" (bs:string 4 'ascii)) (test-group "procedural" (define bsd (bs:string 4 'ascii)) (define bs (make-bytestructure (string->utf8 "1234") 0 bsd)) (test-equal "ref" "1234" (bytestructure-ref bs)) (test-equal "set" "4321" (begin (bytestructure-set! bs "4321") (bytestructure-ref bs))) (test-error "too-long" #t (bytestructure-set! bs "12345")) (test-error "too-short" #t (bytestructure-set! bs "123")) (set! bs (make-bytestructure (string->utf8 "äåãø") 0 bsd)) (test-error "decoding-error" #t (bytestructure-ref bs)) (test-error "encoding-error" #t (bytestructure-set! bs "øãåä"))) (test-group "syntactic" (define-bytestructure-accessors (bs:string 4 'ascii) unwrapper getter setter) (define bv (string->utf8 "1234")) (test-equal "ref" "1234" (getter bv)) (test-equal "set" "4321" (begin (setter bv "4321") (getter bv))) (test-error "too-long" #t (setter bv "12345")) (test-error "too-short" #t (setter bv "123")) (set! bv (string->utf8 "äåãø")) (test-error "ref-error" #t (getter bv)) (test-error "set-error" #t (setter bv "øãåä")))) (test-group "utf8" (test-assert "create" (bs:string 4 'utf8)) (test-group "procedural" (define bsd (bs:string 4 'utf8)) (define bs (make-bytestructure (string->utf8 "1234") 0 bsd)) (test-equal "ref" "1234" (bytestructure-ref bs)) (test-equal "set" "4321" (begin (bytestructure-set! bs "4321") (bytestructure-ref bs))) (test-error "too-long" #t (bytestructure-set! bs "äåãø")) (test-equal (string-append "123" (string #\nul)) (begin (bytestructure-set! bs "123") (bytestructure-ref bs)))) (test-group "syntactic" (define-bytestructure-accessors (bs:string 4 'utf8) unwrapper getter setter) (define bv (string->utf8 "1234")) (test-equal "ref" "1234" (getter bv)) (test-equal "set" "4321" (begin (setter bv "4321") (getter bv))) (test-error "too-long" #t (setter bv "äåãø")) (test-equal (string-append "123" (string #\nul)) (begin (setter bv "123") (getter bv))))) (let () (define-syntax-rule (test-string-encodings ( utf>) ...) (begin (test-group (test-assert "create" (bs:string ')) (test-group "procedural" (define bs (make-bytestructure (utf> "1234" ') 0 (bs:string '))) (test-equal "ref" "1234" (bytestructure-ref bs)) (test-equal "set" "4321" (begin (bytestructure-set! bs "4321") (bytestructure-ref bs))) (test-error "too-long" #t (bytestructure-set! bs "12345")) (if (test-error "too-short" #t (bytestructure-set! bs "123")) (test-equal (string-append "123" (string #\nul)) (begin (bytestructure-set! bs "123") (bytestructure-ref bs))))) (test-group "syntactic" (define-bytestructure-accessors (bs:string ') unwrapper getter setter) (define bv (utf> "1234" ')) (test-equal "ref" "1234" (getter bv)) (test-equal "set" "4321" (begin (setter bv "4321") (getter bv))) (test-error "too-long" #t (setter bv "12345")) (if (test-error "too-short" #t (setter bv "123")) (test-equal (string-append "123" (string #\nul)) (begin (setter bv "123") (getter bv)))))) ...)) (test-string-encodings ("utf16le" utf16le little 8 #f string->utf16) ("utf16be" utf16be big 8 #f string->utf16) ("utf32le" utf32le little 16 #t string->utf32) ("utf32be" utf32be big 16 #t string->utf32)))) (cond-expand (guile (let () (define (protect-from-gc-upto-here obj) (with-output-to-file *null-device* (lambda () (display (eq? #f obj))))) (define pointer-size (ffi:sizeof '*)) (define bytevector-address-set! (case pointer-size ((1) bytevector-u8-set!) ((2) bytevector-u16-native-set!) ((4) bytevector-u32-native-set!) ((8) bytevector-u64-native-set!))) (test-group "pointer" (test-assert "create" (bs:pointer uint16)) (test-group "procedural" (define bs (bytestructure (bs:pointer uint16))) (define bv1 (make-bytevector 2)) (define address (ffi:pointer-address (ffi:bytevector->pointer bv1))) (bytevector-address-set! (bytestructure-bytevector bs) 0 address) (bytevector-u16-native-set! bv1 0 321) (test-eqv "ref" 321 (bytestructure-ref bs '*)) (test-eqv "set" 456 (begin (bytestructure-set! bs '* 456) (bytestructure-ref bs '*))) (test-eqv "ref2" address (bytestructure-ref bs)) (protect-from-gc-upto-here bv1) (let* ((bv2 (make-bytevector 2 123)) (address (ffi:pointer-address (ffi:bytevector->pointer bv2)))) (test-eqv "set2" address (begin (bytestructure-set! bs address) (bytestructure-ref bs))) (protect-from-gc-upto-here bv2))) (test-group "syntactic" (define-bytestructure-accessors (bs:pointer uint16) unwrapper getter setter) (define bv (make-bytevector pointer-size)) (define bv1 (make-bytevector 2)) (define address (ffi:pointer-address (ffi:bytevector->pointer bv1))) (bytevector-address-set! bv 0 address) (bytevector-u16-native-set! bv1 0 321) (test-eqv "ref" 321 (getter bv *)) (test-eqv "set" 456 (begin (setter bv * 456) (getter bv *))) (test-eqv "ref2" address (getter bv)) (protect-from-gc-upto-here bv1) (let* ((bv2 (make-bytevector 2 123)) (address (ffi:pointer-address (ffi:bytevector->pointer bv2)))) (test-eqv "set2" address (begin (setter bv address) (getter bv))) (protect-from-gc-upto-here bv2)))) (test-group "cstring-pointer" (let* ((cstr1-ptr (ffi:string->pointer "abc")) (cstr2-ptr (ffi:string->pointer "cba")) (cstr1-addr (ffi:pointer-address cstr1-ptr)) (cstr2-addr (ffi:pointer-address cstr2-ptr))) (test-group "procedural" (define bs (bytestructure cstring-pointer)) (bytevector-address-set! (bytestructure-bytevector bs) 0 cstr1-addr) (test-equal "ref" "abc" (bytestructure-ref bs)) (test-equal "set" "cba" (begin (bytestructure-set! bs cstr2-addr) (bytestructure-ref bs)))) (test-group "syntactic" (define-bytestructure-accessors cstring-pointer unwrapper getter setter) (define bv (make-bytevector pointer-size)) (bytevector-address-set! bv 0 cstr1-addr) (test-equal "ref" "abc" (getter bv)) (test-equal "set" "cba" (begin (setter bv cstr2-addr) (getter bv)))))))) (else )) (test-end "bytestructures") ;; Local Variables: ;; eval: (put (quote test-group) (quote scheme-indent-function) 1) ;; eval: (put (quote test-=) (quote scheme-indent-function) 2) ;; End: scheme-bytestructures-1.0.10/run-tests.guile.scm000077500000000000000000000005321401771724200217260ustar00rootroot00000000000000#!/usr/bin/env guile !# (use-modules (srfi srfi-11) (srfi srfi-64) ((rnrs exceptions) #:select (guard)) ((system foreign) #:prefix ffi:) (bytestructures r6 bytevectors) (bytestructures guile utils) (bytestructures guile) (bytestructures guile numeric-metadata)) (define inexact exact->inexact) (include-from-path "run-tests.body.scm") scheme-bytestructures-1.0.10/run-tests.r7.scm000077500000000000000000000003431401771724200211510ustar00rootroot00000000000000(import (scheme base) (srfi 64) (bytestructures r7 utils) (bytestructures r7) (bytestructures r7 numeric-metadata) (bytestructures r7 bytevectors) (bytestructures r7 explicit-endianness)) (include "run-tests.body.scm")