diff options
Diffstat (limited to 'byte.c')
| -rw-r--r-- | byte.c | 285 |
1 files changed, 285 insertions, 0 deletions
@@ -0,0 +1,285 @@ +/* Copyright (C) 2003 Free Software Foundation, Inc. + * + * 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 2, 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 software; see the file COPYING. If not, write to + * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of SCM. + * + * The exception is that, if you link the SCM library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the SCM library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name SCM. If you copy + * code from other Free Software Foundation releases into a copy of + * SCM, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for SCM, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. + */ + +/* "byte.c" Strings as Bytes + Author: Aubrey Jaffer */ + +#include "scm.h" + +char s_make_bytes[] = "make-bytes"; +SCM scm_make_bytes(k, n) + SCM k, n; +{ + SCM res; + register unsigned char *dst; + register long i; + ASRTER(INUMP(k) && (k >= 0), k, ARG1, s_make_bytes); + i = INUM(k); + res = makstr(i); + dst = UCHARS(res); + if (!UNBNDP(n)) { + ASRTER(INUMP(n) && 0 <= n && n <= MAKINUM(255), n, ARG2, s_make_bytes); + for(i--;i >= 0;i--) dst[i] = INUM(n); + } + return res; +} +#define s_bytes (s_make_bytes+5) +SCM scm_bytes(ints) + SCM ints; +{ + SCM res; + register unsigned char *data; + long i = ilength(ints); + ASRTER(i >= 0, ints, ARG1, s_bytes); + res = makstr(i); + data = UCHARS(res); + for(;NNULLP(ints);ints = CDR(ints)) { + int n = INUM(CAR(ints)); + ASRTER(INUMP(CAR(ints)) && 0 <= n && n <= 255, ints, ARG1, s_bytes); + *data++ = n; + } + return res; +} +static char s_bt_ref[] = "byte-ref"; +SCM scm_byte_ref(str, k) + SCM str, k; +{ + ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_bt_ref); + ASRTER(INUMP(k), k, ARG2, s_bt_ref); + ASRTER(0 <= INUM(k) && INUM(k) < LENGTH(str), k, OUTOFRANGE, s_bt_ref); + return MAKINUM(UCHARS(str)[INUM(k)]); +} +static char s_bt_set[] = "byte-set!"; +SCM scm_byte_set(str, k, n) + SCM str, k, n; +{ + ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_bt_set); + ASRTER(INUMP(k), k, ARG2, s_bt_set); + ASRTER(INUMP(n), n, ARG3, s_bt_set); + ASRTER(0 <= INUM(k) && INUM(k) < LENGTH(str), k, OUTOFRANGE, s_bt_set); + UCHARS(str)[INUM(k)] = INUM(n); + return UNSPECIFIED; +} +static char s_bytes2list[] = "bytes->list"; +SCM scm_bytes2list(str) + SCM str; +{ + long i; + SCM res = EOL; + unsigned char *src; + ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_bytes2list); + src = UCHARS(str); + for(i = LENGTH(str)-1;i >= 0;i--) res = cons((SCM)MAKINUM(src[i]), res); + return res; +} +static char s_bt_reverse[] = "bytes-reverse!"; +SCM scm_bytes_reverse(str) + SCM str; +{ + register char *dst; + register long k, len; + ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_bt_reverse); + len = LENGTH(str); + dst = CHARS(str); + for(k = len/2;k >= 0;k--) { + int tmp = dst[k]; + dst[k] = dst[len - k - 1]; + dst[len - k - 1] = tmp; + } + return str; +} +static char s_write_byte[] = "write-byte"; +SCM scm_write_byte(chr, port) + SCM chr, port; +{ + int k = INUM(chr); + if UNBNDP(port) port = cur_outp; + else ASRTER(NIMP(port) && OPOUTPORTP(port), port, ARG2, s_write_byte); + ASRTER(INUMP(chr) && 0 <= k && k <= 255, chr, ARG1, s_write_byte); + lputc(k, port); + return UNSPECIFIED; +} +static char s_read_byte[] = "read-byte"; +SCM scm_read_byte(port) + SCM port; +{ + int c; + if UNBNDP(port) port = cur_inp; + ASRTER(NIMP(port) && OPINPORTP(port), port, ARG1, s_read_byte); + c = lgetc(port); + if (EOF==c) return EOF_VAL; + return MAKINUM(c); +} + +static char s_sub_rd[] = "substring-read!"; +SCM scm_substring_read(sstr, start, args) + SCM sstr, start, args; +{ + SCM end, port; + long len; + long alen = ilength(args); + ASRTER(1 <= alen && alen <= 2, args, WNA, s_sub_rd); + end = CAR(args); + port = (2==alen) ? CAR(CDR(args)) : cur_inp; + ASRTER(NIMP(sstr) && STRINGP(sstr), sstr, ARG1, s_sub_rd); + ASRTER(INUMP(start), start, ARG2, s_sub_rd); + ASRTER(INUMP(end), end, ARG3, s_sub_rd); + ASRTER(NIMP(port) && OPINFPORTP(port), port, ARG4, s_sub_rd); + len = LENGTH(sstr); + start = INUM(start); + end = INUM(end); + ASRTER(0 <= start && start <= len, MAKINUM(start), OUTOFRANGE, s_sub_rd); + ASRTER(0 <= end && end <= len, MAKINUM(end), OUTOFRANGE, s_sub_rd); + if (start==end) return INUM0; + if (start < end) { + long ans = 0; + /* An ungetc before an fread will not work on some systems if setbuf(0), + so we read one element char by char. */ + if CRDYP(port) { + CHARS(sstr)[start] = lgetc(port); + start += 1; + len -= 1; + ans = 1; + } + SYSCALL(ans += fread(CHARS(sstr)+start, + (sizet)1, + (sizet)(end - start), + STREAM(port));); + return MAKINUM(ans); + } + else { + long idx = start; + while (end <= idx) { + int chr = lgetc(port); + if (EOF==chr) return MAKINUM(start - idx); + CHARS(sstr)[--idx] = chr; + } + return MAKINUM(start - end); + } +} + +static char s_sub_wr[] = "substring-write"; +SCM scm_substring_write(sstr, start, args) + SCM sstr, start, args; +{ + SCM end, port; + long len; + long alen = ilength(args); + ASRTER(1 <= alen && alen <= 2, args, WNA, s_sub_wr); + end = CAR(args); + port = (2==alen) ? CAR(CDR(args)) : cur_outp; + ASRTER(NIMP(sstr) && STRINGP(sstr), sstr, ARG1, s_sub_wr); + ASRTER(INUMP(start), start, ARG2, s_sub_wr); + ASRTER(INUMP(end), end, ARG3, s_sub_wr); + ASRTER(NIMP(port) && OPOUTFPORTP(port), port, ARG4, s_sub_wr); + len = LENGTH(sstr); + start = INUM(start); + end = INUM(end); + ASRTER(0 <= start && start <= len, MAKINUM(start), OUTOFRANGE, s_sub_wr); + ASRTER(0 <= end && end <= len, MAKINUM(end), OUTOFRANGE, s_sub_wr); + if (start==end) return INUM0; + if (start < end) { + long ans; + SYSCALL(ans = lfwrite(CHARS(sstr)+start, + (sizet)1, + (sizet)(sizet)(end - start), + port);); + return MAKINUM(ans); + } + else { + long idx = start; + while (end <= --idx) { + if (feof(STREAM(port))) return MAKINUM(start - idx - 1); + lputc(CHARS(sstr)[idx], port); + } + return MAKINUM(start - end); + } +} + +static iproc subr1s[] = { + {"list->bytes", scm_bytes}, + {s_bytes2list, scm_bytes2list}, + {s_bt_reverse, scm_bytes_reverse}, + {0, 0}}; + +static iproc subr2os[] = { + {s_write_byte, scm_write_byte}, + {s_make_bytes, scm_make_bytes}, + {0, 0}}; + +static iproc lsubr2s[] = { + {s_sub_rd, scm_substring_read}, + {s_sub_wr, scm_substring_write}, + {0, 0}}; + + +void init_byte() +{ + init_iprocs(subr1s, tc7_subr_1); + init_iprocs(subr2os, tc7_subr_2o); + init_iprocs(lsubr2s, tc7_lsubr_2); + make_subr(s_bytes, tc7_lsubr, scm_bytes); + make_subr(s_read_byte, tc7_subr_1o, scm_read_byte); + make_subr(s_bt_ref, tc7_subr_2, scm_byte_ref); + make_subr(s_bt_set, tc7_subr_3, scm_byte_set); + add_feature("byte"); + scm_ldstr("\n\ +(define bytes-length string-length)\n\ +(define bytes-copy string-copy)\n\ +(define (bytes-reverse bytes)\n\ + (bytes-reverse! (bytes-copy bytes)))\n\ +(define (read-bytes n . port)\n\ + (let* ((len (abs n))\n\ + (byts (make-bytes len))\n\ + (cnt (if (positive? n)\n\ + (apply substring-read! byts 0 n port)\n\ + (apply substring-read! byts (- n) 0 port))))\n\ + (if (= cnt len)\n\ + byts\n\ + (if (positive? n)\n\ + (substring byts 0 cnt)\n\ + (substring byts (- len cnt) len)))))\n\ +(define (write-bytes bytes n . port)\n\ + (if (positive? n)\n\ + (apply substring-write bytes 0 n port)\n\ + (apply substring-write bytes (- n) 0 port)))\n\ +"); +} |