wisp-cvs Mailing List for Wisp interpreter (Page 24)
Status: Alpha
Brought to you by:
digg
Menu
▾
▴
wisp-cvs — Automatic announcements of commits to the CVS repository
You can subscribe to this list here.
| 2002 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
(30) |
Sep
(312) |
Oct
|
Nov
|
Dec
|
|---|---|---|---|---|---|---|---|---|---|---|---|---|
| 2003 |
Jan
(5) |
Feb
(131) |
Mar
(17) |
Apr
(184) |
May
(252) |
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
| 2004 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
(2) |
Nov
|
Dec
|
|
From: <di...@us...> - 2003-02-05 19:51:19
|
Update of /cvsroot/wisp/wisp/users/dig
In directory sc8-pr-cvs1:/tmp/cvs-serv12532/users/dig
Added Files:
struburn.wisp
Log Message:
imported struburn.wisp
--- NEW FILE: struburn.wisp ---
#! /usr/bin/wisp
;;;; struburn.wisp - an utility to burn CDs with the directory
;; structure intact
;;
;; Copyleft © 2002 by Andres Soolo (di...@us...)
;; This file is licensed under the GNU GPL v2. If you
;; don't know what that means, please do read the GPL.
;;
;;;; @(#) $Id: struburn.wisp,v 1.1 2003/02/05 19:51:15 digg Exp $
(use
files getopt lists phases qsort syscalls unix)
(define farm (construct-filename (or (env-ref "TMPDIR") "/tmp")
"farm.$(sys:getpid)"))
(define (uniq =? l)
(if (null? l)
'()
(collect
(lambda (emit)
(my previous (car l)
(emit previous)
(for-each (lambda (i)
(if (not (=? previous i))
(begin
(emit i)
(set! previous i))))
(cdr l)))))))
(my (objects size-only? md5? volid dummy? speed output microsoft? help?)
(getopt '((option ("size" #\s) flag size-only?)
(option ("md5" #\m) flag md5?)
(option ("volid" #\V) value volid)
(option ("dummy" #\d) flag dummy?)
(option ("speed" #\x) value speed)
(option ("output" #\o) value output)
(option ("microsoft" #\J) flag microsoft?)
(option ("help" #\h) flag help?)
(arg objects rest)
(default speed "4")
(return objects size-only? md5? volid dummy?
speed output microsoft? help?))
*arglist*)
(if (or (null? objects) help?)
(begin
(print "usage: struburn [options] object object ...\n\n\
Options recognized:\n\
\ -s, --size just calculate image size\n\
\ -m, --md5 create the MD5SUMS file\n\
\ -V, --volid=text specifies the volume ID to be used\n\
\ -d, --dummy write in dummy mode\n\
\ -x, --speed=N specifies the writing speed (default 4)\n\
\ -o, --output=file just create a CD image, don't burn it\n\
\ -J, --microsoft create a Microsoft-friendly CD\n\
\ --help show this help message\n\n")
(exit)))
(set! speed (or (string->integer speed) speed))
(type integer speed)
(let ((dirs '())
(links '()))
(sys:mkdir farm #o0700)
(for-each (lambda (o)
(while (string=? o[... 2] "./")
(set! o o[2 ...]))
(cond
((string-null? o) (raise 'invalid-filename o))
((absolute-path? o) (raise 'absolute-filename o)))
(let ((name (basename o))
(dir (dirname o)))
(cons! links (construct-filename dir name))
(let (loop (dir dir))
(while (string=? dir[-2 ...] "/.")
(set! dir dir[... -2]))
(if (not (string=? dir "."))
(begin
(cons! dirs dir)
(loop (dirname dir)))))))
objects)
(set! links (qsort! string<? links))
(set! dirs (uniq string=? (qsort! string<? dirs)))
; sanity check
(my int (lset-intersection string=? links dirs)
(if (not (null? int))
(raise 'conflict int)))
; create the dirs
(for-each (lambda (d)
(sys:mkdir (construct-filename farm d) #o700))
dirs)
; create the symlinks
(my curdir (cwd)
(for-each (lambda (link)
(sys:symlink (construct-filename curdir link)
(construct-filename farm link)))
links))
(if md5?
(my files (collect
(lambda (emit)
(let (loop (dir ".") (follow? #t))
(for-dir-entries
(lambda (name inode)
(if (not (member name '("." "..") string=?))
(my qn (construct-filename dir name)
(case (file-type (construct-filename
farm qn) #f)
((regular) (emit qn))
((directory) (loop qn follow?))
((symlink)
(if follow?
(case (file-type (construct-filename
farm qn) #t)
((regular) (emit qn))
((directory) (loop qn #f)))))))))
(construct-filename farm dir)))))
(set! files (qsort string<? files))
(my-port MD5SUMS (open-output-file (construct-filename
farm "MD5SUMS")
'exclusive 'follow-not #o600)
(if (or size-only? dummy?) ; checksumming is expensive
(for-each
(lambda (filename)
(print MD5SUMS "$,(make-string 32 #\0) $,[filename]\n"))
files)
(phase "Calculating MD5 checksums"
(my-port pipe (pipe-from `("/usr/bin/md5sum" "--" ,@files))
(byte-copy-port pipe MD5SUMS)))))))
(my cmdline `("/usr/bin/mkisofs" "-r" ,@(if microsoft?
'("-J")
'("-U" "-D"))
"-F" ,farm
"-quiet"
,@(if volid
`("-V" ,volid)
'()))
(my tsize (my-port p (pipe-from `(,@cmdline "-print-size" ,farm))
(read p))
(print "Space to be occupied: $(ceiling (/ tsize 512))MiB\n")
(if (not size-only?)
(if output
(call-process `(,@cmdline "-o" ,output ,farm))
(call-process
(pipeline `(,@cmdline ,farm)
`("/usr/bin/cdrecord" "dev=0,0,0"
,"speed=$[speed]" "-v"
,@(if dummy? '("-dummy") '())
,"tsize=$[tsize]s" "-")))))
(call-process `("/bin/rm" "-rf" ,farm))))))
; vim: ft=wisp
|
|
From: <di...@us...> - 2003-02-05 19:41:45
|
Update of /cvsroot/wisp/wisp/users/dig In directory sc8-pr-cvs1:/tmp/cvs-serv7049/dig Log Message: Directory /cvsroot/wisp/wisp/users/dig added to the repository |
|
From: <di...@us...> - 2003-02-05 19:18:52
|
Update of /cvsroot/wisp/wisp
In directory sc8-pr-cvs1:/tmp/cvs-serv28827
Modified Files:
wisplint.wisp
Log Message:
tweaked Id: tags of README:s
Index: wisplint.wisp
===================================================================
RCS file: /cvsroot/wisp/wisp/wisplint.wisp,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -d -r1.22 -r1.23
--- wisplint.wisp 1 Feb 2003 14:02:47 -0000 1.22
+++ wisplint.wisp 5 Feb 2003 19:18:48 -0000 1.23
@@ -97,7 +97,6 @@
(not (member name '("COPYING"
"DISCLAIMER"
"INSTALL"
- "README"
"config.guess"
"config.sub"
"debian/changelog"
@@ -117,11 +116,11 @@
"tests/cut-check.wisp"
"tests/srfi-1.wisp"
"tests/srfi-26.wisp"
- "wa/README.wa"
"web/gray.cgi"
"web/index.html"
"web/names.cgi")
- string=?)))
+ string=?))
+ (not (string-contains name "README")))
(begin
(run check-for-gpl-notice name)
(run check-for-long-mail-address name)))
@@ -140,7 +139,6 @@
(not (member name '("COPYING"
"DISCLAIMER"
"INSTALL"
- "README"
"config.guess"
"config.sub"
"debian/changelog"
@@ -155,15 +153,13 @@
"src/native/sysconst.inc"
"src/stamp-h.in"
"src/sysconst.h"
- "tests/cut-check.wisp"
- "wa/README.wa")
+ "tests/cut-check.wisp")
string=?)))
(run check-for-id name))
(if (and (not (equal? (filename-suffix name) ".s"))
(not (member name '("COPYING"
"DISCLAIMER"
"INSTALL"
- "README"
"debian/changelog"
"debian/control"
"doc/TODO"
@@ -174,11 +170,11 @@
"src/native/sysconst.inc"
"src/stamp-h.in"
"src/sysconst.h"
- "wa/README.wa"
"web/gray.cgi"
"web/index.html"
"web/names.cgi")
- string=?)))
+ string=?))
+ (not (string-contains name "README")))
(run check-for-filename name))))))
(collect
(lambda (emit)
|
|
From: <di...@us...> - 2003-02-05 19:18:52
|
Update of /cvsroot/wisp/wisp/users In directory sc8-pr-cvs1:/tmp/cvs-serv28827/users Modified Files: README.users Log Message: tweaked Id: tags of README:s Index: README.users =================================================================== RCS file: /cvsroot/wisp/wisp/users/README.users,v retrieving revision 1.1 retrieving revision 1.2 diff -u -d -r1.1 -r1.2 --- README.users 5 Feb 2003 11:50:50 -0000 1.1 +++ README.users 5 Feb 2003 19:18:49 -0000 1.2 @@ -1,5 +1,5 @@ -README.users -============ +Raw User Contributions +====================== This directory is for quite raw things, typically wild ideas by the developers. Many of them will probably get dropped in time. Some @@ -8,3 +8,5 @@ wisplint.wisp is going to check this directory; no general exemption is planned. If you need a specific exemption, modify wisplint.wisp as needed. + +@(#) $Id$ |
|
From: <di...@us...> - 2003-02-05 14:17:16
|
Update of /cvsroot/wisp/wisp/wa In directory sc8-pr-cvs1:/tmp/cvs-serv18857 Modified Files: README.wa Log Message: added the Id: tag to wa/README.wa Index: README.wa =================================================================== RCS file: /cvsroot/wisp/wisp/wa/README.wa,v retrieving revision 1.1 retrieving revision 1.2 diff -u -d -r1.1 -r1.2 --- README.wa 8 Aug 2002 17:20:00 -0000 1.1 +++ README.wa 5 Feb 2003 14:17:13 -0000 1.2 @@ -5,3 +5,6 @@ or Worth, but are not needed for Wisp and are a bit more useful than the sample programs. Most will likely end up as separate projects once Wisp has matured enough. + +@(#) $Id$ + |
|
From: <di...@us...> - 2003-02-05 14:15:44
|
Update of /cvsroot/wisp/wisp In directory sc8-pr-cvs1:/tmp/cvs-serv18228 Modified Files: README Log Message: added SCCS magic sequence to the main README Index: README =================================================================== RCS file: /cvsroot/wisp/wisp/README,v retrieving revision 1.41 retrieving revision 1.42 diff -u -d -r1.41 -r1.42 --- README 5 Feb 2003 12:14:26 -0000 1.41 +++ README 5 Feb 2003 14:15:40 -0000 1.42 @@ -1,5 +1,5 @@ This is the main README file for the Wisp interpreter. -$Id$ +@(#) $Id$ THE BACKGROUND |
|
From: <di...@us...> - 2003-02-05 12:14:29
|
Update of /cvsroot/wisp/wisp In directory sc8-pr-cvs1:/tmp/cvs-serv2416 Modified Files: README Log Message: added the Id: tag to main README Index: README =================================================================== RCS file: /cvsroot/wisp/wisp/README,v retrieving revision 1.40 retrieving revision 1.41 diff -u -d -r1.40 -r1.41 --- README 30 Jul 2002 21:34:47 -0000 1.40 +++ README 5 Feb 2003 12:14:26 -0000 1.41 @@ -1,5 +1,5 @@ -This is the README file for the Wisp interpreter. - +This is the main README file for the Wisp interpreter. +$Id$ THE BACKGROUND |
|
From: <di...@us...> - 2003-02-05 11:50:53
|
Update of /cvsroot/wisp/wisp/users In directory sc8-pr-cvs1:/tmp/cvs-serv26785 Added Files: README.users Log Message: introduced the users directory --- NEW FILE: README.users --- README.users ============ This directory is for quite raw things, typically wild ideas by the developers. Many of them will probably get dropped in time. Some should end up in either the wa, src or modules directories. wisplint.wisp is going to check this directory; no general exemption is planned. If you need a specific exemption, modify wisplint.wisp as needed. |
|
From: <di...@us...> - 2003-02-01 14:24:49
|
Update of /cvsroot/wisp/wisp/src
In directory sc8-pr-cvs1:/tmp/cvs-serv13594/src
Modified Files:
mem.h wordreg.h.nepl
Log Message:
GCC 3.2 compatibility fixes
Index: mem.h
===================================================================
RCS file: /cvsroot/wisp/wisp/src/mem.h,v
retrieving revision 1.38
retrieving revision 1.39
diff -u -d -r1.38 -r1.39
--- mem.h 4 Sep 2002 14:31:41 -0000 1.38
+++ mem.h 1 Feb 2003 14:24:45 -0000 1.39
@@ -1,7 +1,7 @@
/*
* mem.h - declare the Wisp memory management routines
*
- * Copyleft © 2002 by Andres Soolo (di...@us...)
+ * Copyleft © 2003 by Andres Soolo (di...@us...)
* This file is licensed under the GNU GPL v2. If you
* don't know what that means, please do read the GPL.
*
@@ -11,6 +11,8 @@
#ifndef _MEM_H
#define _MEM_H
+
+#include <string.h>
#include <config.h>
Index: wordreg.h.nepl
===================================================================
RCS file: /cvsroot/wisp/wisp/src/wordreg.h.nepl,v
retrieving revision 1.30
retrieving revision 1.31
diff -u -d -r1.30 -r1.31
--- wordreg.h.nepl 4 Sep 2002 14:31:41 -0000 1.30
+++ wordreg.h.nepl 1 Feb 2003 14:24:45 -0000 1.31
@@ -6,7 +6,7 @@
/*
* wordreg.h - the C header file for word registration.
*
- * Copyleft © 2000 by Andres Soolo (di...@us...)
+ * Copyleft © 2003 by Andres Soolo (di...@us...)
* This file is licensed under the GNU GPL v2. If you
* don't know what that means, please do read the GPL.
*
@@ -82,9 +82,10 @@
#define wordreg_add_node(symbol,word,wordspace,wordhashed) \
{ \
- static struct wrhashnode p = {data: (struct wordreg_node *) \
- &(struct {struct node *sym; char s[wordspace];}) \
- {symbol, word}, val: (unsigned long int) wordhashed}; \
+ static struct {struct node *sym; char s[wordspace];} d = \
+ {symbol, word}; \
+ static struct wrhashnode p = {data: (struct wordreg_node *) &d, \
+ val: (unsigned long int) wordhashed}; \
size_t i = ((unsigned long int) wordhashed) % WRHASHTAB_SIZE; \
p.next = wordreg->tab [i]; \
wordreg->tab [i] = &p; \
@@ -95,3 +96,4 @@
#endif /* _WORDREG_H */
#perl
+# vim: ft=c
|
|
From: <di...@us...> - 2003-02-01 14:02:50
|
Update of /cvsroot/wisp/wisp
In directory sc8-pr-cvs1:/tmp/cvs-serv29017
Modified Files:
Makefile.am configure.in wisplint.wisp
Removed Files:
acconfig.h
Log Message:
autoconf 2.57 compatibility fixes
Index: Makefile.am
===================================================================
RCS file: /cvsroot/wisp/wisp/Makefile.am,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -d -r1.26 -r1.27
--- Makefile.am 28 Aug 2002 20:05:13 -0000 1.26
+++ Makefile.am 1 Feb 2003 14:02:45 -0000 1.27
@@ -1,12 +1,12 @@
#### Makefile.am for the Wisp interpreter
#
-# Copyleft © 2002 by Andres Soolo (di...@us...)
+# Copyleft © 2003 by Andres Soolo (di...@us...)
# This file is licensed under the GNU GPL v2. If you
# don't know what that means, please do read the GPL.
#
#### @(#) $Id$
-EXTRA_DIST = DISCLAIMER COPYING acconfig.h .cvsignore wisplint.wisp
+EXTRA_DIST = DISCLAIMER COPYING .cvsignore wisplint.wisp
SUBDIRS = src doc modules tests tools debian wa web
distcheck: wisplint
Index: configure.in
===================================================================
RCS file: /cvsroot/wisp/wisp/configure.in,v
retrieving revision 1.73
retrieving revision 1.74
diff -u -d -r1.73 -r1.74
--- configure.in 1 Feb 2003 13:12:16 -0000 1.73
+++ configure.in 1 Feb 2003 14:02:46 -0000 1.74
@@ -25,15 +25,17 @@
AC_SUBST(CPUTYPE)
dnl Name and version of the package.
-AC_DEFINE_UNQUOTED(PACKAGE, "$PACKAGE")
-AC_DEFINE_UNQUOTED(VERSION, "$VERSION")
-AC_DEFINE_UNQUOTED(NOW, "`date -u +'%Y-%m-%d %T'`")
+AC_DEFINE_UNQUOTED(PACKAGE, "$PACKAGE", [The name of the package.])
+AC_DEFINE_UNQUOTED(VERSION, "$VERSION", [The version of the package.])
+AC_DEFINE_UNQUOTED(NOW, "`date -u +'%Y-%m-%d %T'`",
+ [Date and time of the build.])
case $host in
*bsd*) HOSTNAME="`hostname`" ;;
*linux*) HOSTNAME="`hostname -f`" ;;
*) HOSTNAME="`hostname`" ;; # it works if we're lucky
esac
-AC_DEFINE_UNQUOTED(BUILDER, "`whoami`@$HOSTNAME")
+AC_DEFINE_UNQUOTED(BUILDER, "`whoami`@$HOSTNAME",
+ [Who and where built the package.])
dnl Set the value of CFLAGS.
CFLAGS="$CFLAGS -g -Wall"
@@ -119,13 +121,36 @@
AC_HEADER_STDC
AC_CHECK_HEADERS(fcntl.h limits.h unistd.h)
AC_CHECK_HEADERS(stdint.h inttypes.h)
-AC_CHECK_HEADER(gc.h, [AC_DEFINE_UNQUOTED(GC_H, <gc.h>)],
- AC_CHECK_HEADER(gc/gc.h, [AC_DEFINE_UNQUOTED(GC_H, <gc/gc.h>)],
- AC_MSG_ERROR(gmp.h not found)))
-AC_CHECK_HEADER(gmp.h, [AC_DEFINE_UNQUOTED(GMP_H, <gmp.h>)],
- AC_CHECK_HEADER(gmp2/gmp.h, [AC_DEFINE_UNQUOTED(GMP_H, <gmp2/gmp.h>)],
- AC_CHECK_HEADER(gmp3/gmp.h, [AC_DEFINE_UNQUOTED(GMP_H, <gmp3/gmp.h>)],
- AC_MSG_ERROR(gmp.h not found))))
+
+AC_CHECK_HEADERS(gc.h gc/gc.h)
+if test $ac_cv_header_gc_h = yes; then
+ gc_h="<gc.h>"
+else
+ if test $ac_cv_header_gc_gc_h = yes; then
+ gc_h="<gc/gc.h>"
+ else
+ AC_MSG_ERROR([gc.h not found])
+ fi
+fi
+AC_MSG_NOTICE([will use $gc_h])
+AC_DEFINE_UNQUOTED(GC_H, $gc_h, [Where gc.h happens to be.])
+
+AC_CHECK_HEADERS(gmp.h gmp3/gmp.h gmp2/gmp.h)
+if test $ac_cv_header_gmp_h = yes; then
+ gmp_h="<gmp.h>"
+else
+ if test $ac_cv_header_gmp3_gmp_h = yes; then
+ gmp_h="<gmp3/gmp.h>"
+ else
+ if test $ac_cv_header_gmp2_gmp_h = yes; then
+ gmp_h="<gmp2/gmp.h>"
+ else
+ AC_MSG_ERROR([gmp.h not found])
+ fi
+ fi
+fi
+AC_MSG_NOTICE([will use $gmp_h])
+AC_DEFINE_UNQUOTED(GMP_H, $gmp_h, [Where gmp.h happens to be.])
dnl Checks for typedefs, structures, and compiler characteristics.
AC_C_CONST
Index: wisplint.wisp
===================================================================
RCS file: /cvsroot/wisp/wisp/wisplint.wisp,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -d -r1.21 -r1.22
--- wisplint.wisp 7 Jan 2003 13:44:27 -0000 1.21
+++ wisplint.wisp 1 Feb 2003 14:02:47 -0000 1.22
@@ -2,7 +2,7 @@
;;;; wisplint.wisp - look for lint in the source of Wisp
;;
-;; Copyleft © 2002 by Andres Soolo (di...@us...)
+;; Copyleft © 2003 by Andres Soolo (di...@us...)
;; This file is licensed under the GNU GPL v2. If you
;; don't know what that means, please do read the GPL.
;;
@@ -98,7 +98,6 @@
"DISCLAIMER"
"INSTALL"
"README"
- "acconfig.h"
"config.guess"
"config.sub"
"debian/changelog"
@@ -142,7 +141,6 @@
"DISCLAIMER"
"INSTALL"
"README"
- "acconfig.h"
"config.guess"
"config.sub"
"debian/changelog"
@@ -166,7 +164,6 @@
"DISCLAIMER"
"INSTALL"
"README"
- "acconfig.h"
"debian/changelog"
"debian/control"
"doc/TODO"
--- acconfig.h DELETED ---
|
|
From: <di...@us...> - 2003-02-01 13:12:19
|
Update of /cvsroot/wisp/wisp
In directory sc8-pr-cvs1:/tmp/cvs-serv28685
Modified Files:
configure.in
Log Message:
improved ordering of AC_CANONICAL_* in configure.in
Index: configure.in
===================================================================
RCS file: /cvsroot/wisp/wisp/configure.in,v
retrieving revision 1.72
retrieving revision 1.73
diff -u -d -r1.72 -r1.73
--- configure.in 18 Sep 2002 21:13:27 -0000 1.72
+++ configure.in 1 Feb 2003 13:12:16 -0000 1.73
@@ -1,20 +1,18 @@
dnl configure.in - autoconf source for the Wisp software suite
dnl
-dnl Copyleft © 2002 by Andres Soolo (di...@us...)
+dnl Copyleft © 2002 by Andres Soolo (di...@us...)
dnl This file is licensed under the GNU GPL v2. If you
dnl don't know what that means, please do read the GPL.
dnl
dnl @(#) $Id$
AC_INIT(src/wisp.c.nepl)
+AC_CANONICAL_HOST
+AC_CANONICAL_TARGET
AM_INIT_AUTOMAKE(wisp, 0.9.9)
-
-dnl Specify configure header file.
AM_CONFIG_HEADER(src/config.h)
dnl Determine the system type.
-AC_CANONICAL_HOST
-AC_CANONICAL_TARGET
case $target in
*-*-linux*) SYSTYPE="LINUX" ;;
*) SYSTYPE="UNKNOWNIX" ;;
@@ -55,7 +53,7 @@
if test "$PERL" = no; then
AC_MSG_ERROR(perl not found)
fi
-test "$NASM" = /usr/bin/nasm && NASM=nasm # æsthetics
+test "$NASM" = /usr/bin/nasm && NASM=nasm # æsthetics
test "$PERL" = /usr/bin/perl && PERL=perl
dnl The dot-usr thingie.
|
|
From: <di...@us...> - 2003-01-07 15:46:47
|
Update of /cvsroot/wisp/wisp In directory sc8-pr-cvs1:/tmp/cvs-serv23606 Modified Files: .cvsignore Log Message: ignore the autom4te.cache directory Index: .cvsignore =================================================================== RCS file: /cvsroot/wisp/wisp/.cvsignore,v retrieving revision 1.11 retrieving revision 1.12 diff -u -d -r1.11 -r1.12 --- .cvsignore 28 Aug 2002 20:05:13 -0000 1.11 +++ .cvsignore 7 Jan 2003 15:46:41 -0000 1.12 @@ -2,6 +2,7 @@ Makefile Makefile.in aclocal.m4 +autom4te.cache build config.cache config.log |
|
From: <di...@us...> - 2003-01-07 13:44:32
|
Update of /cvsroot/wisp/wisp/doc/examples
In directory sc8-pr-cvs1:/tmp/cvs-serv6414/doc/examples
Modified Files:
Makefile.am
Added Files:
whello.wth
Removed Files:
hello.wth
Log Message:
renamed hello.wth to whello.wth
--- NEW FILE: whello.wth ---
;;;; whello.wth - display a familiar greeting
;;
;; Copyleft © 2002 by Andres Soolo (di...@us...)
;; This file is licensed under the GNU GPL v2. If you
;; don't know what that means, please do read the GPL.
;;
;;;; @(#) $Id: whello.wth,v 1.1 2003/01/07 13:44:27 digg Exp $
; Note that this code is not exactly related to hello.was
(include io)
(include linux)
(defun _start
1 "Hello, world!\n" type 0 sys.exit)
; Note that the string literal pushes *two* elements to the stack,
; the first being a pointer to the string and the second being its
; length. |type| takes two elements as well: a string pointer and
; amount of characters to write.
; vim:ft=worth
Index: Makefile.am
===================================================================
RCS file: /cvsroot/wisp/wisp/doc/examples/Makefile.am,v
retrieving revision 1.39
retrieving revision 1.40
diff -u -d -r1.39 -r1.40
--- Makefile.am 30 Sep 2002 18:24:55 -0000 1.39
+++ Makefile.am 7 Jan 2003 13:44:27 -0000 1.40
@@ -7,7 +7,7 @@
#### @(#) $Id$
WORTH_EXAMPLES = angry.wth argenv.wth banana.wth bufinput.wth \
- false.wth hello.wth
+ false.wth whello.wth
EXTRA_DIST = closure.wisp quine.wisp signal.wisp \
rawkey.wisp \
--- hello.wth DELETED ---
|
|
From: <di...@us...> - 2003-01-07 13:44:32
|
Update of /cvsroot/wisp/wisp
In directory sc8-pr-cvs1:/tmp/cvs-serv6414
Modified Files:
wisplint.wisp
Log Message:
renamed hello.wth to whello.wth
Index: wisplint.wisp
===================================================================
RCS file: /cvsroot/wisp/wisp/wisplint.wisp,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -d -r1.20 -r1.21
--- wisplint.wisp 7 Jan 2003 10:13:28 -0000 1.20
+++ wisplint.wisp 7 Jan 2003 13:44:27 -0000 1.21
@@ -106,7 +106,6 @@
"doc/TODO"
"doc/depends.txt"
"doc/examples/embed.ewisp"
- "doc/examples/hello.was"
"doc/examples/quine.wisp"
"doc/paw.txt"
"doc/wisp.texi"
@@ -151,7 +150,6 @@
"doc/TODO"
"doc/depends.txt"
"doc/examples/embed.ewisp"
- "doc/examples/hello.was"
"doc/examples/quine.wisp"
"doc/wisp.texi"
"install-sh"
@@ -173,7 +171,6 @@
"debian/control"
"doc/TODO"
"doc/depends.txt"
- "doc/examples/hello.was"
"doc/examples/quine.wisp"
"doc/paw.txt"
"doc/wisp.texi"
|
|
From: <di...@us...> - 2003-01-07 12:02:56
|
Update of /cvsroot/wisp/wisp/tools In directory sc8-pr-cvs1:/tmp/cvs-serv2729/tools Modified Files: Makefile.am Log Message: Fix shebang lines of installed scripts to match --with-prefix. Index: Makefile.am =================================================================== RCS file: /cvsroot/wisp/wisp/tools/Makefile.am,v retrieving revision 1.14 retrieving revision 1.15 diff -u -d -r1.14 -r1.15 --- Makefile.am 11 Sep 2002 17:35:32 -0000 1.14 +++ Makefile.am 7 Jan 2003 12:02:47 -0000 1.15 @@ -17,3 +17,11 @@ $(PERL) $< > $@ .PHONY: pretty.ssh + +# The DESTDIR feature doesn't seem to be completed in automake 1.4-p4. +install: install-am + @for f in $(bin_SCRIPTS); do \ + echo ed $(DESTDIR)$(bindir)/$$f ; \ + ( echo '1s,#! *[^ ]*/,#! $(bindir)/,'; \ + echo 'wq' ) | ed $(DESTDIR)$(bindir)/$$f ; \ + done |
|
From: <di...@us...> - 2003-01-07 10:13:31
|
Update of /cvsroot/wisp/wisp
In directory sc8-pr-cvs1:/tmp/cvs-serv31292
Modified Files:
wisplint.wisp
Log Message:
ignore *~ and doc/examples/hello.was .
Index: wisplint.wisp
===================================================================
RCS file: /cvsroot/wisp/wisp/wisplint.wisp,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -d -r1.19 -r1.20
--- wisplint.wisp 7 Sep 2002 21:52:26 -0000 1.19
+++ wisplint.wisp 7 Jan 2003 10:13:28 -0000 1.20
@@ -88,7 +88,8 @@
(for-each
(lambda (name)
- (if (not (or (member name '("src/essence.c") string=?)))
+ (if (not (or (char=? (ref name -1) #\~)
+ (member name '("src/essence.c") string=?)))
(begin
(print "Scanning $,[name] \e[80P\r") ; not a smiley
(my suffix (filename-suffix name)
@@ -105,6 +106,7 @@
"doc/TODO"
"doc/depends.txt"
"doc/examples/embed.ewisp"
+ "doc/examples/hello.was"
"doc/examples/quine.wisp"
"doc/paw.txt"
"doc/wisp.texi"
@@ -149,6 +151,7 @@
"doc/TODO"
"doc/depends.txt"
"doc/examples/embed.ewisp"
+ "doc/examples/hello.was"
"doc/examples/quine.wisp"
"doc/wisp.texi"
"install-sh"
@@ -170,6 +173,7 @@
"debian/control"
"doc/TODO"
"doc/depends.txt"
+ "doc/examples/hello.was"
"doc/examples/quine.wisp"
"doc/paw.txt"
"doc/wisp.texi"
|
|
From: <di...@us...> - 2002-09-30 18:24:58
|
Update of /cvsroot/wisp/wisp/wa In directory usw-pr-cvs1:/tmp/cvs-serv25684/wa Modified Files: cupid.wth Log Message: Created the beginnings of Worth-level assemblying. Index: cupid.wth =================================================================== RCS file: /cvsroot/wisp/wisp/wa/cupid.wth,v retrieving revision 1.2 retrieving revision 1.3 diff -u -d -r1.2 -r1.3 --- cupid.wth 8 Sep 2002 11:27:24 -0000 1.2 +++ cupid.wth 30 Sep 2002 18:24:56 -0000 1.3 @@ -9,6 +9,8 @@ (include io) (include linux) +(macro .cpuid. #o017 byte# #o242 byte#) + (macro cpu_vendor ,(cpu 586) (register %ecx) @@ -16,7 +18,7 @@ (register %ebx) (register %eax) ,(xor %eax %eax) - ,(cpuid) + .cpuid. drop) (macro cpuid_level @@ -26,7 +28,7 @@ (register %ebx) (register %eax) ,(xor %eax %eax) - ,(cpuid) + .cpuid. nip nip nip) (macro cpu_version @@ -34,7 +36,7 @@ (register %eax) (register %edx) ,(mov %eax 1) - ,(cpuid) + .cpuid. drop) (macro cpu_features @@ -42,7 +44,7 @@ (register %eax) (register %edx) ,(mov %eax 1) - ,(cpuid) + .cpuid. nip) (defun _start |
|
From: <di...@us...> - 2002-09-30 18:24:58
|
Update of /cvsroot/wisp/wisp/tools
In directory usw-pr-cvs1:/tmp/cvs-serv25684/tools
Modified Files:
worth
Log Message:
Created the beginnings of Worth-level assemblying.
Index: worth
===================================================================
RCS file: /cvsroot/wisp/wisp/tools/worth,v
retrieving revision 1.35
retrieving revision 1.36
diff -u -d -r1.35 -r1.36
--- worth 30 Sep 2002 18:24:37 -0000 1.35
+++ worth 30 Sep 2002 18:24:56 -0000 1.36
@@ -15,8 +15,10 @@
unix)
(define builtin-words
- '(->synstack < <-synstack <= <> = > >= ?jump annihilate gen-label
- stack=! stick-label u< u<= u> u>=))
+ '(->synstack < <-synstack <= <> = > >= ?jump annihilate byte#
+ decode-register gen-label is? literal-integer? register?
+ regstack-depth stack=! stick-label synstack tetra# u< u<= u> u>=
+ wyde#))
(define (other op c)
(cond
@@ -83,8 +85,6 @@
(define (word-class word)
(cond
((cpu-register? word) 'register)
- ((and (>= (symbol-length word) 3)
- (broketed? word)) 'broketed)
((memq word known-procedure-box[]) 'procedure)
((assq word macro-box[]) 'macro)
((memq word builtin-words) 'builtin)
@@ -117,7 +117,7 @@
(modulo i #x100000000))
(define (reduce-to-stetra i)
- (set! i (reduce-to-utetra))
+ (set! i (reduce-to-utetra i))
(if (>= i #x80000000)
(decr! i #x100000000))
i)
@@ -200,6 +200,14 @@
(list 'tetra datum))
(else (signal 'cell? datum)))) body))
+(define register-data
+ '((%eax 0 0) (%ecx 0 1) (%edx 0 2) (%ebx 0 3)
+ (%esp 0 4) (%ebp 0 5) (%esi 0 6) (%edi 0 7)
+ (%ax 1 0) (%cx 1 1) (%dx 1 2) (%bx 1 3)
+ (%sp 1 4) (%bp 1 5) (%si 1 6) (%si 1 7)
+ (%al 2 0) (%cl 2 1) (%dl 2 2) (%bl 2 3)
+ (%ah 2 4) (%ch 2 5) (%dh 2 6) (%bh 2 7)))
+
(define (worth->ia32 name body)
(if (word-class name)
(raise 'duplicate-word name))
@@ -207,8 +215,7 @@
(let ((gen-label (my c (make-counter)
(lambda (prefix)
(string->symbol "$,[prefix].L$(c)"))))
- (rcode '())
- (reminder '()))
+ (rcode '()))
(my emit (my skip? #f
(lambda (x) ; the postprocessor
(cond
@@ -222,7 +229,8 @@
(let ((regstack '()) ; FIXME: regstack should be a deque
(synstack '())
(regref# (map (cut cons <> 0)
- '(%eax %ebx %ecx %edx %esi %edi))))
+ '(%eax %ebx %ecx %edx %esi %edi)))
+ (mode #f))
(letrec (((process-word-list word-list (suppress? #f))
(for-each (cut process-word <> suppress?)
word-list))
@@ -398,11 +406,6 @@
((->non-expression i)
(if (cons? (list-ref regstack i))
(->register i)))
- ((copy i)
- (stack>=! (+ i 1))
- (my object (list-ref regstack i)
- (use++ object)
- (cons! regstack object)))
((delete i)
(stack>=! (+ i 1))
(use-- (list-ref regstack i))
@@ -438,218 +441,104 @@
(delete 0)
(delete 0)
(delete 0)))))
+ ((get-dollar-list)
+ (and (memq '$ synstack) -> sep
+ (my dl synstack
+ (set! synstack (cdr sep))
+ (set! (cdr sep) '())
+ (drop-right dl 1))))
((process-word word suppress?)
(if (and (not suppress?)
skip-assembly?[] => (cut >= <> 2))
(emit (list '() 'word word)))
- (case word
- (integer? (cons! regstack word))
- (char? (cons! regstack (char->integer word)))
- (string? (my name (genname)
- (add-string name word)
- (cons! regstack name)
- (cons! regstack (length word))))
- ((= <> < <= > >= u< u<= u> u>=)
- ; force stack depth
- (stack>=! 2)
- ; normalize operand order
- (my (b a) regstack
- (if (and (cons? b)
- (or (integer? a)
- (and (symbol? a)
- (not (cpu-register? a)))))
- (begin
- (set! regstack `(,a ,b ,@(cddr regstack)))
- (set! word (reverse-comparison word)))))
- (cond
- ((and (zero? (car regstack))
- (or (eq? word '<>)
- (eq? word '=))
- (cons? (cadr regstack))
- (memq (caadr regstack)
- '(= <> < <= > >= u< u<= u> u>=)))
- (cdr! regstack) ; drop the zero
- (if (eq? word '=)
- (set! (caar regstack)
- (negate-comparison (caar regstack)))))
- (else
- ; reduce subexpressions
- (if (cons? (second regstack))
- (->register 1))
- (if (cons? (first regstack))
- (->register 0))
- ; make an expression
- (my b (car regstack)
- (cdr! regstack)
- (my a (car regstack)
- (cdr! regstack)
- (cons! regstack (list word a b)))))))
- ((stack=!)
- (if (null? regstack)
- (raise 'invalid-context 'stack=!))
- (my depth (car regstack)
- (cdr! regstack)
- (type integer depth)
- (stack<=! depth)
- (stack>=! depth)))
- ((gen-label)
- (cons! regstack (gen-label name)))
- ((stick-label)
- (if (null? regstack)
- (raise 'invalid-context 'stick-label))
- (my label (car regstack)
- ; FIXME: check integrity of the label here
- (cdr! regstack)
- (emit label)))
- ((->synstack)
- (if (null? regstack)
- (raise 'invalid-context '->synstack))
- (my item (car regstack)
- (cdr! regstack)
- (cons! synstack item)))
- ((<-synstack)
- (if (null? synstack)
- (raise 'invalid-context '<-synstack))
- (my item (car synstack)
- (cdr! synstack)
- (cons! regstack item)))
- ((annihilate)
- (cond
- ((null? synstack)
- (raise 'invalid-context 'annihilate))
- ((null? (cdr synstack))
- (raise 'invalid-context
- (list (car synstack) 'annihilate)))
- (else
- (my (etalon actual . rest) synstack
- (set! synstack rest)
- (if (not (eq? actual etalon))
- (raise 'syntax-mismatch
- (list actual etalon)))))))
- ((?jump)
- ; Note that |?jump| just jumps disregarding
- ; any register usage mismatches
- (if (null? regstack)
- (raise 'invalid-context '?jump))
- (my l (car regstack)
- (cdr! regstack)
- (conditional-jump l)))
- (cons?
- (case (car word)
- ((quote) (if (not (and (cons? (cdr word))
- (null? (cddr word))))
- (raise 'worth-word? word))
- (my sym (second word)
- (type symbol sym)
- (if (memq sym known-procedure-box[])
- (cons! regstack sym)
- (raise 'undefined sym))))
- ((unquote) (if (not (and (cons? (cdr word))
- (null? (cddr word))))
- (raise 'worth-word? word))
- (emit (if (symbol? (second word))
- (second word)
- (let (loop (l (second word)))
- (map (lambda (item)
- (cond
- ((not (cons? item))
- item)
- ; FIXME: report a suitable error if the stack is too shallow
- ((eq? (car item)
- 'unquote)
- (list-ref regstack
- (second
- item)))
- (else
- (loop item))))
- l)))))
- ((flush) (if (not (null? (cdr word)))
- (raise 'worth-word? word))
- (flush))
- ((register) (let (loop)
- (my r (pick-register
- (and (cons? (cdr word))
- (cdr word)))
- (if r
- (cons! regstack r)
- (begin
- (if (cons? (last regstack))
- ; We've run out of registers and the bottom
- ; register is an expression. This is bad.
- (raise 'deadlock regstack))
- (enstack)
- (loop))))))
- ((copy) (if (not (and (cons? (cdr word))
- (null? (cddr word))))
- (raise 'worth-word? word))
- (copy (second word)))
- ((delete) (if (not (and (cons? (cdr word))
- (null? (cddr word))))
- (raise 'worth-word? word))
- (delete (second word)))
- ((->reg) (case (length word)
- ((1) (raise 'worth-word? word))
- ((2) (->register (second word)))
- ((3) (->register (second word)
- (cddr word)))
- (else (raise 'worth-word? word))))
- ((->ureg) (if (not (and (cons? (cdr word))
- (null? (cddr word))))
- (raise 'worth-word? word))
- (->unaliased-register (second word)))
- ((->/expr) (if (not (and (cons? (cdr word))
- (null? (cddr word))))
- (raise 'worth-word? word))
- (->non-expression (second word)))
- ((stack>=!) (if (not (and (cons? (cdr word))
- (null? (cddr word))))
- (raise 'worth-word? word))
- (stack>=! (second word)))
- ((stack<=!) (if (not (and (cons? (cdr word))
- (null? (cddr word))))
- (raise 'worth-word? word))
- (stack<=! (second word)))
- ((stack=!) (if (not (and (cons? (cdr word))
- (null? (cddr word))))
- (raise 'worth-word? word))
- (stack=! (second word)))
- ((remember) (if (not (and (cons? (cdr word))
- (null? (cddr word))))
- (raise 'worth-word? word))
- (set! reminder (drop regstack
- (second word))))
- ((if-int-const) (if (not (and (cons? (cdr word))
- (cons? (cddr word))
- (cons? (cdddr word))
- (null? (cddddr word))))
- (raise 'worth-word? word))
- (my (i pos neg) (cdr word)
- (process-word-list
- (if (and (> (length regstack) i)
- (integer? (list-ref regstack i)))
- pos
- neg)
- suppress?)))
- ((if-empty) (if (not (and (cons? (cdr word))
- (cons? (cddr word))
- (null? (cdddr word))))
- (raise 'worth-word? word))
- (my (pos neg) (cdr word)
- (process-word-list
- (if (null? regstack)
- pos
- neg)
- suppress?)))
- ((conform) (my reqs (cdr word)
+ (cond
+ ((eq? mode 'syn)
+ (if (char? word)
+ (set! word (char->integer word)))
+ (if (or (integer? word)
+ (symbol? word))
+ (if (not (and (cons? synstack)
+ (eq? (car synstack) '<mute>)))
+ (cons! synstack word))
+ (raise 'synstackable? word))
+ (set! mode #f))
+ ((and (cons? synstack)
+ (eq? (car synstack) '<mute>))
+ (case word
+ ((if) (cons! synstack '<mute>))
+ ((else) (if (not (and (cons? (cdr synstack))
+ (eq? (cadr synstack) '<mute>)))
+ (set! (car synstack) '<unmute>)))
+ ((then) (cdr! synstack))
+ ((thens)
+ (while (and (cons? synstack)
+ (memq (car synstack)
+ '(<mute> <unmute> <if>)))
+ (cdr! synstack))
+ (if (and (cons? synstack)
+ (eq? (car synstack) '<cond>))
+ (cdr! synstack)
+ (raise 'invalid-context 'thens)))
+ ; Ignore these in order to avoid infinite recursion
+ ((dig))
+ ((syn) (set! mode 'syn))
+ ; Although we won't generate any code, we will
+ ; still want to expand macros since the block
+ ; delimiters may be in these expansions.
+ (else (and (assq word macro-box[]) -> c
+ (process-word-list (cdr c) #t)))))
+ ((and (cons? synstack)
+ (eq? (car synstack) '<unmute>)
+ (or (eq? word 'else) (eq? word 'then)))
+ (case word
+ ((else) (set! (car synstack) '<mute>))
+ ((then) (cdr! synstack))))
+ ((and (eq? word 'dig)
+ (cons? regstack)
+ (integer? (car regstack))
+ (> (length (cdr regstack))
+ (reduce-to-utetra (car regstack))))
+ (my object (list-ref (cdr regstack)
+ (reduce-to-utetra
+ (car regstack)))
+ (set! (car regstack) object)
+ (use++ object)))
+ (else
+ (case word
+ (integer? (case mode
+ ((synstack syn)
+ (cons! synstack word))
+ (else
+ (cons! regstack word))))
+ (char? (process-word (char->integer word) #t))
+ (string? (case mode
+ ((synstack syn)
+ (raise 'invalid-context word))
+ (else
+ (my name (genname)
+ (add-string name word)
+ (cons! regstack name)
+ (cons! regstack (length word))))))
+ ((syn synstack) (set! mode word))
+ ((regstack) (set! mode #f))
+ ((believe) (set! regstack '())
+ (set! regref#
+ (map (cut cons <> 0)
+ '(%eax %ebx %ecx %edi
+ %edx %esi))))
+ ((conform) (set! mode #f) ; for convenience
+ (my reqs (or (get-dollar-list)
+ (raise 'invalid-context
+ word))
(cond
((null? reqs) (flush))
((and (cons? reqs)
(null? (cdr reqs))
reqs -> (reg)
(assq reg regref#))
- (my (reg) reqs
- (->register 0 reg)
- (stack=! 1)))
+ (my (reg) reqs
+ (->register 0 reg)
+ (stack=! 1)))
((and (cons? reqs)
(cons? (cdr reqs))
(null? (cddr reqs))
@@ -657,10 +546,10 @@
(assq reg1 regref#)
(assq reg2 regref#)
(not (eq? reg1 reg2)))
- (my (reg1 reg2) reqs
- (stack<=! 2)
- (->register 0 reg2)
- (->register 1 reg1)))
+ (my (reg1 reg2) reqs
+ (stack<=! 2)
+ (->register 0 reg1)
+ (->register 1 reg2)))
((and (cons? reqs)
(cons? (cdr reqs))
(cons? (cddr reqs))
@@ -672,67 +561,321 @@
(not (eq? reg1 reg2))
(not (eq? reg1 reg3))
(not (eq? reg2 reg3)))
- (my (reg1 reg2 reg3) reqs
- (stack<=! 3)
- (->register 0 reg3)
- (->register 1 reg2)
- (->register 2 reg1)))
+ (my (reg1 reg2 reg3) reqs
+ (stack<=! 3)
+ (->register 0 reg1)
+ (->register 1 reg2)
+ (->register 2 reg3)))
(else (raise 'unable-to-conform
reqs)))))
- ((believe) (my claim (cdr word)
- (set! regstack
- (if (and (not (null? claim))
- (eq? (car claim) '*))
- (append-reverse (cdr claim) reminder)
- (reverse claim)))
- (set! regref#
- (map (cut cons <> 0)
- '(%eax %ebx %ecx %edi
- %edx %esi)))
- (for-each use++ regstack)))
- (else (raise 'worth-word? word))))
- (else
- (cond
- ((and (memq word '(+ - * / mod lshift rshift))
- (cons? regstack)
- (integer? (car regstack))
- (cons? (cdr regstack))
- (integer? (cadr regstack)))
- (case word
- ((+ - * / mod lshift rshift)
- (my (b a . rest) regstack
- (set! regstack
- (cons
- (case word
- ((+) (+ a b))
- ((-) (- a b))
- ((*) (* a b))
- ((/) (quotient a b))
- ((mod) (remainder a b))
- ((lshift) (reduce-to-utetra
- (<< (reduce-to-utetra a)
- b)))
- ((rshift) (>> (reduce-to-utetra a)
- b))
- (else (raise 'huh? word)))
- rest))))
+ ((decode-register)
+ (stack>=! 1)
+ (my obj (car regstack)
+ (cdr! regstack)
+ (my c (assq obj register-data)
+ (if (not c)
+ (raise 'register? obj))
+ (cdr! c)
+ (cons! regstack (first c))
+ (cons! regstack (second c)))))
+ ((literal-integer?)
+ (stack>=! 1)
+ (my obj (car regstack)
+ (set! (car regstack)
+ (if (integer? obj)
+ -1 0))
+ (use-- obj)))
+ ((register?)
+ (stack>=! 1)
+ (my obj (car regstack)
+ (set! (car regstack)
+ (if (cpu-register? obj)
+ -1 0))
+ (use-- obj)))
+ ((is?)
+ (stack>=! 2)
+ (my (a b . rest) regstack
+ (set! regstack rest)
+ (cons! regstack (if (equal? a b)
+ -1 0))
+ (use-- a)
+ (use-- b)))
+ ((regstack-depth)
+ (cons! regstack (length regstack)))
+ ((thens)
+ (while (and (cons? synstack)
+ (eq? (car synstack) '<if>))
+ (process-word 'then #t))
+ (if (and (cons? synstack)
+ (eq? (car synstack) '<cond>))
+ (cdr! synstack)
+ (raise 'invalid-context 'thens)))
+ ((bug)
+ (raise 'bug-occurred (reverse regstack)))
+ ((stack=!)
+ (if (null? regstack)
+ (raise 'invalid-context 'stack=!))
+ (my depth (car regstack)
+ (cdr! regstack)
+ (type integer depth)
+ (stack<=! depth)
+ (stack>=! depth)))
+ ((gen-label)
+ (cons! regstack (gen-label name)))
+ ((stick-label)
+ (if (null? regstack)
+ (raise 'invalid-context 'stick-label))
+ (my label (car regstack)
+ ; FIXME: check integrity of the label here
+ (cdr! regstack)
+ (emit label)))
+ ((byte#)
+ (if (or (null? regstack)
+ (not (integer? (car regstack))))
+ (raise 'invalid-context 'byte#))
+ (emit (list 'byte (car regstack)))
+ (cdr! regstack))
+ ((wyde#)
+ (if (or (null? regstack)
+ (not (integer? (car regstack))))
+ (raise 'invalid-context 'wyde#))
+ (emit (list 'wyde (car regstack)))
+ (cdr! regstack))
+ ((tetra#)
+ (if (or (null? regstack)
+ (not (or (integer? (car regstack))
+ (symbol? (car regstack)))))
+ (raise 'invalid-context 'wyde#))
+ (emit (list 'tetra (car regstack)))
+ (cdr! regstack))
+ ((->synstack)
+ (if (null? regstack)
+ (raise 'invalid-context '->synstack))
+ (my item (car regstack)
+ (cdr! regstack)
+ (cons! synstack item)
+ (use-- item)))
+ ((<-synstack)
+ (if (null? synstack)
+ (raise 'invalid-context '<-synstack))
+ (my item (car synstack)
+ (cdr! synstack)
+ (cons! regstack item)
+ (use++ item)))
+ ((annihilate)
+ (cond
+ ((null? synstack)
+ (raise 'invalid-context 'annihilate))
+ ((null? (cdr synstack))
+ (raise 'invalid-context
+ (list (car synstack) 'annihilate)))
(else
- (raise 'huh? word))))
- ((eq? (word-class word) 'broketed)
- (cons! synstack word))
- ((assq word macro-box[])
- => (serial cdr (cut process-word-list <> #t)))
- ((memq word known-procedure-box[])
- (flush)
- (emit `(call ,word)))
+ (my (etalon actual . rest) synstack
+ (set! synstack rest)
+ (if (not (eq? actual etalon))
+ (raise 'syntax-mismatch
+ (list actual etalon)))))))
+ ((?jump)
+ ; Note that |?jump| just jumps disregarding
+ ; any register usage mismatches
+ (if (null? regstack)
+ (raise 'invalid-context '?jump))
+ (my l (car regstack)
+ (cdr! regstack)
+ (conditional-jump l)))
+ (cons?
+ (case (car word)
+ ((quote) (if (not (and (cons? (cdr word))
+ (null? (cddr word))))
+ (raise 'worth-word? word))
+ (my sym (second word)
+ (type symbol sym)
+ (if (memq sym known-procedure-box[])
+ (cons! regstack sym)
+ (raise 'undefined sym))))
+ ((unquote) (if (not (and (cons? (cdr word))
+ (null? (cddr word))))
+ (raise 'worth-word? word))
+ (emit (if (symbol? (second word))
+ (second word)
+ (let (loop (l (second word)))
+ (map (lambda (item)
+ (cond
+ ((not (cons? item))
+ item)
+ ; FIXME: report a suitable error if the stack is too shallow
+ ((eq? (car item)
+ 'unquote)
+ (list-ref regstack
+ (second
+ item)))
+ (else
+ (loop item))))
+ l)))))
+ ((flush) (if (not (null? (cdr word)))
+ (raise 'worth-word? word))
+ (flush))
+ ((register) (let (loop)
+ (my r (pick-register
+ (and (cons? (cdr word))
+ (cdr word)))
+ (if r
+ (cons! regstack r)
+ (begin
+ (if (cons? (last regstack))
+ ; We've run out of registers and the bottom
+ ; register is an expression. This is bad.
+ (raise 'deadlock regstack))
+ (enstack)
+ (loop))))))
+ ((copy) (if (not (and (cons? (cdr word))
+ (null? (cddr word))))
+ (raise 'worth-word? word))
+ (copy (second word)))
+ ((delete) (if (not (and (cons? (cdr word))
+ (null? (cddr word))))
+ (raise 'worth-word? word))
+ (delete (second word)))
+ ((->reg) (case (length word)
+ ((1) (raise 'worth-word? word))
+ ((2) (->register (second word)))
+ ((3) (->register (second word)
+ (cddr word)))
+ (else (raise 'worth-word? word))))
+ ((->ureg) (if (not (and (cons? (cdr word))
+ (null? (cddr word))))
+ (raise 'worth-word? word))
+ (->unaliased-register (second word)))
+ ((->/expr) (if (not (and (cons? (cdr word))
+ (null? (cddr word))))
+ (raise 'worth-word? word))
+ (->non-expression (second word)))
+ ((stack>=!) (if (not (and (cons? (cdr word))
+ (null? (cddr word))))
+ (raise 'worth-word? word))
+ (stack>=! (second word)))
+ ((stack<=!) (if (not (and (cons? (cdr word))
+ (null? (cddr word))))
+ (raise 'worth-word? word))
+ (stack<=! (second word)))
+ ((stack=!) (if (not (and (cons? (cdr word))
+ (null? (cddr word))))
+ (raise 'worth-word? word))
+ (stack=! (second word)))
+ (else (raise 'worth-word? word))))
(else
- (raise 'worth-word? word)))))
- (if (and (not suppress?)
- skip-assembly?[] => (cut >= <> 3))
- (emit (list '() 'stack (reverse regstack))))
- (if (and (not suppress?)
- skip-assembly?[] => (cut >= <> 4))
- (emit (list '() 'synstack (reverse synstack))))))
+ (cond
+ ((and (eq? word 'if)
+ (cons? regstack)
+ (integer? (car regstack)))
+ (set! (car regstack)
+ (reduce-to-stetra (car regstack)))
+ (cons! synstack
+ (if (zero? (car regstack))
+ '<mute>
+ '<unmute>))
+ (cdr! regstack))
+ ((and (memq word
+ '(* + - / < <= <> = > >=
+ lshift mod rshift u< u<=
+ u> u>=))
+ (cons? regstack)
+ (integer? (car regstack))
+ (cons? (cdr regstack))
+ (integer? (cadr regstack)))
+ (case word
+ ((* + - / < <= <> = > >= lshift mod
+ rshift u< u<= u> u>=)
+ (my (b a . rest) regstack
+ (set! a (reduce-to-stetra a))
+ (set! b (reduce-to-stetra b))
+ (set! regstack
+ (cons
+ (case word
+ ((+) (+ a b))
+ ((-) (- a b))
+ ((*) (* a b))
+ ((/) (quotient a b))
+ ((mod) (remainder a b))
+ ((lshift) (<< (reduce-to-utetra a)
+ (reduce-to-utetra b)))
+ ((rshift) (>> (reduce-to-utetra a)
+ (reduce-to-utetra b)))
+ ((=) (if (= a b) -1 0))
+ ((<) (if (< a b) -1 0))
+ ((>) (if (> a b) -1 0))
+ ((<=) (if (<= a b) -1 0))
+ ((>=) (if (>= a b) -1 0))
+ ((u<) (if (< (reduce-to-utetra a)
+ (reduce-to-utetra b))
+ -1 0))
+ ((u>) (if (> (reduce-to-utetra a)
+ (reduce-to-utetra b))
+ -1 0))
+ ((u<=) (if (<= (reduce-to-utetra a)
+ (reduce-to-utetra b))
+ -1 0))
+ ((u>=) (if (>= (reduce-to-utetra a)
+ (reduce-to-utetra b))
+ -1 0))
+ (else (raise 'huh? word)))
+ rest))))
+ (else
+ (raise 'huh? word))))
+ ((memq word '(= <> < <= > >= u< u<= u> u>=))
+ ; force stack depth
+ (stack>=! 2)
+ ; normalize operand order
+ (my (b a) regstack
+ (if (and (cons? b)
+ (or (integer? a)
+ (and (symbol? a)
+ (not (cpu-register? a)))))
+ (begin
+ (set! regstack `(,a ,b ,@(cddr regstack)))
+ (set! word (reverse-comparison word)))))
+ (cond
+ ((and (zero? (car regstack))
+ (or (eq? word '<>)
+ (eq? word '=))
+ (cons? (cadr regstack))
+ (memq (caadr regstack)
+ '(= <> < <= > >= u< u<= u> u>=)))
+ (cdr! regstack) ; drop the zero
+ (if (eq? word '=)
+ (set! (caar regstack)
+ (negate-comparison (caar regstack)))))
+ (else
+ ; reduce subexpressions
+ (if (cons? (second regstack))
+ (->register 1))
+ (if (cons? (first regstack))
+ (->register 0))
+ ; make an expression
+ (my b (car regstack)
+ (cdr! regstack)
+ (my a (car regstack)
+ (cdr! regstack)
+ (cons! regstack (list word a b)))))))
+
+ ((assq word macro-box[])
+ => (serial cdr (cut process-word-list <> #t)))
+ ((eq? mode 'synstack)
+ (cons! synstack word))
+ ((cpu-register? word)
+ (cons! regstack word)
+ (use++ word))
+ ((memq word known-procedure-box[])
+ (flush)
+ (emit `(call ,word)))
+ (else
+ (raise 'worth-word? word)))))
+ (if (and (not suppress?)
+ skip-assembly?[] => (cut >= <> 3))
+ (emit (list '() 'stack (reverse regstack))))))
+ (if (and (not suppress?)
+ skip-assembly?[] => (cut >= <> 4))
+ (emit (list '() 'synstack (reverse synstack))))))
(for-each (cut process-word <> #f) body)
(if (eq? name '_start)
(begin
|
|
From: <di...@us...> - 2002-09-30 18:24:58
|
Update of /cvsroot/wisp/wisp/modules
In directory usw-pr-cvs1:/tmp/cvs-serv25684/modules
Modified Files:
Makefile.am io.wrti linux.wrti universal.wrti wisptyp.wrti
Added Files:
ia32.wrti
Log Message:
Created the beginnings of Worth-level assemblying.
--- NEW FILE: ia32.wrti ---
;;;; ia32.wrti - an experiment at tangling Worth and an assembler
;;
;; Copyleft © 2002 by Andres Soolo (di...@us...)
;; This file is licensed under the GNU GPL v2. If you
;; don't know what that means, please do read the GPL.
;;
;;;; @(#) $Id: ia32.wrti,v 1.1 2002/09/30 18:24:55 digg Exp $
(ifndef _ia32.wrti_ (define _ia32.wrti_)
; Prefixes
(macro .a16. #o147 byte#)
(macro .a32.)
(macro .o16. #o146 byte#)
(macro .o32.)
(macro .lock. #o360 byte#)
(macro .rep. #o363 byte#)
(macro .repe. #o363 byte#)
(macro .repz. #o363 byte#)
(macro .repne. #o362 byte#)
(macro .repnz. #o362 byte#)
; "String" operations
(macro .ins.b. #o154 byte#)
(macro .ins.w. .o16. #o155 byte#)
(macro .ins.t. .o32. #o155 byte#)
(macro .outs.b. #o156 byte#)
(macro .outs.w. .o16. #o157 byte#)
(macro .outs.t. .o32. #o157 byte#)
(macro .movs.b. #o244 byte#)
(macro .movs.w. .o16. #o245 byte#)
(macro .movs.t. .o32. #o245 byte#)
(macro .cmps.b. #o246 byte#)
(macro .cmps.w. .o16. #o247 byte#)
(macro .cmps.t. .o32. #o247 byte#)
(macro .stos.b. #o252 byte#)
(macro .stos.w. .o16. #o253 byte#)
(macro .stos.t. .o32. #o253 byte#)
(macro .lods.b. #o254 byte#)
(macro .lods.w. .o16. #o255 byte#)
(macro .lods.t. .o32. #o255 byte#)
(macro .scas.b. #o256 byte#)
(macro .scas.w. .o16. #o257 byte#)
(macro .scas.t. .o32. #o257 byte#)
; Flag operations
(macro .cmc. #o365 byte#)
(macro .clc. #o370 byte#)
(macro .stc. #o371 byte#)
(macro .cli. #o372 byte#)
(macro .sti. #o373 byte#)
(macro .cld. #o374 byte#)
(macro .std. #o375 byte#)
; Privileged instructions
(macro .hlt. #o364 byte#)
(macro .clts. #o017 byte# #o006 byte#)
(macro .rdmsr. #o017 byte# #o062 byte#)
(macro .wrmsr. #o017 byte# #o060 byte#)
; Stack manipulation
(macro .enter. #o310 byte# swap wyde# byte#)
(macro .leave. #o311 byte#)
(macro .push.
cond dup register? if
decode-register swap
cond dup 0 = if drop .o32. #o120 + byte#
else dup 1 = if drop .o16. #o120 + byte#
else bug thens
else bug
thens)
(macro .pusha. #o140 byte#)
(macro .pusha.w. .o16. .pusha.)
(macro .pusha.t. .o32. .pusha.)
(macro .pushf. #o234 byte#)
(macro .pushf.w. .o16. .pushf.)
(macro .pushf.t. .o32. .pushf.)
(macro .pop.
cond dup register? if
decode-register swap
cond dup 0 = if drop .o32. #o130 + byte#
else dup 1 = if drop .o16. #o130 + byte#
else bug thens
else bug
thens)
(macro .popa. #o141 byte#)
(macro .popa.w. .o16. .popa.)
(macro .popa.t. .o32. .popa.)
(macro .popf. #o235 byte#)
(macro .popf.w. .o16. .popf.)
(macro .popf.t. .o32. .popf.)
; Floating point instructions: computation
(macro .fchs. #o331 byte# #o340 byte#)
(macro .fabs. #o331 byte# #o341 byte#)
(macro .f2xm1. #o331 byte# #o360 byte#)
(macro .fyl2x. #o331 byte# #o361 byte#)
(macro .fptan. #o331 byte# #o362 byte#)
(macro .fpatan. #o331 byte# #o363 byte#)
(macro .fprem1. #o331 byte# #o365 byte#)
(macro .fprem. #o331 byte# #o370 byte#)
(macro .fyl2xp1. #o331 byte# #o371 byte#)
(macro .fsqrt. #o331 byte# #o372 byte#)
(macro .fsincos. #o331 byte# #o373 byte#)
(macro .frndint. #o331 byte# #o374 byte#)
(macro .fscale. #o331 byte# #o375 byte#)
(macro .fsin. #o331 byte# #o376 byte#)
(macro .fcos. #o331 byte# #o377 byte#)
; Floating point instructions: computation control
(macro .fld.one. #o331 byte# #o350 byte#)
(macro .fld.l2t. #o331 byte# #o351 byte#)
(macro .fld.l2e. #o331 byte# #o352 byte#)
(macro .fld.pi. #o331 byte# #o353 byte#)
(macro .fld.lg2. #o331 byte# #o354 byte#)
(macro .fld.ln2. #o331 byte# #o355 byte#)
(macro .fld.zero. #o331 byte# #o356 byte#)
; Control flow
(macro .int. #o315 byte# byte#)
(macro .int1. #o361 byte#)
(macro .int3. #o314 byte#)
(macro .into. #o316 byte#)
(macro .iret. #o317 byte#)
(macro .iret.w. .o16. .iret.)
(macro .iret.t. .o32. .iret.)
(macro .ret. #o303 byte#)
(macro .ret.f. #o313 byte#))
; vim: ft=worth
Index: Makefile.am
===================================================================
RCS file: /cvsroot/wisp/wisp/modules/Makefile.am,v
retrieving revision 1.57
retrieving revision 1.58
diff -u -d -r1.57 -r1.58
--- Makefile.am 18 Sep 2002 21:16:38 -0000 1.57
+++ Makefile.am 30 Sep 2002 18:24:55 -0000 1.58
@@ -33,7 +33,7 @@
files.wid getopt.wid ini.wid lists.wid locale.wid random.wid \
strings.wid unicode.wid
-wrti_DATA = io.wrti linux.wrti universal.wrti wisptyp.wrti
+wrti_DATA = ia32.wrti io.wrti linux.wrti universal.wrti wisptyp.wrti
EXTRA_DIST = .cvsignore \
$(wisp_DATA) $(wim_DATA) $(wid_DATA) $(wrti_DATA)
Index: io.wrti
===================================================================
RCS file: /cvsroot/wisp/wisp/modules/io.wrti,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -d -r1.10 -r1.11
--- io.wrti 18 Sep 2002 20:58:04 -0000 1.10
+++ io.wrti 30 Sep 2002 18:24:55 -0000 1.11
@@ -27,6 +27,16 @@
(macro encode-digit
dup 10 >= if 7 + then #\0 +)
+ (macro decode-digit
+ dup #\a >= if #\a #\A - - then
+ cond
+ dup #\0 < if drop -1 else
+ dup #\9 <= if #\0 - else
+ dup #\A < if drop -1 else
+ dup #\Z <= if #\A 10 - - else
+ drop -1
+ thens)
+
(macro emit-digit
encode-digit emit)
Index: linux.wrti
===================================================================
RCS file: /cvsroot/wisp/wisp/modules/linux.wrti,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -d -r1.23 -r1.24
--- linux.wrti 18 Sep 2002 21:14:23 -0000 1.23
+++ linux.wrti 30 Sep 2002 18:24:55 -0000 1.24
@@ -6,37 +6,35 @@
;;
;;;; @(#) $Id$
-;;;; Note the unfortunate dependency on ia32.
+(include ia32) ; Note the unfortunate dependency on ia32.
(ifndef _linux.wrti_ (define _linux.wrti_)
; These are supposed to be used immediately in the start of |_start|.
- (macro argc-argv-envp (stack=! 1) sp@ 2dup swap cells + cell+)
+ (macro argc-argv-envp 1 stack=! sp@ 2dup swap cells + cell+)
(macro argv-envp argc-argv-envp rot drop)
- (macro \sys ,(mov %eax ,0) drop ,(int #x80))
- (macro \skt (stack=! 1) ,(mov %ebx ,0) drop
+ (macro \sys ,(mov %eax ,0) drop #x80 .int.)
+ (macro \skt 1 stack=! ,(mov %ebx ,0) drop
(flush) ,(mov %ecx %esp) 102 \sys)
(macro sys.exit (->reg 0 %ebx) 1 \sys ,(\skip))
(macro sys.write-char ; ( fd char )
- (flush)
- ,(pop %ecx)
- ,(pop %ebx)
+ $ %ebx %ecx conform
,(mov %edx 1)
,(push %ecx)
,(mov %ecx %esp)
4 \sys
,(add %esp 4)
- (believe %eax))
+ believe %eax)
; |sys.pipe| returns ( reading-part writing-part ) or ( -errno )
(macro sys.pipe
- (conform)
+ $ conform
,(sub %esp 8) ; allocate space for filedes[2]
,(mov %ebx %esp)
- 42 \sys (believe %eax)
+ 42 \sys believe %eax
dup 0 < if ; failed?
nip nip ; clean up
else
@@ -44,100 +42,100 @@
swap ; account for downwards-growing stack
then)
- (macro sys.fork (conform) 2 \sys (believe %eax))
- (macro sys.read (conform %ebx %ecx %edx) 3 \sys (believe %eax))
- (macro sys.write (conform %ebx %ecx %edx) 4 \sys (believe %eax))
- (macro sys.open (conform %ebx %ecx %edx) 5 \sys (believe %eax))
- (macro sys.close (conform %ebx) 6 \sys (believe %eax))
+ (macro sys.fork $ conform 2 \sys believe %eax)
+ (macro sys.read $ %ebx %ecx %edx conform 3 \sys believe %eax)
+ (macro sys.write $ %ebx %ecx %edx conform 4 \sys believe %eax)
+ (macro sys.open $ %ebx %ecx %edx conform 5 \sys believe %eax)
+ (macro sys.close $ %ebx conform 6 \sys believe %eax)
; |sys.waitpid| takes (pid options) and
; returns (status pid) or (-errno) or (0)
- (macro sys.waitpid (conform %ebx %edx) ,(sub %esp 4) ,(mov %ecx %esp)
- 7 \sys (believe %eax)
+ (macro sys.waitpid $ %ebx %edx conform ,(sub %esp 4) ,(mov %ecx %esp)
+ 7 \sys believe %eax
dup 0 <= if ; no status?
nip
then)
- (macro sys.creat (conform %ebx %ecx) 8 \sys (believe %eax))
- (macro sys.link (conform %ebx %ecx) 9 \sys (believe %eax))
- (macro sys.unlink (conform %ebx) 10 \sys (believe %eax))
- (macro sys.execve (conform %ebx %ecx %edx) 11 \sys (believe %eax))
- (macro sys.chdir (conform %ebx) 12 \sys (believe %eax))
+ (macro sys.creat $ %ebx %ecx conform 8 \sys believe %eax)
+ (macro sys.link $ %ebx %ecx conform 9 \sys believe %eax)
+ (macro sys.unlink $ %ebx conform 10 \sys believe %eax)
+ (macro sys.execve $ %ebx %ecx %edx conform 11 \sys believe %eax)
+ (macro sys.chdir $ %ebx conform 12 \sys believe %eax)
; |sys.time| takes no argument and returns the time
- (macro sys.time (conform) ,(mov %ebx 0) 13 \sys (believe %eax))
- (macro sys.chmod (conform %ebx %ecx) 15 \sys (believe %eax))
- (macro sys.lseek (conform %ebx %ecx %edx) 19 \sys (believe %eax))
- (macro sys.getpid (conform) 20 \sys (believe %eax))
- (macro sys.setuid (conform %ebx) 23 \sys (believe %eax))
- (macro sys.getuid (conform) 24 \sys (believe %eax))
- (macro sys.stime (conform %ebx) 25 \sys (believe %eax))
- (macro sys.alarm (conform %ebx) 27 \sys (believe %eax))
- (macro sys.pause (conform) 29 \sys (believe %eax))
- (macro sys.access (conform %ebx %ecx) 33 \sys (believe %eax))
- (macro sys.nice (conform %ebx) 34 \sys (believe %eax))
+ (macro sys.time $ conform ,(mov %ebx 0) 13 \sys believe %eax)
+ (macro sys.chmod $ %ebx %ecx conform 15 \sys believe %eax)
+ (macro sys.lseek $ %ebx %ecx %edx conform 19 \sys believe %eax)
+ (macro sys.getpid $ conform 20 \sys believe %eax)
+ (macro sys.setuid $ %ebx conform 23 \sys believe %eax)
+ (macro sys.getuid $ conform 24 \sys believe %eax)
+ (macro sys.stime $ %ebx conform 25 \sys believe %eax)
+ (macro sys.alarm $ %ebx conform 27 \sys believe %eax)
+ (macro sys.pause $ conform 29 \sys believe %eax)
+ (macro sys.access $ %ebx %ecx conform 33 \sys believe %eax)
+ (macro sys.nice $ %ebx conform 34 \sys believe %eax)
; since sync(2) never fails, |sys.sync| returns nothing
- (macro sys.sync (conform) 36 \sys (believe))
- (macro sys.kill (conform %ebx %ecx) 37 \sys (believe %eax))
- (macro sys.rename (conform %ebx %ecx) 38 \sys (believe %eax))
- (macro sys.mkdir (conform %ebx %ecx) 39 \sys (believe %eax))
- (macro sys.rmdir (conform %ebx) 40 \sys (believe %eax))
- (macro sys.dup (conform %ebx) 41 \sys (believe %eax))
- (macro sys.brk (conform %ebx) 45 \sys (believe %eax))
- (macro sys.setgid (conform %ebx) 46 \sys (believe %eax))
- (macro sys.getgid (conform) 47 \sys (believe %eax))
- (macro sys.geteuid (conform) 49 \sys (believe %eax))
- (macro sys.getegid (conform) 50 \sys (believe %eax))
- (macro sys.ioctl (conform %ebx %ecx %edx) 54 \sys (believe %eax))
- (macro sys.ioctl2 (conform %ebx %ecx %edx %esi) 54 \sys (believe %eax))
- (macro sys.setpgid (conform %ebx %ecx) 57 \sys (believe %eax))
- (macro sys.umask (conform %ebx) 60 \sys (believe %eax))
- (macro sys.chroot (conform %ebx) 61 \sys (believe %eax))
- (macro sys.dup2 (conform %ebx %ecx) 63 \sys (believe %eax))
- (macro sys.getppid (conform) 64 \sys (believe %eax))
- (macro sys.getpgrp (conform) 65 \sys (believe %eax))
- (macro sys.setsid (conform) 66 \sys (believe %eax))
- (macro sys.setreuid (conform %ebx %ecx) 70 \sys (believe %eax))
- (macro sys.setregid (conform %ebx %ecx) 71 \sys (believe %eax))
- (macro sys.symlink (conform %ebx %ecx) 83 \sys (believe %eax))
- (macro sys.swapon (conform %ebx %ecx) 87 \sys (believe %eax))
- (macro sys.truncate (conform %ebx %ecx) 92 \sys (believe %eax))
- (macro sys.ftruncate (conform %ebx %ecx) 93 \sys (believe %eax))
- (macro sys.fchmod (conform %ebx %ecx) 94 \sys (believe %eax))
- (macro sys.stat (conform %ebx %ecx) 106 \sys (believe %eax))
- (macro sys.lstat (conform %ebx %ecx) 107 \sys (believe %eax))
- (macro sys.fstat (conform %ebx %ecx) 108 \sys (believe %eax))
- (macro sys.vhangup (conform) 111 \sys (believe %eax))
- (macro sys.swapoff (conform %ebx) 115 \sys (believe %eax))
- (macro sys.fsync (conform %ebx) 118 \sys (believe %eax))
- (macro sys.getpgid (conform %ebx) 132 \sys (believe %eax))
- (macro sys.fchdir (conform %ebx) 133 \sys (believe %eax))
- (macro sys.getdents (conform %ebx %ecx %edx) 141 \sys (believe %eax))
+ (macro sys.sync $ conform 36 \sys believe)
+ (macro sys.kill $ %ebx %ecx conform 37 \sys believe %eax)
+ (macro sys.rename $ %ebx %ecx conform 38 \sys believe %eax)
+ (macro sys.mkdir $ %ebx %ecx conform 39 \sys believe %eax)
+ (macro sys.rmdir $ %ebx conform 40 \sys believe %eax)
+ (macro sys.dup $ %ebx conform 41 \sys believe %eax)
+ (macro sys.brk $ %ebx conform 45 \sys believe %eax)
+ (macro sys.setgid $ %ebx conform 46 \sys believe %eax)
+ (macro sys.getgid $ conform 47 \sys believe %eax)
+ (macro sys.geteuid $ conform 49 \sys believe %eax)
+ (macro sys.getegid $ conform 50 \sys believe %eax)
+ (macro sys.ioctl $ %ebx %ecx %edx conform 54 \sys believe %eax)
+ (macro sys.ioctl2 $ %ebx %ecx %edx %esi conform 54 \sys believe %eax)
+ (macro sys.setpgid $ %ebx %ecx conform 57 \sys believe %eax)
+ (macro sys.umask $ %ebx conform 60 \sys believe %eax)
+ (macro sys.chroot $ %ebx conform 61 \sys believe %eax)
+ (macro sys.dup2 $ %ebx %ecx conform 63 \sys believe %eax)
+ (macro sys.getppid $ conform 64 \sys believe %eax)
+ (macro sys.getpgrp $ conform 65 \sys believe %eax)
+ (macro sys.setsid $ conform 66 \sys believe %eax)
+ (macro sys.setreuid $ %ebx %ecx conform 70 \sys believe %eax)
+ (macro sys.setregid $ %ebx %ecx conform 71 \sys believe %eax)
+ (macro sys.symlink $ %ebx %ecx conform 83 \sys believe %eax)
+ (macro sys.swapon $ %ebx %ecx conform 87 \sys believe %eax)
+ (macro sys.truncate $ %ebx %ecx conform 92 \sys believe %eax)
+ (macro sys.ftruncate $ %ebx %ecx conform 93 \sys believe %eax)
+ (macro sys.fchmod $ %ebx %ecx conform 94 \sys believe %eax)
+ (macro sys.stat $ %ebx %ecx conform 106 \sys believe %eax)
+ (macro sys.lstat $ %ebx %ecx conform 107 \sys believe %eax)
+ (macro sys.fstat $ %ebx %ecx conform 108 \sys believe %eax)
+ (macro sys.vhangup $ conform 111 \sys believe %eax)
+ (macro sys.swapoff $ %ebx conform 115 \sys believe %eax)
+ (macro sys.fsync $ %ebx conform 118 \sys believe %eax)
+ (macro sys.getpgid $ %ebx conform 132 \sys believe %eax)
+ (macro sys.fchdir $ %ebx conform 133 \sys believe %eax)
+ (macro sys.getdents $ %ebx %ecx %edx conform 141 \sys believe %eax)
(macro sys.select
(->reg 0 %edi)
(->reg 1 %esi)
(->reg 2 %edx)
(->reg 3 %ecx)
(->reg 4 %ebx)
- 142 \sys (believe %eax))
- (macro sys.flock (conform %ebx %ecx) 143 \sys (believe %eax))
- (macro sys.getsid (conform %ebx) 147 \sys (believe %eax))
- (macro sys.fdatasync (conform %ebx) 148 \sys (believe %eax))
- (macro sys.mlock (conform %ebx %ecx) 150 \sys (believe %eax))
- (macro sys.munlock (conform %ebx %ecx) 151 \sys (believe %eax))
- (macro sys.mlockall (conform %ebx) 152 \sys (believe %eax))
- (macro sys.munlockall (conform) 153 \sys (believe %eax))
+ 142 \sys believe %eax)
+ (macro sys.flock $ %ebx %ecx conform 143 \sys believe %eax)
+ (macro sys.getsid $ %ebx conform 147 \sys believe %eax)
+ (macro sys.fdatasync $ %ebx conform 148 \sys believe %eax)
+ (macro sys.mlock $ %ebx %ecx conform 150 \sys believe %eax)
+ (macro sys.munlock $ %ebx %ecx conform 151 \sys believe %eax)
+ (macro sys.mlockall $ %ebx conform 152 \sys believe %eax)
+ (macro sys.munlockall $ conform 153 \sys believe %eax)
; |sys.nanosleep| takes ( sec nsec ) and returns ( sec nsec result ).
; The returned time is not always meaningful.
(macro sys.nanosleep swap (flush) ,(mov %ebx %esp) ,(mov %ecx %esp)
- 162 \sys (believe %eax) -rot swap rot)
- (macro sys.getcwd (conform %ebx %ecx) 183 \sys (believe %eax))
+ 162 \sys believe %eax -rot swap rot)
+ (macro sys.getcwd $ %ebx %ecx conform 183 \sys believe %eax)
- (macro sys.socket swap rot 1 \skt (believe %eax) nip nip nip)
- (macro sys.bind swap rot 2 \skt (believe %eax) nip nip nip)
- (macro sys.connect swap rot 3 \skt (believe %eax) nip nip nip)
- (macro sys.listen swap 4 \skt (believe %eax) nip nip)
- (macro sys.accept swap rot 5 \skt (believe %eax) nip nip nip)
- (macro sys.getsockname swap rot 6 \skt (believe %eax) nip nip nip)
- (macro sys.getpeername swap rot 7 \skt (believe %eax) nip nip nip)
- (macro sys.shutdown swap 13 \skt (believe %eax) nip nip)
+ (macro sys.socket swap rot 1 \skt believe %eax nip nip nip)
+ (macro sys.bind swap rot 2 \skt believe %eax nip nip nip)
+ (macro sys.connect swap rot 3 \skt believe %eax nip nip nip)
+ (macro sys.listen swap 4 \skt believe %eax nip nip)
+ (macro sys.accept swap rot 5 \skt believe %eax nip nip nip)
+ (macro sys.getsockname swap rot 6 \skt believe %eax nip nip nip)
+ (macro sys.getpeername swap rot 7 \skt believe %eax nip nip nip)
+ (macro sys.shutdown swap 13 \skt believe %eax nip nip)
;;;; <asm/errno.h>
(macro EPERM 1) ; Operation not permitted
Index: universal.wrti
===================================================================
RCS file: /cvsroot/wisp/wisp/modules/universal.wrti,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -d -r1.25 -r1.26
--- universal.wrti 30 Sep 2002 18:24:37 -0000 1.25
+++ universal.wrti 30 Sep 2002 18:24:55 -0000 1.26
@@ -6,24 +6,27 @@
;;
;;;; @(#) $Id$
-;; Note the unfortunate dependency on ia32.
+(include ia32) ; Note the unfortunate dependency on ia32.
(ifndef _universal.wrti_ (define _universal.wrti_)
;; Stack manipulation
(macro dup
- (copy 0))
+ (stack>=! 1)
+ 0 dig)
(macro drop
(delete 0))
(macro swap
- (copy 1)
+ (stack>=! 2)
+ 1 dig
(delete 2))
(macro rot
- (copy 2)
+ (stack>=! 3)
+ 2 dig
(delete 3))
(macro -rot
@@ -39,14 +42,15 @@
swap tuck)
(macro dig
- (stack=! 1)
+ ; NOTE: the macro will only be used if regstack is not deep enough
+ 1 stack=!
(->reg 0)
(register)
,(mov ,0 (tetra %esp ,1 \tetras))
nip)
(macro bury
- (stack=! 2)
+ 2 stack=!
(->reg 0)
,(mov (tetra %esp ,0 \tetras) ,1)
drop drop)
@@ -91,15 +95,17 @@
drop drop)
(macro 2swap
- (copy 3)
+ (stack>=! 4)
+ 3 dig
(delete 4)
- (copy 3)
+ 3 dig
(delete 4))
(macro 2rot
- (copy 5)
+ (stack>=! 6)
+ 5 dig
(delete 6)
- (copy 5)
+ 5 dig
(delete 6))
(macro -2rot
@@ -110,9 +116,8 @@
0 until)
(macro jump
- (if-empty
- (,(ret))
- (,(jmp ,0)))
+ (stack>=! 1)
+ ,(jmp ,0)
,(\skip)
drop)
@@ -347,16 +352,23 @@
;; Arithmetics
(macro /mod
- (conform %eax %ebx)
+ $ %eax %ebx conform
,(sex %edx:eax %eax)
,(idiv %ebx)
- (believe %edx %eax))
-
- ;; These *names* are special: if the translator determines that these
- ;; operations can be performed at compile-time, it will happily do so.
+ believe %edx %eax)
- (macro + (->ureg 1) (->/expr 0) ,(add ,1 ,0) drop)
- (macro - (->ureg 1) (->/expr 0) ,(sub ,1 ,0) drop)
+ (macro + (->ureg 1) (->/expr 0)
+ dup 1 is? if
+ ,(inc ,1) drop
+ else
+ ,(add ,1 ,0) drop
+ then)
+ (macro - (->ureg 1) (->/expr 0)
+ dup 1 is? if
+ ,(dec ,1) drop
+ else
+ ,(sub ,1 ,0) drop
+ then)
(macro * (->ureg 1) (->/expr 0) ,(imul ,1 ,0) drop)
(macro / /mod nip)
(macro mod /mod drop)
@@ -365,13 +377,8 @@
(->ureg 0)
,(neg ,0))
- (macro 1+
- (->ureg 0)
- ,(inc ,0))
-
- (macro 1-
- (->ureg 0)
- ,(dec ,0))
+ (macro 1+ 1 +)
+ (macro 1- 1 -)
(macro 2*
1 lshift)
@@ -446,49 +453,49 @@
;; Operations on bit vectors
(macro lshift
- (if-int-const 0
- ((->ureg 1)
- ,(shl ,1 ,0))
- ((->reg 0 %ecx)
- (->ureg 1)
- ,(shl ,1 %cl)))
- drop)
+ (->ureg 1)
+ dup literal-integer? if
+ ,(shl ,1 ,0)
+ else
+ (->reg 0 %ecx)
+ ,(shl ,1 %cl)
+ then drop)
(macro rshift
- (if-int-const 0
- ((->ureg 1)
- ,(shr ,1 ,0))
- ((->reg 0 %ecx)
- (->ureg 1)
- ,(shr ,1 %cl)))
- drop)
+ (->ureg 1)
+ dup literal-integer? if
+ ,(shr ,1 ,0)
+ else
+ (->reg 0 %ecx)
+ ,(shr ,1 %cl)
+ then drop)
(macro arshift
- (if-int-const 0
- ((->ureg 1)
- ,(sar ,1 ,0))
- ((->reg 0 %ecx)
- (->ureg 1)
- ,(sar ,1 %cl)))
- drop)
+ (->ureg 1)
+ dup literal-integer? if
+ ,(sar ,1 ,0)
+ else
+ (->reg 0 %ecx)
+ ,(sar ,1 %cl)
+ then drop)
(macro rol
- (if-int-const 0
- ((->ureg 1)
- ,(rol ,1 ,0))
- ((->reg 0 %ecx)
- (->ureg 1)
- ,(rol ,1 %cl)))
- drop)
+ (->ureg 1)
+ dup literal-integer? if
+ ,(rol ,1 ,0)
+ else
+ (->reg 0 %ecx)
+ ,(rol ,1 %cl)
+ then drop)
(macro ror
- (if-int-const 0
- ((->ureg 1)
- ,(ror ,1 ,0))
- ((->reg 0 %ecx)
- (->ureg 1)
- ,(ror ,1 %cl)))
- drop)
+ (->ureg 1)
+ dup literal-integer? if
+ ,(ror ,1 ,0)
+ else
+ (->reg 0 %ecx)
+ ,(ror ,1 %cl)
+ then drop)
(macro bsf
(->ureg 0)
@@ -511,49 +518,58 @@
;; Syntax
+ (macro $
+ syn $ synstack)
+
(macro if
0 = ; booleanize and negate the condition
1 stack=! ; force calling convention
- gen-label dup ->synstack <if> ; generate the label
+ gen-label dup ->synstack syn <if> ; generate the label
?jump) ; jump as necessary
(macro else
- <if> annihilate ; check context
+ syn <if> annihilate ; check context
0 stack=! ; force calling convention
gen-label dup ->synstack
jump
- <-synstack <-synstack swap ->synstack <if> ; fetch the else-label
+ <-synstack <-synstack swap ->synstack syn <if> ; fetch the else-label
stick-label)
(macro then
- <if> annihilate ; check context
+ syn <if> annihilate ; check context
0 stack=! ; force calling convention
<-synstack
stick-label)
+ (macro unless
+ 0 = if)
+
(macro begin
- 0 stack=! gen-label dup ->synstack stick-label <begin>)
+ 0 stack=! gen-label dup ->synstack stick-label syn <begin>)
(macro until
0 = ; booleanize and negate the condition
1 stack=! ; force calling convention
- <begin> annihilate ; check context
+ syn <begin> annihilate ; check context
<-synstack ?jump) ; jump
(macro while
0 = ; booleanize and negate the condition
1 stack=! ; force calling convention
- <begin> annihilate ; check context
+ syn <begin> annihilate ; check context
gen-label dup ->synstack ; generate exit label
?jump ; jump
- <while>) ; establish new context
+ syn <while>) ; establish new context
(macro repeat
- 0 stack=! <while> annihilate
+ 0 stack=! syn <while> annihilate
<-synstack ; exit label
<-synstack ; start label
jump
stick-label)
+ (macro cond
+ syn <cond>)
+
(macro fra
- gen-label dup ->synstack <fra>)
+ gen-label dup ->synstack syn <fra>)
(macro here
- <fra> annihilate <-synstack stick-label)
+ syn <fra> annihilate <-synstack stick-label)
;; Memory calculations
@@ -634,39 +650,25 @@
(macro cell! tetra!)
(macro bytefill
- (conform %edi %ecx %eax)
- ,(cld)
- ,(rep)
- ,(stos %al)
- (believe))
+ $ %edi %ecx %eax conform .cld. .rep. .stos.b. believe)
- (macro fill bytefill) ; FIXME: drop this
+ (macro wydefill
+ $ %edi %ecx %eax conform .cld. .rep. .stos.w. believe)
(macro tetrafill
- (conform %edi %ecx %eax)
- ,(cld)
- ,(rep)
- ,(stos %eax)
- (believe))
+ $ %edi %ecx %eax conform .cld. .rep. .stos.t. believe)
(macro cellfill tetrafill)
(macro bytemove
- (conform %esi %edi %ecx)
- ,(cld)
- ,(rep)
- ,(movs \byte)
- (believe))
+ $ %esi %edi %ecx conform .cld. .rep. .movs.b. believe)
- (macro move bytemove) ; FIXME: drop this
+ (macro wydemove
+ $ %esi %edi %ecx conform .cld. .rep. .movs.w. believe)
(macro tetramove
- (conform %esi %edi %ecx)
- ,(cld)
- ,(rep)
- ,(movs \tetra)
- (believe))
+ $ %esi %edi %ecx conform .cld. .rep. .movs.t. believe)
(macro cellmove tetramove))
-; vim:ft=worth
+; vim: ft=worth
Index: wisptyp.wrti
===================================================================
RCS file: /cvsroot/wisp/wisp/modules/wisptyp.wrti,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -d -r1.19 -r1.20
--- wisptyp.wrti 26 Sep 2002 18:21:38 -0000 1.19
+++ wisptyp.wrti 30 Sep 2002 18:24:55 -0000 1.20
@@ -8,6 +8,8 @@
;; "ut" prefix denotes operations on untagged nodes
+(include ia32)
+
(ifndef _wisptyp.wrti_ (define _wisptyp.wrti_)
;; Cons manipulation
@@ -113,9 +115,13 @@
3 arshift)
(macro get-type
- dup 3 and if drop FALSE else
- dup NULL = if drop FALSE else
- cell@ then then)
+ cond dup 3 and if
+ drop FALSE
+ else dup NULL = if
+ drop FALSE
+ else
+ cell@
+ thens)
;; Type tags
@@ -138,24 +144,24 @@
;; Wisp calling convention
(macro wisp-prologue
- (believe %ecx))
+ believe %ecx)
(macro wisp-epilogue
- (stack=! 1)
+ 1 stack=!
(->reg 0 %eax)
- ,(ret)
+ .ret.
,(\skip))
(macro <:
fra)
(macro :>
- here (believe %eax))
+ here believe %eax)
(extern N_signal_argcount)
(macro argc
- 0= if (stack=! 1) (->reg 0 %ecx) 'N_signal_argcount jump then)
+ 0= if 1 stack=! (->reg 0 %ecx) 'N_signal_argcount jump then)
(extern raise$2)
@@ -169,10 +175,10 @@
(extern binary_mul)
(extern binary_div)
- (macro w+ <: -rot 2 (conform %ecx) 'binary_add jump :> (believe %eax))
- (macro w- <: -rot 2 (conform %ecx) 'binary_sub jump :> (believe %eax))
- (macro w* <: -rot 2 (conform %ecx) 'binary_mul jump :> (believe %eax))
- (macro w/ <: -rot 2 (conform %ecx) 'binary_div jump :> (believe %eax))
+ (macro w+ <: -rot 2 $ %ecx conform 'binary_add jump :> believe %eax)
+ (macro w- <: -rot 2 $ %ecx conform 'binary_sub jump :> believe %eax)
+ (macro w* <: -rot 2 $ %ecx conform 'binary_mul jump :> believe %eax)
+ (macro w/ <: -rot 2 $ %ecx conform 'binary_div jump :> believe %eax)
;; Records
@@ -181,15 +187,15 @@
(extern slot_accessor_body)
(macro go-discriminate ; takes: arg ... count rectype
- (conform %ecx %edx)
+ $ %ecx %edx conform
'discriminator_body jump)
(macro go-construct-record ; takes: arg ... count rectype
- (conform %ecx %edx)
+ $ %ecx %edx conform
'record_constructor_body jump)
(macro go-access-slot ; takes: arg ... count rectype index
- (conform %ecx %edx %ebx)
+ $ %ecx %edx %ebx conform
'slot_accessor_body jump))
; vim: ft=worth
|
|
From: <di...@us...> - 2002-09-30 18:24:58
|
Update of /cvsroot/wisp/wisp/src/native
In directory usw-pr-cvs1:/tmp/cvs-serv25684/src/native
Modified Files:
boxes.wth cons.wth death.wth misc.wth sys.wth vectors.wth
Log Message:
Created the beginnings of Worth-level assemblying.
Index: boxes.wth
===================================================================
RCS file: /cvsroot/wisp/wisp/src/native/boxes.wth,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -d -r1.9 -r1.10
--- boxes.wth 18 Sep 2002 21:18:04 -0000 1.9
+++ boxes.wth 30 Sep 2002 18:24:55 -0000 1.10
@@ -34,7 +34,7 @@
'RT_box go-construct-record)
(defun box_ref.final
- (believe %eax)
+ believe %eax
dup UNDEF = if drop 'WB_undefined swap go-raise then
nip
wisp-epilogue)
@@ -44,7 +44,7 @@
'RT_box 1 go-access-slot)
(native box_empty dup 1 = argc drop
- UNDEF -2 (stack=! 1) (->reg 0 %ecx) 'N_box_ref jump)
+ UNDEF -2 1 stack=! (->reg 0 %ecx) 'N_box_ref jump)
(native box_empty_huh dup 1 = argc drop
<: swap 1 'RT_box 1 go-access-slot :>
Index: cons.wth
===================================================================
RCS file: /cvsroot/wisp/wisp/src/native/cons.wth,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -d -r1.1 -r1.2
--- cons.wth 26 Aug 2002 15:59:43 -0000 1.1
+++ cons.wth 30 Sep 2002 18:24:55 -0000 1.2
@@ -16,7 +16,7 @@
(native cons
dup 2 = argc drop
(flush) ,cons$2 ; an extra entry point
- 8 GC_malloc (believe %eax) nip
+ 8 GC_malloc believe %eax nip
swap over utcdr!
swap over utcar!
tag-cons)
Index: death.wth
===================================================================
RCS file: /cvsroot/wisp/wisp/src/native/death.wth,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -d -r1.1 -r1.2
--- death.wth 4 Sep 2002 14:26:57 -0000 1.1
+++ death.wth 30 Sep 2002 18:24:55 -0000 1.2
@@ -12,7 +12,7 @@
(defun die ; one argument: a null-terminated string
drop ; we aren't going to return
- (flush) strlen (believe %eax)
+ (flush) strlen believe %eax
1 "wisp engine: " sys.write drop
1 -rot sys.write drop
1 "\n" sys.write drop
Index: misc.wth
===================================================================
RCS file: /cvsroot/wisp/wisp/src/native/misc.wth,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -d -r1.13 -r1.14
--- misc.wth 18 Sep 2002 21:18:04 -0000 1.13
+++ misc.wth 30 Sep 2002 18:24:55 -0000 1.14
@@ -108,14 +108,14 @@
; Note that |new| is not supposed to work in setter context.
(native new dup 0 > argc
- (stack=! 1) sp@ over cells + cell- dup cell@
+ 1 stack=! sp@ over cells + cell- dup cell@
dup require-record-type 5 cells + cell@
dup FALSE = if
drop 'WB_creatable_huh swap go-raise
then
nip swap 'immediate_return swap cell! ; fix the return address
swap 1- swap ; decrement argcount
- (conform %ecx %eax) ,(jmp funcall))
+ $ %ecx %eax conform ,(jmp funcall))
; The supposed usage of |%get-argument-list| and |%get-environment| is
; once, during the initialization phase of the run-time library.
Index: sys.wth
===================================================================
RCS file: /cvsroot/wisp/wisp/src/native/sys.wth,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -d -r1.14 -r1.15
--- sys.wth 18 Sep 2002 21:12:38 -0000 1.14
+++ sys.wth 30 Sep 2002 18:24:55 -0000 1.15
@@ -37,8 +37,8 @@
(macro encsi <: swap (flush) 'encsi$1 jump :>)
(macro encui <: swap (flush) 'encui$1 jump :>)
(macro salloc <: swap (flush) 'salloc$1 jump :>)
-(macro ws->zt (flush) ws2zt (believe %eax) nip)
-(macro zt->ws (flush) zt2ws (believe %eax) nip)
+(macro ws->zt (flush) ws2zt believe %eax nip)
+(macro zt->ws (flush) zt2ws believe %eax nip)
(macro cons <: -rot (flush) 'cons$2 jump :>)
@@ -183,15 +183,13 @@
NULL
then
; ( pid status res )
- over WIFEXITED if
+ cond over WIFEXITED if
swap WEXITSTATUS encui swap cons 'WB_exit swap cons
- else
- over WIFSTOPPED if
- swap WTERMSIG encui swap cons 'WB_stop swap cons
- else ; assume WIFSIGNALED
- swap WTERMSIG encui swap cons 'WB_signal swap cons
- then
- then
+ else over WIFSTOPPED if
+ swap WTERMSIG encui swap cons 'WB_stop swap cons
+ else ; assume WIFSIGNALED
+ swap WTERMSIG encui swap cons 'WB_signal swap cons
+ thens
swap encui swap cons
else
dup 0 = if
@@ -287,19 +285,15 @@
(native sys_low_tcsetattr dup 3 = argc drop
rot decui rot
- dup 'WB_now = if
+ cond dup 'WB_now = if
drop TCSETS
+ else dup 'WB_drain = if
+ drop TCSETSW
+ else dup 'WB_flush = if
+ drop TCSETSF
else
- dup 'WB_drain = if
- drop TCSETSW
- else
- dup 'WB_flush = if
- drop TCSETSF
- else
- 'WB_unknown swap go-raise
- then
- then
- then
+ 'WB_unknown swap go-raise
+ thens
rot require-c8string
sizeof.struct-termios require-string-length
string-data sys.ioctl (flush) 'encsi$1 jump)
@@ -364,7 +358,7 @@
begin over while
dup dirent.name zt->ws
over dirent.ino@ encui
- <: -rot 2 8 dig (conform %ecx %eax) ,(jmp funcall) :> (believe %eax)
+ <: -rot 2 8 dig $ %ecx %eax conform ,(jmp funcall) :> believe %eax
drop dup dirent.reclen@ swap over + -rot - swap
repeat
drop drop
@@ -376,7 +370,7 @@
(native sys_ns_execve dup 3 = argc drop
(flush) sp@ drop
rot ws->zt -rot
- (stack=! 3) ; so that all arguments are in registers
+ 3 stack=! ; so that all arguments are in registers
sp@ ; this is the stack pointer we're going to return with
(stack<=! 1)
; sp[-1 cells] is filename, sp[-2 cells] is argvp and
@@ -395,7 +389,7 @@
2swap ; (datum data sp len)
rot ; (datum sp len data)
repeat drop drop
- (stack=! 1) sp@ over 2 cells - cell!
+ 1 stack=! sp@ over 2 cells - cell!
; Process the environment:
0 swap
@@ -409,13 +403,13 @@
2swap ; (datum data sp len)
rot ; (datum sp len data)
repeat drop drop
- (stack=! 1) sp@ over 3 cells - cell!
+ 1 stack=! sp@ over 3 cells - cell!
dup dup dup ; (sp sp sp sp)
rot 1 cells - cell@
rot 2 cells - cell@
rot 3 cells - cell@
sys.execve swap ; (result sp)
- (stack=! 2) sp! (flush) 'encsi$1 jump)
+ 2 stack=! sp! (flush) 'encsi$1 jump)
; vim: ft=worth
Index: vectors.wth
===================================================================
RCS file: /cvsroot/wisp/wisp/src/native/vectors.wth,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -d -r1.4 -r1.5
--- vectors.wth 18 Sep 2002 21:18:04 -0000 1.4
+++ vectors.wth 30 Sep 2002 18:24:55 -0000 1.5
@@ -87,7 +87,7 @@
'RT_vector over cell! ; store type
tuck 1 cells + cell! ; store length
tuck swap ; (node node object)
- <: -rot 2 (conform %ecx) 'N_vector_fill jump :> (believe %eax)
+ <: -rot 2 $ %ecx conform 'N_vector_fill jump :> believe %eax
drop)
(native vector_move dup 5 = argc drop
|
|
From: <di...@us...> - 2002-09-30 18:24:58
|
Update of /cvsroot/wisp/wisp/doc/examples
In directory usw-pr-cvs1:/tmp/cvs-serv25684/doc/examples
Modified Files:
.cvsignore Makefile.am
Added Files:
bufinput.wth
Log Message:
Created the beginnings of Worth-level assemblying.
--- NEW FILE: bufinput.wth ---
;;;; bufinput.wth - buffered input
;;
;; Copyleft © 2002 by Andres Soolo (di...@us...)
;; This file is licensed under the GNU GPL v2. If you
;; don't know what that means, please do read the GPL.
;;
;;;; @(#) $Id: bufinput.wth,v 1.1 2002/09/30 18:24:55 digg Exp $
(include io)
(include linux)
(macro inbuf-size 80)
(macro instruc-size inbuf-size 4 +)
(macro instruc.start@ inbuf-size + byte@)
(macro instruc.start! inbuf-size + byte!)
(macro instruc.stop@ inbuf-size 1 + + byte@)
(macro instruc.stop! inbuf-size 1 + + byte!)
(macro instruc.eof@ inbuf-size 2 + + byte@)
(macro instruc.eof! inbuf-size 2 + + byte!)
(macro instruc.fd@ inbuf-size 3 + + byte@)
(macro instruc.fd! inbuf-size 3 + + byte!)
(macro init-instruc
0 over instruc.start!
0 over instruc.stop!
0 over instruc.eof!
0 swap instruc.fd!)
(macro shift-instruc
dup instruc.start@ dup if
over +
over dup dup instruc.start@ swap instruc.stop@ - bytemove
dup instruc.stop@ over instruc.start@ - over instruc.stop!
0 swap instruc.start!
else 2drop then)
(macro fill-instruc
dup instruc.eof@ unless
dup shift-instruc
dup dup instruc.stop@ 2dup + swap inbuf-size swap -
rot instruc.fd@ -rot sys.read
cond dup 0 > if
swap dup instruc.stop@ rot + swap instruc.stop!
else dup 0 = if
drop 1 swap instruc.eof!
else
negate hexprint " error occurred\n" type 1 sys.exit
thens
else
drop
then)
(macro EOF -1)
(defun instruc-getchar
swap
dup dup instruc.start@ swap instruc.stop@ u>= if
dup fill-instruc
then
dup dup instruc.start@ swap instruc.stop@ u< if
dup instruc.start@ 2dup + byte@ -rot 1+ swap instruc.start!
else
drop EOF
then
swap)
(macro whitespace? #\space <=)
(defun _start
instruc-size 0 allocate
dup init-instruc
begin dup instruc-getchar dup EOF <> while
dup dup #\space #\U+7F within over #\[ <> and over #\] <> and if
emit
else
#\[ emit
16 /mod emit-digit emit-digit #\] emit
then
#\newline = if cr then
repeat
"\nThe End\n" type)
; vim: ft=worth
Index: .cvsignore
===================================================================
RCS file: /cvsroot/wisp/wisp/doc/examples/.cvsignore,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -d -r1.2 -r1.3
--- .cvsignore 22 Jul 2002 14:36:47 -0000 1.2
+++ .cvsignore 30 Sep 2002 18:24:55 -0000 1.3
@@ -1,4 +1,11 @@
.*.swp
Makefile
Makefile.in
+angry
+argenv
+banana
+bufinput
+false
+foo*
gmon.out
+hello
Index: Makefile.am
===================================================================
RCS file: /cvsroot/wisp/wisp/doc/examples/Makefile.am,v
retrieving revision 1.38
retrieving revision 1.39
diff -u -d -r1.38 -r1.39
--- Makefile.am 30 Sep 2002 18:24:37 -0000 1.38
+++ Makefile.am 30 Sep 2002 18:24:55 -0000 1.39
@@ -6,16 +6,24 @@
#
#### @(#) $Id$
+WORTH_EXAMPLES = angry.wth argenv.wth banana.wth bufinput.wth \
+ false.wth hello.wth
+
EXTRA_DIST = closure.wisp quine.wisp signal.wisp \
rawkey.wisp \
find.wisp \
- hello.was hello.wth banana.wth false.wth angry.wth argenv.wth \
+ hello.was \
+ $(WORTH_EXAMPLES) \
.cvsignore
%: %.wth
WISP_PATH=$(top_srcdir)/modules $(top_builddir)/src/wisp \
$(top_srcdir)/tools/worth $<
+%.was: %.wth
+ WISP_PATH=$(top_srcdir)/modules $(top_builddir)/src/wisp \
+ $(top_srcdir)/tools/worth -III $<
+
exampledir = ${prefix}/share/doc/wisp/examples
install: install-dir install-readable
@@ -26,8 +34,7 @@
install-readable: closure.wisp quine.wisp signal.wisp \
rawkey.wisp \
find.wisp \
- hello.was hello.wth banana.wth false.wth angry.wth \
- argenv.wth
+ hello.was $(WORTH_EXAMPLES)
install -m644 $^ ${exampledir}
check: quine-check
|
|
From: <di...@us...> - 2002-09-30 18:24:58
|
Update of /cvsroot/wisp/wisp/doc In directory usw-pr-cvs1:/tmp/cvs-serv25684/doc Modified Files: worth.vim Log Message: Created the beginnings of Worth-level assemblying. Index: worth.vim =================================================================== RCS file: /cvsroot/wisp/wisp/doc/worth.vim,v retrieving revision 1.25 retrieving revision 1.26 diff -u -d -r1.25 -r1.26 --- worth.vim 26 Sep 2002 18:21:38 -0000 1.25 +++ worth.vim 30 Sep 2002 18:24:55 -0000 1.26 @@ -18,11 +18,13 @@ syn keyword worthPreproc assemble define defun extern ifdef ifndef syn keyword worthPreproc include macro native -syn keyword wispSyntax ->compstack ->reg ->ureg :> <-compstack <: ?jump -syn keyword wispSyntax again annihilate begin believe binary conform -syn keyword wispSyntax copy delete else flush gen-label if if-empty -syn keyword wispSyntax if-int-const register repeat stack<=! stack=! -syn keyword wispSyntax stack>=! stick-label then unless until while +syn keyword wispSyntax $ ->compstack ->reg ->ureg :> <-compstack <: +syn keyword wispSyntax ?jump again annihilate begin believe binary +syn keyword wispSyntax byte# cond conform copy delete else flush +syn keyword wispSyntax gen-label if if-empty if-int-const register +syn keyword wispSyntax regstack repeat stack<=! stack=! stack>=! +syn keyword wispSyntax stick-label syn synstack tetra# then thens +syn keyword wispSyntax unless until while wyde# syn keyword wispFunc * + - --byte@ --cell@ --tetra@ --wyde@ -2rot syn keyword wispFunc ->wisp-bool -rot / /mod 0= 1+ 1- 2* 2drop 2dup @@ -31,37 +33,37 @@ syn keyword wispFunc WSTOPSIG WTERMSIG abs and argc argc-argv-envp syn keyword wispFunc argv-envp arshift bsf bsr bury byte! byte@ byte@++ syn keyword wispFunc bytefill bytemove cell! cell+ cell- cell@ cell@++ -syn keyword wispFunc cellfill cellmove cells cr d+ d- d>s decons -syn keyword wispFunc dhexprint dig drop dup emit emit-digit -syn keyword wispFunc encode-digit fill get-type go-access-slot hexprint -syn keyword wispFunc lshift m+ max min mod move negate nip not octas or -syn keyword wispFunc over require-c8string require-cons -syn keyword wispFunc require-record-type require-string-length -syn keyword wispFunc require-vector rol ror rot rshift s>d sp! sp@ -syn keyword wispFunc space square string-data string-length swap -syn keyword wispFunc sys.accept sys.access sys.alarm sys.bind sys.brk -syn keyword wispFunc sys.chdir sys.chmod sys.chroot sys.close -syn keyword wispFunc sys.connect sys.creat sys.dup sys.dup2 sys.execve -syn keyword wispFunc sys.exit sys.fchdir sys.fchmod sys.fdatasync -syn keyword wispFunc sys.flock sys.fork sys.fstat sys.fsync -syn keyword wispFunc sys.ftruncate sys.getcwd sys.getdents sys.getegid -syn keyword wispFunc sys.geteuid sys.getgid sys.getpeername sys.getpgid -syn keyword wispFunc sys.getpgrp sys.getpid sys.getppid sys.getsid -syn keyword wispFunc sys.getsockname sys.getuid sys.ioctl sys.ioctl2 -syn keyword wispFunc sys.kill sys.link sys.listen sys.lseek sys.lstat -syn keyword wispFunc sys.mkdir sys.mlock sys.mlockall sys.munlock -syn keyword wispFunc sys.munlockall sys.nanosleep sys.nice sys.open -syn keyword wispFunc sys.pause sys.pipe sys.read sys.rename sys.rmdir -syn keyword wispFunc sys.select sys.setgid sys.setpgid sys.setregid -syn keyword wispFunc sys.setreuid sys.setsid sys.setuid sys.shutdown -syn keyword wispFunc sys.socket sys.stat sys.stime sys.swapoff -syn keyword wispFunc sys.swapon sys.symlink sys.sync sys.time -syn keyword wispFunc sys.truncate sys.umask sys.unlink sys.vhangup -syn keyword wispFunc sys.waitpid sys.write sys.write-char tetra! tetra+ -syn keyword wispFunc tetra- tetra@ tetra@++ tetrafill tetramove tetras -syn keyword wispFunc tuck type u< u<= u> u>= vector-data vector-length -syn keyword wispFunc wisp-bool-> wisp-epilogue wisp-prologue within -syn keyword wispFunc wyde! wyde+ wyde- wyde@ wyde@++ wydes xor +syn keyword wispFunc cellfill cellmove cells cr d+ d- d>s decode-digit +syn keyword wispFunc decons dhexprint dig drop dup emit emit-digit +syn keyword wispFunc encode-digit get-type go-access-slot hexprint +syn keyword wispFunc lshift m+ max min mod negate nip not octas or over +syn keyword wispFunc require-c8string require-cons require-record-type +syn keyword wispFunc require-string-length require-vector rol ror rot +syn keyword wispFunc rshift s>d sp! sp@ space square string-data +syn keyword wispFunc string-length swap sys.accept sys.access sys.alarm +syn keyword wispFunc sys.bind sys.brk sys.chdir sys.chmod sys.chroot +syn keyword wispFunc sys.close sys.connect sys.creat sys.dup sys.dup2 +syn keyword wispFunc sys.execve sys.exit sys.fchdir sys.fchmod +syn keyword wispFunc sys.fdatasync sys.flock sys.fork sys.fstat +syn keyword wispFunc sys.fsync sys.ftruncate sys.getcwd sys.getdents +syn keyword wispFunc sys.getegid sys.geteuid sys.getgid sys.getpeername +syn keyword wispFunc sys.getpgid sys.getpgrp sys.getpid sys.getppid +syn keyword wispFunc sys.getsid sys.getsockname sys.getuid sys.ioctl +syn keyword wispFunc sys.ioctl2 sys.kill sys.link sys.listen sys.lseek +syn keyword wispFunc sys.lstat sys.mkdir sys.mlock sys.mlockall +syn keyword wispFunc sys.munlock sys.munlockall sys.nanosleep sys.nice +syn keyword wispFunc sys.open sys.pause sys.pipe sys.read sys.rename +syn keyword wispFunc sys.rmdir sys.select sys.setgid sys.setpgid +syn keyword wispFunc sys.setregid sys.setreuid sys.setsid sys.setuid +syn keyword wispFunc sys.shutdown sys.socket sys.stat sys.stime +syn keyword wispFunc sys.swapoff sys.swapon sys.symlink sys.sync +syn keyword wispFunc sys.time sys.truncate sys.umask sys.unlink +syn keyword wispFunc sys.vhangup sys.waitpid sys.write sys.write-char +syn keyword wispFunc tetra! tetra+ tetra- tetra@ tetra@++ tetrafill +syn keyword wispFunc tetramove tetras tuck type u< u<= u> u>= +syn keyword wispFunc vector-data vector-length wisp-bool-> +syn keyword wispFunc wisp-epilogue wisp-prologue within wyde! wyde+ +syn keyword wispFunc wyde- wyde@ wyde@++ wydefill wydemove wydes xor " structure management |
|
From: <di...@us...> - 2002-09-30 18:24:41
|
Update of /cvsroot/wisp/wisp/doc/examples
In directory usw-pr-cvs1:/tmp/cvs-serv25589/doc/examples
Modified Files:
Makefile.am
Log Message:
Fixed Worth's handling of binary operators with constant arguments.
Index: Makefile.am
===================================================================
RCS file: /cvsroot/wisp/wisp/doc/examples/Makefile.am,v
retrieving revision 1.37
retrieving revision 1.38
diff -u -d -r1.37 -r1.38
--- Makefile.am 18 Sep 2002 21:14:23 -0000 1.37
+++ Makefile.am 30 Sep 2002 18:24:37 -0000 1.38
@@ -12,6 +12,10 @@
hello.was hello.wth banana.wth false.wth angry.wth argenv.wth \
.cvsignore
+%: %.wth
+ WISP_PATH=$(top_srcdir)/modules $(top_builddir)/src/wisp \
+ $(top_srcdir)/tools/worth $<
+
exampledir = ${prefix}/share/doc/wisp/examples
install: install-dir install-readable
|
|
From: <di...@us...> - 2002-09-30 18:24:41
|
Update of /cvsroot/wisp/wisp/modules
In directory usw-pr-cvs1:/tmp/cvs-serv25589/modules
Modified Files:
universal.wrti
Log Message:
Fixed Worth's handling of binary operators with constant arguments.
Index: universal.wrti
===================================================================
RCS file: /cvsroot/wisp/wisp/modules/universal.wrti,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -d -r1.24 -r1.25
--- universal.wrti 26 Sep 2002 18:22:46 -0000 1.24
+++ universal.wrti 30 Sep 2002 18:24:37 -0000 1.25
@@ -446,24 +446,22 @@
;; Operations on bit vectors
(macro lshift
- (binary lshift
- (if-int-const 0
- ((->ureg 1)
- ,(shl ,1 ,0))
- ((->reg 0 %ecx)
- (->ureg 1)
- ,(shl ,1 %cl)))
- drop))
+ (if-int-const 0
+ ((->ureg 1)
+ ,(shl ,1 ,0))
+ ((->reg 0 %ecx)
+ (->ureg 1)
+ ,(shl ,1 %cl)))
+ drop)
(macro rshift
- (binary rshift
- (if-int-const 0
- ((->ureg 1)
- ,(shr ,1 ,0))
- ((->reg 0 %ecx)
- (->ureg 1)
- ,(shr ,1 %cl)))
- drop))
+ (if-int-const 0
+ ((->ureg 1)
+ ,(shr ,1 ,0))
+ ((->reg 0 %ecx)
+ (->ureg 1)
+ ,(shr ,1 %cl)))
+ drop)
(macro arshift
(if-int-const 0
|
|
From: <di...@us...> - 2002-09-30 18:24:41
|
Update of /cvsroot/wisp/wisp/tools
In directory usw-pr-cvs1:/tmp/cvs-serv25589/tools
Modified Files:
worth
Log Message:
Fixed Worth's handling of binary operators with constant arguments.
Index: worth
===================================================================
RCS file: /cvsroot/wisp/wisp/tools/worth,v
retrieving revision 1.34
retrieving revision 1.35
diff -u -d -r1.34 -r1.35
--- worth 26 Sep 2002 18:22:47 -0000 1.34
+++ worth 30 Sep 2002 18:24:37 -0000 1.35
@@ -703,7 +703,7 @@
(my (b a . rest) regstack
(set! regstack
(cons
- (case oper
+ (case word
((+) (+ a b))
((-) (- a b))
((*) (* a b))
@@ -714,7 +714,7 @@
b)))
((rshift) (>> (reduce-to-utetra a)
b))
- (else (raise 'binary-operator? oper)))
+ (else (raise 'huh? word)))
rest))))
(else
(raise 'huh? word))))
|
