Commit 83afb8bc authored by Erick Gallesio's avatar Erick Gallesio

- Fixes on fixnum

- New primitives: MD5SUM and MD5SUM-FILE
parent fc050f7c
......@@ -18,7 +18,7 @@
;; USA.
;; Author: Erick Gallesio [eg@unice.fr]
;; Creation date: 26-Nov-2000 18:19 (eg)
;; Last file update: 5-May-2007 11:09 (eg)
;; Last file update: 14-May-2007 10:36 (eg)
;;
;; ======================================================================
......@@ -777,6 +777,8 @@ See SRFI document for more information.])
(insertdoc 'pp)
(insertdoc 'uri-parse)
(insertdoc 'string->html)
(insertdoc 'md5sum)
(insertdoc 'md5sum-file)
(insertdoc 'base64-encode)
(insertdoc 'base64-decode)
(insertdoc 'base64-encode-string)
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 14-Mar-2001 13:49 (eg)
;;;; Last file update: 23-Feb-2007 23:04 (eg)
;;;; Last file update: 10-May-2007 15:48 (eg)
;;;;
;;;
......@@ -228,6 +228,16 @@
(DEEP-LOC-REF-FAR 1)
(DEEP-LOC-SET-FAR 1)
(CREATE-CLOSURE-FAR 2)
;; Fixnum
(IN-FXADD2 0)
(IN-FXSUB2 0)
(IN-FXMUL2 0)
(IN-FXDIV2 0)
(IN-SINT-FXADD2 1)
(IN-SINT-FXSUB2 1)
(IN-SINT-FXMUL2 1)
(IN-SINT-FXDIV2 1)
))))
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 14-Jun-2000 17:24 (eg)
;;;; Last file update: 25-Apr-2007 22:20 (eg)
;;;; Last file update: 14-May-2007 10:33 (eg)
;;;;
;;
......@@ -857,6 +857,23 @@ doc>
(set! base64-encode-string (encode/decode base64-encode))
(set! base64-decode-string (encode/decode base64-decode)))
;; ======================================================================
;; md5sum ...
;; ======================================================================
#|
<doc EXT md5sum-file
* (md5sum-file str)
*
* Return a string contening the md5 dum of the file whose name is |str|.
doc>
|#
(define (md5sum-file path)
(let ((port (open-file path "r")))
(if port
(let ((res (md5sum port)))
(close-input-port port)
res)
(error "cannot read file ~s" path))))
;; ======================================================================
;; ansi-color ...
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 26-Feb-2000 10:47 (eg)
;;;; Last file update: 4-May-2007 15:10 (eg)
;;;; Last file update: 10-May-2007 16:32 (eg)
;;;;
(define-module STKLOS-COMPILER
......@@ -41,6 +41,10 @@
(- . ,-)
(* . ,*)
(/ . ,/)
(fx+ . ,fx+)
(fx- . ,fx-)
(fx* . ,fx*)
(fxdiv . ,fxdiv)
(= . ,=)
(< . ,<)
(<= . ,<=)
......@@ -541,7 +545,6 @@ doc>
((and (pair? l) (pair? (car l)) (eq? (caar l) 'define-macro))
;; This is an internal define-macro. Add expander + skip expression
(let ((name (compile-internal-define-macro (car l) env #f)))
(eprintf "Internal macro ~S\n" name)
(set! internal-macros (cons name internal-macros))
(Loop (cdr l) defs)))
(else
......@@ -967,6 +970,39 @@ doc>
(else
(comp2 'IN-DIV2)))))
(else (compile-normal-call fct actuals len env epair #f))))
((fx+ fx- fx* fxdiv)
(case len
((2) (let ((a (car actuals))
(b (cadr actuals)))
(cond
((and (fixnum? a) (fixnum? b))
(compile-constant (case fct
((fx+) (fx+ a b))
((fx-) (fx- a b))
((fx*) (fx* a b))
((fxdiv) (fxdiv a b)))
env
tail?))
((and (small-integer-constant? a)
(memq fct '(fx+ fx*))) ; commutative only
(oper2 (if (eq? fct 'fx+) 'IN-SINT-ADD2 'INT-SINT-MUL2)
b a))
((small-integer-constant? b)
(oper2 (case fct
((fx+) 'IN-SINT-FXADD2)
((fx-) 'IN-SINT-FXSUB2)
((fx*) 'IN-SINT-FXMUL2)
((fxdiv) 'IN-SINT-FXDIV2))
a b))
(else
(comp2 (case fct
((fx+) 'IN-FXADD2)
((fx-) 'IN-FXSUB2)
((fx*) 'IN-FXMUL2)
((fxdiv) 'IN-FXDIV2)))))))
(else
(compile-normal-call fct actuals len env epair #f))))
((= < > <= >=)
(case len
((O) (compiler-error fct epair
......
......@@ -21,17 +21,17 @@
;;;;
;;;; Author: Manuel Serrano
;;;; Creation date: 8-Jan-2007 11:33 (eg)
;;;; Last file update: 8-Jan-2007 13:19 (eg)
;;;; Last file update: 10-May-2007 17:03 (eg)
;;;;
;;;;
;;;; Based on Chicken's tar implementation (Felix L. Winkelmann).
;(define-module TAR-MODULE
;(define-module TAR
(export tar-header
tar-read-header
tar-read-block
tar-round-up-to-record-size)
(define-struct tar-header
name mode uid gid size mtime checksum type linkname magic uname gname
......@@ -54,47 +54,46 @@
(define (tar-name-size) 100)
(define (tar-tunmlen) 32)
(define (tar-tgnmlen) 32)
(define (tar-tmagic) "ustar ")
(define (tar-umagic) "ustar")
(define (tar-tmagic) "ustar ")
(define (tar-umagic) "ustar")
(define (tar-gnumagic) "GNUtar ")
;; ----------------------------------------------------------------------
;; tar-type-name ...
;; ----------------------------------------------------------------------
(define (tar-type-name c)
(case c
((#\null) 'oldnormal)
((#\0) 'normal)
((#\1) 'link)
((#\2) 'symlink)
((#\3) 'chr)
((#\4) 'blk)
((#\5) 'dir)
((#\6) 'fifo)
((#\7) 'contig)
(else (tar-error "invalid file type" c))))
(case c
((#\null) 'oldnormal)
((#\0) 'normal)
((#\1) 'link)
((#\2) 'symlink)
((#\3) 'chr)
((#\4) 'blk)
((#\5) 'dir)
((#\6) 'fifo)
((#\7) 'contig)
(else (tar-error "invalid file type" c))))
;; ----------------------------------------------------------------------
;; str->octal ...
;; ----------------------------------------------------------------------
(define (str->octal str #!optional (err #t))
(or (string->number str 8)
(if err
(tar-error "invalid octal record item" str)
0)))
(or (string->number str 8)
(if err
(tar-error "invalid octal record item" str)
0)))
;; ----------------------------------------------------------------------
;; checksum ...
;; ----------------------------------------------------------------------
(define (checksum buf)
(let* ((p (+ (tar-name-size) 48))
(b2 (string-append
(substring buf 0 p)
" "
(substring buf (+ p 8) (string-length buf)))))
(do ((i 0 (+ 1 i))
(s 0 (+ s (char->integer (string-ref b2 i)))))
((>= i (tar-record-size)) s))))
(let* ((p (+ (tar-name-size) 48))
(b2 (string-append (substring buf 0 p)
" "
(substring buf (+ p 8) (string-length buf)))))
(do ((i 0 (+ 1 i))
(s 0 (+ s (char->integer (string-ref b2 i)))))
((>= i (tar-record-size)) s))))
;; ----------------------------------------------------------------------
;; tar-read-header ...
......@@ -103,6 +102,7 @@
(let* ((ptr 0)
(data (read-chars (tar-record-size) port))
(len (string-length data)))
(define (extract size)
(let loop ((i 0))
(cond
......@@ -122,10 +122,12 @@
sub))
(else
(loop (+ 1 i)))))))))
(define (fetch)
(let ((c (string-ref data ptr)))
(set! ptr (+ 1 ptr))
c))
(let ((name (if (or (not (string? data)) (= (string-length data) 0))
""
(extract (tar-name-size)))))
......@@ -155,20 +157,20 @@
csum2))
(else
(make-struct tar-header
name
mode
uid
gid
size
(seconds->date mtime)
chksum
(tar-type-name linkflag)
linkname
magic
uname
gname
devmajor
devminor))))))))
name
mode
uid
gid
size
(seconds->date mtime)
chksum
(tar-type-name linkflag)
linkname
magic
uname
gname
devmajor
devminor))))))))
;; ----------------------------------------------------------------------
;; tar-round-up-to-record-size ...
......@@ -185,11 +187,11 @@
(let ((n (tar-header-size h)))
(if (= n 0)
#f
(let ((s (read-chars n p)))
(if (< (string-length s) n)
(error "illegal block ~S" (tar-header-name h))
(read-chars (- (tar-round-up-to-record-size n) n) p))
s)))
(let ((s (read-chars n p)))
(if (< (string-length s) n)
(error "illegal block ~S" (tar-header-name h))
(read-chars (- (tar-round-up-to-record-size n) n) p))
s)))
(error "incorrect tar header ~S" h)))
(provide "tar")
\ No newline at end of file
;;; Author: Erick Gallesio [eg@essi.fr]
;;; Creation date: 21-Mar-2007 13:45 (eg)
;;; Last file update: 5-May-2007 11:51 (eg)
%%
;; Character "
#\\\" "#\\\""
;; Strings
\"([^\\\"]|\\.)*\" yytext ;|;
;;Comment
\;.* yytext
;; #!eof
#!eof "#eof"
;; Other characters
[^#\"\;]+ yytext
;; A #
[#] yytext
<<EOF>> 'eof
<<ERROR>> (error 'chicken-preprocessor "parse error ~S (line ~a)"
yytext (lexer-get-line))
;;;;
;;;; lang-chicken.stk -- Chicken language support
;;;;
;;;; Copyright 2007 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;;
;;;;
;;;; 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 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, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 21-Mar-2007 13:57 (eg)
;;;; Last file update: 5-May-2007 11:53 (eg)
;;;;
(include "lang-chicken.inc")
;; ----------------------------------------------------------------------
;; chicken-rewrite ...
;; ----------------------------------------------------------------------
(define (chicken-rewrite src dir)
(define (do-rewrite in tmp)
(with-output-to-file tmp
(lambda ()
(let ((lex (lang-chicken in)))
(let loop ((token (lexer-next-token lex)))
(unless (eq? token 'eof)
(display token)
(loop (lexer-next-token lex))))))))
(when (file-exists? src)
(let ((tmp (temporary-file-name)))
(do-rewrite src tmp)
(copy-file tmp src)
(remove-file tmp))))
;;;
;;; Register this language
;;;
(add-rewriter! 'chicken chicken-rewrite)
;;;;
;;;; lang-mzscheme.stk -- Mzscheme language support
;;;;
;;;; Copyright 2007 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;;
;;;;
;;;; 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 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, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 21-Mar-2007 13:57 (eg)
;;;; Last file update: 5-May-2007 18:50 (eg)
;;;;
(include "lang-mzscheme.inc")
;; ----------------------------------------------------------------------
;; mzscheme-rewrite ...
;; ----------------------------------------------------------------------
(define (mzscheme-rewrite src dir)
(define (do-rewrite in tmp)
(with-output-to-file tmp
(lambda ()
(let ((lex (lang-mzscheme in)))
(let loop ((token (lexer-next-token lex)))
(unless (eq? token 'eof)
(display token)
(loop (lexer-next-token lex))))))))
(when (file-exists? src)
(let ((tmp (temporary-file-name)))
(do-rewrite src tmp)
(copy-file tmp src)
(remove-file tmp))))
;;;
;;; Register this language
;;;
(add-rewriter! 'mzscheme mzscheme-rewrite)
;;; Author: Erick Gallesio [eg@essi.fr]
;;; Creation date: 21-Mar-2007 13:45 (eg)
;;; Last file update: 5-May-2007 18:49 (eg)
%%
;; Character "
#\\\" "#\\\""
;; Strings
\"([^\\\"]|\\.)*\" yytext ;|;
;;Comment
\;.* yytext
;; require provide
\(require "(mzrequire"
\(provide "(mzprovide"
;; Other characters
[^#\"\;\(]+ yytext
;; A #
[#\(] yytext
<<EOF>> 'eof
<<ERROR>> (error 'chicken-preprocessor "parse error ~S (line ~a)"
yytext (lexer-get-line))
......@@ -2,7 +2,7 @@
#
# Author: Erick Gallesio [eg@unice.fr]
# Creation date: 11-Apr-2000 10:30 (eg)
# Last file update: 27-Oct-2006 14:50 (eg)
# Last file update: 14-May-2007 10:21 (eg)
CC = @CC@
CFLAGS = @CFLAGS@ @STKCFLAGS@
......@@ -31,8 +31,8 @@ if NO_THREAD
endif
stklos_SOURCES = base64.c boolean.c boot.c char.c cond.c dynload.c env.c error.c \
extend.c fport.c gnu-getopt.c gnu-glob.c hash.c keyword.c lib.c \
list.c misc.c number.c object.c parameter.c path.c port.c print.c \
extend.c fixnum.c fport.c gnu-getopt.c gnu-glob.c hash.c keyword.c lib.c \
list.c misc.c md5.c number.c object.c parameter.c path.c port.c print.c \
proc.c process.c promise.c read.c regexp.c \
signal.c sio.c socket.c sport.c stklos.c str.c struct.c \
symbol.c system.c uvector.c vector.c vm.c vport.c $(THREAD_FILES)
......
......@@ -18,7 +18,7 @@
#
# Author: Erick Gallesio [eg@unice.fr]
# Creation date: 11-Apr-2000 10:30 (eg)
# Last file update: 27-Oct-2006 14:50 (eg)
# Last file update: 14-May-2007 10:21 (eg)
VPATH = @srcdir@
......@@ -52,8 +52,8 @@ am__installdirs = "$(DESTDIR)$(bindir)" "$(DESTDIR)$(extraincdir)"
binPROGRAMS_INSTALL = $(INSTALL_PROGRAM)
PROGRAMS = $(bin_PROGRAMS)
am__stklos_SOURCES_DIST = base64.c boolean.c boot.c char.c cond.c \
dynload.c env.c error.c extend.c fport.c gnu-getopt.c \
gnu-glob.c hash.c keyword.c lib.c list.c misc.c number.c \
dynload.c env.c error.c extend.c fixnum.c fport.c gnu-getopt.c \
gnu-glob.c hash.c keyword.c lib.c list.c misc.c md5.c number.c \
object.c parameter.c path.c port.c print.c proc.c process.c \
promise.c read.c regexp.c signal.c sio.c socket.c sport.c \
stklos.c str.c struct.c symbol.c system.c uvector.c vector.c \
......@@ -71,17 +71,18 @@ am__stklos_SOURCES_DIST = base64.c boolean.c boot.c char.c cond.c \
@LURC_TRUE@ mutex-lurc.$(OBJEXT)
am_stklos_OBJECTS = base64.$(OBJEXT) boolean.$(OBJEXT) boot.$(OBJEXT) \
char.$(OBJEXT) cond.$(OBJEXT) dynload.$(OBJEXT) env.$(OBJEXT) \
error.$(OBJEXT) extend.$(OBJEXT) fport.$(OBJEXT) \
gnu-getopt.$(OBJEXT) gnu-glob.$(OBJEXT) hash.$(OBJEXT) \
keyword.$(OBJEXT) lib.$(OBJEXT) list.$(OBJEXT) misc.$(OBJEXT) \
number.$(OBJEXT) object.$(OBJEXT) parameter.$(OBJEXT) \
path.$(OBJEXT) port.$(OBJEXT) print.$(OBJEXT) proc.$(OBJEXT) \
process.$(OBJEXT) promise.$(OBJEXT) read.$(OBJEXT) \
regexp.$(OBJEXT) signal.$(OBJEXT) sio.$(OBJEXT) \
socket.$(OBJEXT) sport.$(OBJEXT) stklos.$(OBJEXT) \
str.$(OBJEXT) struct.$(OBJEXT) symbol.$(OBJEXT) \
system.$(OBJEXT) uvector.$(OBJEXT) vector.$(OBJEXT) \
vm.$(OBJEXT) vport.$(OBJEXT) $(am__objects_1)
error.$(OBJEXT) extend.$(OBJEXT) fixnum.$(OBJEXT) \
fport.$(OBJEXT) gnu-getopt.$(OBJEXT) gnu-glob.$(OBJEXT) \
hash.$(OBJEXT) keyword.$(OBJEXT) lib.$(OBJEXT) list.$(OBJEXT) \
misc.$(OBJEXT) md5.$(OBJEXT) number.$(OBJEXT) object.$(OBJEXT) \
parameter.$(OBJEXT) path.$(OBJEXT) port.$(OBJEXT) \
print.$(OBJEXT) proc.$(OBJEXT) process.$(OBJEXT) \
promise.$(OBJEXT) read.$(OBJEXT) regexp.$(OBJEXT) \
signal.$(OBJEXT) sio.$(OBJEXT) socket.$(OBJEXT) \
sport.$(OBJEXT) stklos.$(OBJEXT) str.$(OBJEXT) \
struct.$(OBJEXT) symbol.$(OBJEXT) system.$(OBJEXT) \
uvector.$(OBJEXT) vector.$(OBJEXT) vm.$(OBJEXT) \
vport.$(OBJEXT) $(am__objects_1)
stklos_OBJECTS = $(am_stklos_OBJECTS)
am__DEPENDENCIES_1 =
stklos_DEPENDENCIES = $(am__DEPENDENCIES_1) $(am__DEPENDENCIES_1) \
......@@ -245,8 +246,8 @@ DOCDB = DOCDB
@NO_THREAD_TRUE@THREAD_FILES = thread-none.c mutex-none.c
@PTHREADS_TRUE@THREAD_FILES = thread-common.c thread-pthreads.c mutex-common.c mutex-pthreads.c
stklos_SOURCES = base64.c boolean.c boot.c char.c cond.c dynload.c env.c error.c \
extend.c fport.c gnu-getopt.c gnu-glob.c hash.c keyword.c lib.c \
list.c misc.c number.c object.c parameter.c path.c port.c print.c \
extend.c fixnum.c fport.c gnu-getopt.c gnu-glob.c hash.c keyword.c lib.c \
list.c misc.c md5.c number.c object.c parameter.c path.c port.c print.c \
proc.c process.c promise.c read.c regexp.c \
signal.c sio.c socket.c sport.c stklos.c str.c struct.c \
symbol.c system.c uvector.c vector.c vm.c vport.c $(THREAD_FILES)
......@@ -380,6 +381,7 @@ distclean-compile:
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/env.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/error.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/extend.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/fixnum.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/fport.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gnu-getopt.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gnu-glob.Po@am__quote@
......@@ -387,6 +389,7 @@ distclean-compile:
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/keyword.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/lib.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/list.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/md5.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/misc.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/mutex-common.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/mutex-lurc.Po@am__quote@
......
This diff is collapsed.
This source diff could not be displayed because it is too large. You can view the blob instead.
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 8-Jan-2000 14:48 (eg)
* Last file update: 9-Feb-2007 17:02 (eg)
* Last file update: 11-May-2007 15:50 (eg)
*
* This implementation is built by reverse engineering on an old SUNOS 4.1.1
* stdio.h. It has been simplified to fit the needs for STklos. In particular
......@@ -141,11 +141,13 @@ static void fill_buffer(struct fstream *f)
PORT_STREAM_FLAGS(f) &= ~STK_IOEOF;
/* Read */
do
do {
if (n == -1) perror("fill_buffer");
if (PORT_USERDATA(f))
n = PORT_LOWREAD(f)(f, ptr, PORT_BUFSIZE(f));
else
n = read(PORT_FD(f), ptr, PORT_BUFSIZE(f));
}
while ((n == -1) && (errno == EINTR));
if (n == 0) {
......
/*
* l i b . c -- Scheme library
*
* Copyright © 2000-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
* Copyright © 2000-2007 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
*
*
* This program is free software; you can redistribute it and/or modify
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 5-Jan-2000 12:17 (eg)
* Last file update: 21-Oct-2006 10:59 (eg)
* Last file update: 14-May-2007 10:25 (eg)
*/
......@@ -61,6 +61,7 @@ STk_init_library(int *argc, char ***argv, int stack_size)
STk_init_system() &&
STk_init_mutexes() &&
STk_init_number() &&
STk_init_fixnum() &&
STk_init_hash() &&
STk_init_misc() &&
STk_init_signal() &&
......@@ -70,5 +71,6 @@ STk_init_library(int *argc, char ***argv, int stack_size)
STk_init_socket() &&
STk_init_object() &&
STk_init_base64() &&
STk_init_md5() &&
(STk_library_initialized = TRUE);
}
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@kaolin.unice.fr]
* Creation date: 12-May-1993 10:34
* Last file update: 26-Apr-2007 18:21 (eg)
* Last file update: 9-May-2007 17:15 (eg)
*/
......@@ -1596,14 +1596,6 @@ SCM STk_add2(SCM o1, SCM o2)
return o1;
}
//DEFINE_PRIMITIVE("fx+", fxplus, subr2, (SCM o1, SCM o2))
//{
// if (!INTP(o1)) STk_error("bad fixnum ~S", o1);
// if (!INTP(o2)) STk_error("bad fixnum ~S", o1);
// return MAKE_INT(INT_VAL(o1) + INT_VAL(o2));
//}
DEFINE_PRIMITIVE("+", plus, vsubr, (int argc, SCM *argv))
{
SCM res;
......
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 28-Dec-1999 22:58 (eg)
* Last file update: 11-Apr-2007 16:43 (eg)
* Last file update: 10-May-2007 15:15 (eg)
*/
......@@ -476,6 +476,20 @@ extern struct extended_type_descr *STk_xtypes[];
int STk_new_user_type(struct extended_type_descr *);
int STk_init_extend(void);
/*
------------------------------------------------------------------------------
----
---- F I X N U M . C
----
------------------------------------------------------------------------------
*/
EXTERN_PRIMITIVE("fx+", fxplus, subr2, (SCM o1, SCM o2));
EXTERN_PRIMITIVE("fx-", fxminus, subr2, (SCM o1, SCM o2));
EXTERN_PRIMITIVE("fx*", fxtime, subr2, (SCM o1, SCM o2));
EXTERN_PRIMITIVE("fxdiv", fxdiv, subr2, (SCM o1, SCM o2));
/*
------------------------------------------------------------------------------
----
......@@ -736,7 +750,6 @@ SCM STk_make_C_parameter(SCM symbol, SCM value, SCM (*proc)(SCM new_value));
SCM STk_make_C_parameter2(SCM symbol,SCM (*value)(void),SCM (*proc)(SCM new_value));
/*
------------------------------------------------------------------------------
----
......
......@@ -16,7 +16,7 @@
*
* Author: Erick Gallesio [eg@kaolin.unice.fr]
* Creation date: 29-Mar-1994 10:57
* Last file update: 5-May-2007 11:08 (eg)
* Last file update: 11-May-2007 14:56 (eg)
*/
#include <unistd.h>
......
......@@ -154,8 +154,16 @@
# define DEEP_LOC_REF_FAR 149
# define DEEP_LOC_SET_FAR 150
# define CREATE_CLOSURE_FAR 151
# define IN_FXADD2 152
# define IN_FXSUB2 153
# define IN_FXMUL2 154
# define IN_FXDIV2 155
# define IN_SINT_FXADD2 156
# define IN_SINT_FXSUB2 157
# define IN_SINT_FXMUL2 158
# define IN_SINT_FXDIV2 159
# define NB_VM_INSTR (CREATE_CLOSURE_FAR +1)
# define NB_VM_INSTR (IN_SINT_FXDIV2 +1)
#endif
......@@ -314,6 +322,14 @@ static void *jump_table[] = {
&&lab_DEEP_LOC_REF_FAR ,
&&lab_DEEP_LOC_SET_FAR ,
&&lab_CREATE_CLOSURE_FAR ,
&&lab_IN_FXADD2 ,
&&lab_IN_FXSUB2 ,
&&lab_IN_FXMUL2 ,
&&lab_IN_FXDIV2 ,
&&lab_IN_SINT_FXADD2 ,
&&lab_IN_SINT_FXSUB2 ,
&&lab_IN_SINT_FXMUL2 ,
&&lab_IN_SINT_FXDIV2 ,
NULL};
#endif
#undef DEFINE_JUMP_TABLE
......@@ -474,6 +490,14 @@ static char *name_table[] = {
"DEEP_LOC_REF_FAR ",
"DEEP_LOC_SET_FAR ",
"CREATE_CLOSURE_FAR ",
"IN_FXADD2 ",
"IN_FXSUB2 ",
"IN_FXMUL2 ",
"IN_FXDIV2 ",
"IN_SINT_FXADD2 ",
"IN_SINT_FXSUB2 ",
"IN_SINT_FXMUL2 ",
"IN_SINT_FXDIV2 ",
NULL};
#endif
#undef DEFINE_NAME_TABLE
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 1-Mar-2000 19:51 (eg)
* Last file update: 13-Apr-2007 12:25 (eg)
* Last file update: 10-May-2007 15:51 (eg)
*/
// INLINER values
......@@ -1376,6 +1376,16 @@ CASE(IN_MUL2) { REG_CALL_PRIM(multiplication);
CASE(IN_DIV2) { REG_CALL_PRIM(division);
vm->val = STk_div2(pop(), vm->val); NEXT1;}
CASE(IN_FXADD2) { REG_CALL_PRIM(fxplus);
vm->val = STk_fxplus(pop(), vm->val); NEXT1;}
CASE(IN_FXSUB2) { REG_CALL_PRIM(fxminus);
vm->val = STk_fxminus(pop(), vm->val); NEXT1;}
CASE(IN_FXMUL2) { REG_CALL_PRIM(fxtime);
vm->val = STk_fxtime(pop(), vm->val); NEXT1;}
CASE(IN_FXDIV2) { REG_CALL_PRIM(fxdiv);
vm->val = STk_fxdiv(pop(), vm->val); NEXT1;}
CASE(IN_SINT_ADD2) { REG_CALL_PRIM(plus);
vm->val = STk_add2(vm->val, MAKE_INT(fetch_next())); NEXT1;}
CASE(IN_SINT_SUB2) { REG_CALL_PRIM(difference);
......@@ -1386,6 +1396,16 @@ CASE(IN_SINT_DIV2) { REG_CALL_PRIM(division);
vm->val = STk_div2(vm->val, MAKE_INT(fetch_next())); NEXT1;}
CASE(IN_SINT_FXADD2) { REG_CALL_PRIM(fxplus);
vm->val = STk_fxplus(vm->val, MAKE_INT(fetch_next())); NEXT1;}
CASE(IN_SINT_FXSUB2) { REG_CALL_PRIM(fxminus);
vm->val = STk_fxminus(MAKE_INT(fetch_next()), vm->val<