From 81e8afedceb3b8b1e7e18b8946931b31008d1d19 Mon Sep 17 00:00:00 2001 From: Lassi Kortela Date: Fri, 5 Aug 2022 12:28:40 +0300 Subject: [PATCH] GScheme-20020806.tar --- Document.h | 53 + Document.m | 237 ++ EnvWindow.h | 24 + EnvWindow.m | 134 + GNUmakefile | 37 + GScheme.app/GScheme | 218 ++ GScheme.app/Resources/GScheme.desktop | 8 + GScheme.app/Resources/Info-gnustep.plist | 29 + GScheme.app/Resources/library.scm | 109 + GScheme.app/Resources/library.scm~ | 103 + GSchemeInfo.plist | 19 + Primitive.h | 249 ++ Primitive.m | 1566 ++++++++++++ SCMTextView.h | 31 + SCMTextView.m | 155 ++ Scheme/library.scm | 109 + Scheme/library.scm~ | 103 + SchemeDelegate.h | 39 + SchemeDelegate.m | 462 ++++ SchemeTypes.h | 316 +++ SchemeTypes.m | 864 +++++++ TestScheme.app/Resources/Info-gnustep.plist | 6 + TestScheme.app/Resources/TestScheme.desktop | 5 + TestScheme.app/TestScheme | 218 ++ USAGE | 40 + VScheme.h | 120 + VScheme.m | 1722 +++++++++++++ examples/allocate.scm | 23 + examples/and-or.scm | 10 + examples/browse.scm | 35 + examples/call-cc.scm | 11 + examples/call-cc1.scm | 15 + examples/case.scm | 13 + examples/characters.scm | 15 + examples/circle.scm | 55 + examples/circular.scm | 19 + examples/cond.scm | 28 + examples/deep-recursion.scm | 11 + examples/eq-mem-association.scm | 10 + examples/factorial.scm | 16 + examples/koch-curve.scm | 27 + examples/let-over-lambda.scm | 3 + examples/letrec.scm | 11 + examples/library.scm | 109 + examples/list-misc.scm | 12 + examples/misc.scm | 4 + examples/plotter.scm | 26 + examples/primes.scm | 32 + examples/queens.scm | 103 + examples/reduce.scm | 8 + examples/rootfinder.scm | 32 + examples/simple.scm | 13 + examples/tail-recursion.scm | 7 + lex.yy.c | 1939 ++++++++++++++ main.m | 64 + php/scheme.php | 2562 +++++++++++++++++++ scheme.flex | 210 ++ scheme.lex.m | 1939 ++++++++++++++ scheme.tab.m | 1614 ++++++++++++ scheme.tab.m.h | 34 + scheme.y | 369 +++ scratch/allocate.scm | 18 + scratch/allocate.scm~ | 18 + test/classes.m | 12 + test/classes.m~ | 15 + test/commands.txt | 1 + test/compileit | 26 + test/compileit~ | 26 + test/sscanf | Bin 0 -> 13739 bytes test/sscanf.c | 13 + test/test.m | 15 + test/test.m~ | 15 + test/testschemeparser.c~ | 18 + testscheme.m | 186 ++ 74 files changed, 16718 insertions(+) create mode 100644 Document.h create mode 100644 Document.m create mode 100644 EnvWindow.h create mode 100644 EnvWindow.m create mode 100644 GNUmakefile create mode 100755 GScheme.app/GScheme create mode 100644 GScheme.app/Resources/GScheme.desktop create mode 100644 GScheme.app/Resources/Info-gnustep.plist create mode 100644 GScheme.app/Resources/library.scm create mode 100644 GScheme.app/Resources/library.scm~ create mode 100644 GSchemeInfo.plist create mode 100644 Primitive.h create mode 100644 Primitive.m create mode 100644 SCMTextView.h create mode 100644 SCMTextView.m create mode 100644 Scheme/library.scm create mode 100644 Scheme/library.scm~ create mode 100644 SchemeDelegate.h create mode 100644 SchemeDelegate.m create mode 100644 SchemeTypes.h create mode 100644 SchemeTypes.m create mode 100644 TestScheme.app/Resources/Info-gnustep.plist create mode 100644 TestScheme.app/Resources/TestScheme.desktop create mode 100755 TestScheme.app/TestScheme create mode 100644 USAGE create mode 100644 VScheme.h create mode 100644 VScheme.m create mode 100644 examples/allocate.scm create mode 100644 examples/and-or.scm create mode 100644 examples/browse.scm create mode 100644 examples/call-cc.scm create mode 100644 examples/call-cc1.scm create mode 100644 examples/case.scm create mode 100644 examples/characters.scm create mode 100644 examples/circle.scm create mode 100644 examples/circular.scm create mode 100644 examples/cond.scm create mode 100644 examples/deep-recursion.scm create mode 100644 examples/eq-mem-association.scm create mode 100644 examples/factorial.scm create mode 100644 examples/koch-curve.scm create mode 100644 examples/let-over-lambda.scm create mode 100644 examples/letrec.scm create mode 100644 examples/library.scm create mode 100644 examples/list-misc.scm create mode 100644 examples/misc.scm create mode 100644 examples/plotter.scm create mode 100644 examples/primes.scm create mode 100644 examples/queens.scm create mode 100644 examples/reduce.scm create mode 100644 examples/rootfinder.scm create mode 100644 examples/simple.scm create mode 100644 examples/tail-recursion.scm create mode 100644 lex.yy.c create mode 100644 main.m create mode 100644 php/scheme.php create mode 100644 scheme.flex create mode 100644 scheme.lex.m create mode 100644 scheme.tab.m create mode 100644 scheme.tab.m.h create mode 100644 scheme.y create mode 100644 scratch/allocate.scm create mode 100644 scratch/allocate.scm~ create mode 100644 test/classes.m create mode 100644 test/classes.m~ create mode 100644 test/commands.txt create mode 100755 test/compileit create mode 100755 test/compileit~ create mode 100755 test/sscanf create mode 100644 test/sscanf.c create mode 100644 test/test.m create mode 100644 test/test.m~ create mode 100644 test/testschemeparser.c~ create mode 100644 testscheme.m diff --git a/Document.h b/Document.h new file mode 100644 index 0000000..1738694 --- /dev/null +++ b/Document.h @@ -0,0 +1,53 @@ +/* Document.h Subclass of NSDocument for GScheme application + + Copyright (C) 2000 Free Software Foundation, Inc. + + Author: Fred Kiefer + Date: 2000. + + Adapted by: Marko Riedel . + Date: 2002. + + This file is part of GNUstep. + + 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., 675 Mass Ave, Cambridge, MA 02139, USA. + */ +#import +#import +#import +#import + +@interface Document : NSDocument +{ + NSTextView *tview; + NSString *progstr; + BOOL readOnly; +} + +- init; + +- (void)dealloc; + +- (void)makeWindowControllers; + +- evaluate:(id)sender; + +- (NSData *)dataRepresentationOfType:(NSString *)aType; +- (BOOL)loadDataRepresentation:(NSData *)data ofType:(NSString *)aType; + +- (BOOL)readFromFile:(NSString *)fileName ofType:(NSString *)docType; +- (BOOL)writeToFile:(NSString *)fileName ofType:(NSString *)docType; + +@end diff --git a/Document.m b/Document.m new file mode 100644 index 0000000..100f780 --- /dev/null +++ b/Document.m @@ -0,0 +1,237 @@ +/* Document.m Subclass of NSDocument for GScheme application + + Copyright (C) 2000 Free Software Foundation, Inc. + + Author: Fred Kiefer + Date: 2000. + + Adapted by: Marko Riedel . + Date: 2002. + + This file is part of GNUstep. + + 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., 675 Mass Ave, Cambridge, MA 02139, USA. + */ +#include +#include +#include "Document.h" +#include "SCMTextView.h" + +@interface Document (Private) + +- (NSWindow*)makeWindow; + +@end + +@implementation Document + +- init +{ + progstr = @"\n"; + return [super init]; +} + +- (void)dealloc +{ + // RELEASE (tview); + [super dealloc]; +} + +- (NSData *)dataRepresentationOfType:(NSString *)aType +{ + if(aType==nil || [aType isEqualToString:@"scm"]){ + return [[tview string] dataUsingEncoding:NSASCIIStringEncoding]; + } + else{ + NSString *msg = [NSString stringWithFormat: @"Unknown type: %@", + [aType uppercaseString]]; + NSRunAlertPanel(@"Alert", msg, @"Ok", nil, nil); + // [msg autorelease]; + return nil; + } +} + +- (BOOL)loadDataRepresentation:(NSData *)data ofType:(NSString *)aType +{ + if([aType isEqualToString:@"scm"]){ + progstr = [NSString stringWithCString:[data bytes] + length:[data length]]; + } + else{ + NSString *msg = [NSString stringWithFormat: @"Unknown type: %@", + [aType uppercaseString]]; + NSRunAlertPanel(@"Alert", msg, @"Ok", nil, nil); + // [msg autorelease]; + return NO; + } + + return YES; +} + + +- (BOOL)readFromFile:(NSString *)fileName ofType:(NSString *)docType +{ + NSFileManager *manager = [NSFileManager defaultManager]; + if([manager isWritableFileAtPath:fileName]==NO){ + NSString *msg = [NSString stringWithFormat: @"File is read only: %@", + fileName]; + readOnly = YES; + + NSRunAlertPanel(@"Alert", msg, @"Ok", nil, nil); + // [msg autorelease]; + } + + return [super readFromFile:fileName ofType:docType]; +} + +- (BOOL)writeToFile:(NSString *)fileName ofType:(NSString *)docType +{ + BOOL result = [super writeToFile:fileName ofType:docType]; + if(result==YES && readOnly==YES){ + NSString *msg = [NSString stringWithFormat: @"File now writable: %@", + fileName]; + NSRunAlertPanel(@"Alert", msg, @"Ok", nil, nil); + // [msg autorelease]; + + readOnly = NO; + [tview setEditable:YES]; + } + else if(result==NO){ + NSString *msg = [NSString stringWithFormat: @"Write failed: %@", + fileName]; + NSRunAlertPanel(@"Alert", msg, @"Ok", nil, nil); + // [msg autorelease]; + } + + return result; +} + +extern VScheme *vm; +extern NSWindow *interpreterWindow; + +- evaluate:(id)sender +{ + BOOL res; + SCMInteractive *intView = + [[interpreterWindow contentView] documentView]; + NSString *suffix = [intView getSuffix]; + + if([suffix length]>0){ + [intView appendString:@"\n> "]; + } + + progstr = [tview string]; + res = [vm processString:progstr mode:MODE_EVALUATE]; + + if(res==NO){ + NSRunAlertPanel(@"Error", [vm errmsg], + @"Ok", nil, nil); + } + else{ + [interpreterWindow makeKeyAndOrderFront:self]; + } +} + +- (void) makeWindowControllers +{ + NSWindowController *controller; + NSWindow *win = [self makeWindow]; + + controller = [[NSWindowController alloc] initWithWindow: win]; + // RELEASE (win); + [self addWindowController:controller]; + // RELEASE(controller); + + // We have to do this ourself, as there is currently no nib file + [self windowControllerDidLoadNib:controller]; +} + + +@end + +@implementation Document (Private) + +static int shiftPos = 0; +#define WREP 7 + +- (NSWindow*)makeWindow +{ + NSWindow *window; + NSScrollView *scrollView; + NSTextView *textView; + NSRect scrollViewRect = {{0, 0}, {470, 400}}; + NSRect winRect = {{100+25*(shiftPos%WREP), 100+25*(shiftPos%WREP)}, + {470, 400}}; + NSRect textRect; + unsigned int style = NSTitledWindowMask | NSClosableWindowMask | + NSMiniaturizableWindowMask | NSResizableWindowMask; + shiftPos++; + + // This is expected to be retained, as it would normaly come from a + // nib file, where the owner would retain it. + window = [[NSWindow alloc] initWithContentRect: winRect + styleMask: style + backing: NSBackingStoreRetained + defer: NO]; + [window setMinSize:NSMakeSize(300, 300)]; + + scrollView = [[NSScrollView alloc] initWithFrame: scrollViewRect]; + [scrollView setHasHorizontalScroller: NO]; + [scrollView setHasVerticalScroller: YES]; + [scrollView setAutoresizingMask: NSViewHeightSizable | NSViewWidthSizable]; + [[scrollView contentView] setAutoresizingMask: NSViewHeightSizable + | NSViewWidthSizable]; + [[scrollView contentView] setAutoresizesSubviews:YES]; + + // Build up the text network + textRect = [[scrollView contentView] frame]; + textView = [[SCMTextView alloc] initWithFrame: textRect]; + + [textView setBackgroundColor: [NSColor whiteColor]]; + + [textView setString:progstr]; + [textView setFont:[NSFont userFixedPitchFontOfSize:12]]; + [textView setEditable:(readOnly==NO ? YES : NO)]; + + [textView setDelegate: self]; + [textView setHorizontallyResizable: NO]; + [textView setVerticallyResizable: YES]; + [textView setMinSize: NSMakeSize (0, 0)]; + [textView setMaxSize: NSMakeSize (1E7, 1E7)]; + [textView setAutoresizingMask: NSViewHeightSizable | NSViewWidthSizable]; + [[textView textContainer] setContainerSize: NSMakeSize (textRect.size.width, + 1e7)]; + [[textView textContainer] setWidthTracksTextView: YES]; + // Store the text view in an ivar + tview = textView; + + [scrollView setDocumentView: textView]; + // RELEASE(textView); + [window setContentView: scrollView]; + // RELEASE(scrollView); + + // Make the Document the delegate of the window + [window setDelegate: self]; + + // Make the text view the first responder + [window makeFirstResponder:textView]; + [window display]; + [window orderFront: nil]; + + return window; +} + + +@end diff --git a/EnvWindow.h b/EnvWindow.h new file mode 100644 index 0000000..1d619e1 --- /dev/null +++ b/EnvWindow.h @@ -0,0 +1,24 @@ +#import +#import + +#import "SchemeTypes.h" + +@interface EnvWindow : NSWindow +{ + int current; + int length; + + id *forms; + + NSScrollView *scrollView; +} + +- initWithEnv:(Environment *)env; + +- up:(id)sender; +- down:(id)sender; + +- releaseForms; + +@end + diff --git a/EnvWindow.m b/EnvWindow.m new file mode 100644 index 0000000..f54af3c --- /dev/null +++ b/EnvWindow.m @@ -0,0 +1,134 @@ + +#import "EnvWindow.h" +#import "VScheme.h" + +@implementation EnvWindow + +#define WIDTH 300 +#define HEIGHT 200 + +static int count = 0; +- initWithEnv:(Environment *)env +{ + NSWindow *window; + Environment *layer; int lind; + NSRect scrollViewRect = {{0, 0}, {WIDTH, HEIGHT}}; + NSRect winRect = + {{250+(count%12)*24, 100+(count%12)*24}, {WIDTH, HEIGHT}}; + NSRect textRect; + unsigned int style = NSTitledWindowMask | NSClosableWindowMask | + NSMiniaturizableWindowMask | NSResizableWindowMask; + NSString *title = + [NSString stringWithFormat:@"Scheme Env. # %d", ++count]; + + length = [env chainLength]; current=length-1; + forms = NSZoneMalloc([self zone], length*sizeof(id)); + + for(lind=length-1, layer = env; lind>=0; lind--){ + NSMutableDictionary *data = [layer data]; + NSMutableArray *keys; + NSEnumerator *en; + id key, form; + + keys = [NSMutableArray arrayWithCapacity:1]; + [keys setArray:[data allKeys]]; + [keys sortUsingSelector:@selector(compare:)]; + + en = [keys objectEnumerator]; + + + forms[lind] = form = + [[NSForm alloc] initWithFrame:scrollViewRect]; + while((key = [en nextObject])!=nil){ + id obj = [data objectForKey:key]; + id ctitle = [NSString stringWithFormat:@" %@ ", key]; + id cell = [form addEntry:ctitle]; + + [cell setEditable:NO]; + [cell setEnabled:NO]; + [cell setStringValue:[VScheme valToString:obj]]; + } + + [form setEntryWidth:WIDTH]; + [form setAutosizesCells:YES]; + [form setAutoresizingMask:NSViewWidthSizable]; + + // [form retain]; + + layer = [layer parent]; + } + + [self initWithContentRect:winRect + styleMask:style + backing:NSBackingStoreRetained + defer:NO]; + [self setMinSize:NSMakeSize(WIDTH, HEIGHT)]; + [self setReleasedWhenClosed:YES]; + + scrollView = [[NSScrollView alloc] initWithFrame: scrollViewRect]; + [scrollView setHasHorizontalScroller:YES]; + [scrollView setHasVerticalScroller:YES]; + [scrollView setAutoresizingMask: NSViewHeightSizable | NSViewWidthSizable]; + [[scrollView contentView] setAutoresizingMask: NSViewHeightSizable + | NSViewWidthSizable]; + [[scrollView contentView] setAutoresizesSubviews:YES]; + + [scrollView setDocumentView:forms[current]]; + + [self setContentView:scrollView]; + // RELEASE(scrollView); + + [self setTitle:title]; + [self display]; + [self makeKeyAndOrderFront:nil]; + + return self; +} + +- up:(id)sender +{ + if(!current){ + NSBeep(); + } + else{ + NSRect bounds = [forms[current] bounds]; + current--; + [forms[current] setEntryWidth:bounds.size.width]; + [scrollView setDocumentView:forms[current]]; + } + + return self; +} + +- down:(id)sender +{ + if(current==length-1){ + NSBeep(); + } + else{ + NSRect bounds = [forms[current] bounds]; + current++; + [forms[current] setEntryWidth:bounds.size.width]; + [scrollView setDocumentView:forms[current]]; + } + + return self; +} + +- releaseForms +{ + int ind; + + [scrollView setDocumentView:nil]; + [scrollView release]; + + for(ind=0; ind +# Date: May 1999 +# +# This file is part of the GNUstep Makefile Package. +# +# This library 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. +# +# You should have received a copy of the GNU General Public +# License along with this library; see the file COPYING.LIB. +# If not, write to the Free Software Foundation, +# 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +# This is a shell script which attempts to find the GNUstep executable +# of the same name based on the current host and library_combo. + +#-------------------------------------------------------------------------- +# Main body +#-------------------------------------------------------------------------- +if [ -z "$EXEEXT" ]; then + EXEEXT= +fi +if [ -z "$LIBRARY_COMBO" ]; then + LIBRARY_COMBO=gnu-gnu-gnu +fi + +# Process arguments +app=$0 +show_available_platforms=0 +show_relative_path=0 +show_full_path=0 +while true +do + case $1 in + + --script-help) + echo usage: `basename $0` [--library-combo=...] + echo " [--available-platforms][--full-executable-path]" + echo " [--relative-executable-path] [arguments...]" + echo + echo " --library-combo=... specifies a GNUstep backend to use." + echo " It overrides the default LIBRARY_COMBO environment variable." + echo + echo " --available-platforms displays a list of valid exec hosts" + echo " --full-executable-path displays full path to executable" + echo " --relative-executable-path displays subdirectory path" + echo " arguments... are the arguments to the application." + exit 0 + ;; + --library-combo=*) + LIBRARY_COMBO=`echo $1 | sed 's/--library-combo=//'` + shift + ;; + --available-platforms) + show_available_platforms=1 + exit 0 + ;; + --full-executable-path) + show_full_path=1 + break + ;; + --relative-executable-path) + show_relative_path=1 + break + ;; + *) + break;; + esac +done + +if [ "$LIBRARY_COMBO" = nx ]; then + LIBRARY_COMBO=nx-nx-nx +elif [ "$LIBRARY_COMBO" = gnu ]; then + LIBRARY_COMBO=gnu-gnu-gnu +elif [ "$LIBRARY_COMBO" = fd ]; then + LIBRARY_COMBO=gnu-fd-gnu +fi +export LIBRARY_COMBO + +# Find path to ourself +app=`echo $app | sed 's%/*$%%'` +dir=`dirname $app` + +case $app in + /*) # An absolute path. + full_appname=$dir;; + */*) # A relative path + full_appname=`(cd $dir; pwd)`;; + *) # A path that needs to be searched + if [ -n $GNUSTEP_PATHPREFIX_LIST ]; then + SPATH=$GNUSTEP_PATHPREFIX_LIST + else + SPATH=$PATH + fi + SPATH=.:$SPATH + IFS=: + for path_dir in $SPATH; do + if [ -d $path_dir/$dir ]; then + full_appname=`(cd $path_dir/$dir; pwd)` + break; + fi + if [ -d $path_dir/Applications/$dir ]; then + full_appname=`(cd $path_dir/Applications/$dir; pwd)` + break; + fi + done;; +esac + +if [ -z "$full_appname" ]; then + echo "Can't find absolute path for $app! Please specify full path when" + echo "invoking executable" + exit 1 +fi + +# +# get base app name +# +app=`echo $app | sed 's/\.[a-z]*$//'` +app=`basename $app` +appname= +if [ -f "$full_appname/Resources/Info-gnustep.plist" ]; then +# -n disable auto-print (for portability reasons) +# /^ *NSExecutable *=/ matches every line beginning with +# zero or more spaces, followed by 'NSExecutable', followed by zero or +# more spaces, followed by '=' +# to this line we apply the following commands: +# s/"//g; which deletes all " in the line. +# s/^ *NSExecutable *= *\([^ ;]*\) *;.*/\1/p; +# which replaces 'NSExecutable = Gorm; ' with 'Gorm', then, because +# of the 'p' at the end, prints out the result +# q; which quits sed since we know there must be only a single line +# to replace. + appname=`sed -n -e '/^ *NSExecutable *=/ \ + {s/"//g; s/^ *NSExecutable *= *\([^ ;]*\) *;.*/\1/p; q;}' \ + "$full_appname/Resources/Info-gnustep.plist"` +fi +if [ -z "$appname" ]; then + appname=$app +fi + +appname="$appname$EXEEXT" + +if [ $show_available_platforms = 1 ]; then + cd $full_appname + #available_platforms + exit 0 +fi + +# +# Determine the host information +# +if [ -z "$GNUSTEP_HOST" ]; then + GNUSTEP_HOST=`(cd /tmp; $GNUSTEP_SYSTEM_ROOT/Makefiles/config.guess)` + GNUSTEP_HOST=`(cd /tmp; $GNUSTEP_SYSTEM_ROOT/Makefiles/config.sub $GNUSTEP_HOST)` + export GNUSTEP_HOST +fi +if [ -z "$GNUSTEP_HOST_CPU" ]; then + GNUSTEP_HOST_CPU=`$GNUSTEP_SYSTEM_ROOT/Makefiles/cpu.sh $GNUSTEP_HOST` + GNUSTEP_HOST_CPU=`$GNUSTEP_SYSTEM_ROOT/Makefiles/clean_cpu.sh $GNUSTEP_HOST_CPU` + export GNUSTEP_HOST_CPU +fi +if [ -z "$GNUSTEP_HOST_VENDOR" ]; then + GNUSTEP_HOST_VENDOR=`$GNUSTEP_SYSTEM_ROOT/Makefiles/vendor.sh $GNUSTEP_HOST` + GNUSTEP_HOST_VENDOR=`$GNUSTEP_SYSTEM_ROOT/Makefiles/clean_vendor.sh $GNUSTEP_HOST_VENDOR` + export GNUSTEP_HOST_VENDOR +fi +if [ -z "$GNUSTEP_HOST_OS" ]; then + GNUSTEP_HOST_OS=`$GNUSTEP_SYSTEM_ROOT/Makefiles/os.sh $GNUSTEP_HOST` + GNUSTEP_HOST_OS=`$GNUSTEP_SYSTEM_ROOT/Makefiles/clean_os.sh $GNUSTEP_HOST_OS` + export GNUSTEP_HOST_OS +fi + +# +# Make sure the executable is there +# +if [ -x $full_appname/$GNUSTEP_HOST_CPU/$GNUSTEP_HOST_OS/$LIBRARY_COMBO/$appname ]; then + relative_path=$GNUSTEP_HOST_CPU/$GNUSTEP_HOST_OS/$LIBRARY_COMBO/$appname +elif [ -x $full_appname/$GNUSTEP_HOST_CPU/$GNUSTEP_HOST_OS/$appname ]; then + relative_path=$GNUSTEP_HOST_CPU/$GNUSTEP_HOST_OS/$appname +elif [ -x $full_appname/$GNUSTEP_HOST_CPU/$appname ]; then + relative_path=$GNUSTEP_HOST_CPU/$appname +elif [ $appname != $app -a -x $full_appname/$appname ]; then + relative_path=$appname +else + echo "$full_appname application does not have a binary for this kind of machine/operating system ($GNUSTEP_HOST_CPU/$GNUSTEP_HOST_OS)." + exit 1 +fi + +if [ $show_relative_path = 1 ]; then + echo $relative_path + exit 0 +fi +if [ $show_full_path = 1 ]; then + echo $full_appname/$relative_path + exit 0 +fi + +if [ "$LIBRARY_COMBO" = nx-nx-nx -a $GNUSTEP_HOST_OS = nextstep4 ]; then + if [ -f "$full_appname/library_paths.openapp" ]; then + additional_library_paths="`cat $full_appname/library_paths.openapp`" + fi +else + if [ -f "$full_appname/$GNUSTEP_HOST_CPU/$GNUSTEP_HOST_OS/$LIBRARY_COMBO/library_paths.openapp" ]; then + additional_library_paths="`cat $full_appname/$GNUSTEP_HOST_CPU/$GNUSTEP_HOST_OS/$LIBRARY_COMBO/library_paths.openapp`" + fi +fi + +# Load up LD_LIBRARY_PATH +. $GNUSTEP_SYSTEM_ROOT/Makefiles/ld_lib_path.sh + +exec $full_appname/$relative_path "$@" + diff --git a/GScheme.app/Resources/GScheme.desktop b/GScheme.app/Resources/GScheme.desktop new file mode 100644 index 0000000..8425164 --- /dev/null +++ b/GScheme.app/Resources/GScheme.desktop @@ -0,0 +1,8 @@ +[Desktop Entry] +Encoding=UTF-8 +Type=Application +Version=GScheme 0.1 +Name=GScheme +Exec=openapp GScheme.app +#TryExec=GScheme.app +MimeType= diff --git a/GScheme.app/Resources/Info-gnustep.plist b/GScheme.app/Resources/Info-gnustep.plist new file mode 100644 index 0000000..da54d8f --- /dev/null +++ b/GScheme.app/Resources/Info-gnustep.plist @@ -0,0 +1,29 @@ +{ + ApplicationDescription = "A scheme interpreter"; + ApplicationName = GScheme; + ApplicationRelease = "GScheme 0.1"; + Authors = ( + "Marko Riedel " + ); + Copyright = "Copyright (C) 2002 Free Software Foundation, Inc."; + CopyrightDescription = "This program is released under the GNU General Public License"; + FullVersionID = "0.1, June 2002"; + NOTE = "Automatically generated, do not edit!"; + NSExecutable = GScheme; + NSMainNibFile = ""; + NSPrincipalClass = NSApplication; + NSTypes = ( + { + NSDOSExtensions = ( + scm + ); + NSDocumentClass = Document; + NSHumanReadableName = "Scheme program"; + NSName = scm; + NSRole = Editor; + NSUnixExtensions = ( + scm + ); + } + ); +} \ No newline at end of file diff --git a/GScheme.app/Resources/library.scm b/GScheme.app/Resources/library.scm new file mode 100644 index 0000000..b08daa4 --- /dev/null +++ b/GScheme.app/Resources/library.scm @@ -0,0 +1,109 @@ + +(define vector + (lambda args + (list->vector args))) + + +(define list-n + (lambda (n) + (if (zero? n) '() + (cons n (list-n (- n 1)))))) + +(define list-ref + (lambda (l n) + (if (zero? n) + (car l) + (list-ref (cdr l) (- n 1))))) + +(define length + (lambda (l) + (if (or (null? l) (not (pair? l))) 0 + (+ 1 (length (cdr l)))))) + +(define filter + (lambda (l f) + (if (null? l) '() + (if (f (car l)) + (cons (car l) (filter (cdr l) f)) + (filter (cdr l) f))))) + +(define reverse + (letrec + ((rev + (lambda (l acc) + (if (null? l) acc + (rev (cdr l) (cons (car l) acc)))))) + (lambda (l) + (rev l '())))) + +(define append + (lambda (l . ls) + (if (null? l) + (if (pair? ls) + (if (pair? (cdr ls)) + (apply append ls) + (car ls)) ls) + (cons (car l) + (apply append (cons (cdr l) ls)))))) + +(define eqv? eq?) +(define equal? + (lambda (obj1 obj2) + (if (and (pair? obj1) (pair? obj2)) + (and (equal? (car obj1) (car obj2)) + (equal? (cdr obj1) (cdr obj2))) + (if (or (pair? obj1) (pair? obj2)) #f + (eqv? obj1 obj2))))) + +(define memgeneric + (lambda (obj l pred) + (if (null? l) '() + (if (pred obj (car l)) l + (memgeneric obj (cdr l) pred))))) + +(define memq + (lambda (obj l) (memgeneric obj l eq?))) +(define memv + (lambda (obj l) (memgeneric obj l eqv?))) +(define member + (lambda (obj l) (memgeneric obj l equal?))) + +(define association + (lambda (obj l pred) + (if (null? l) #f + (if (and (pair? (car l)) + (pred obj (car (car l)))) + (car l) + (association obj (cdr l) pred))))) + +(define assq + (lambda (obj l) (association obj l eq?))) +(define assv + (lambda (obj l) (association obj l eqv?))) +(define assoc + (lambda (obj l) (association obj l equal?))) + + +(define map-over-single-list + (lambda (p l) + (if (null? l) '() + (cons (p (car l)) + (map-over-single-list p (cdr l)))))) + +(define map + (lambda (proc . lists) + (if (memq '() lists) '() + (cons + (apply proc + (map-over-single-list car lists)) + (apply map + (cons proc (map-over-single-list cdr lists))))))) + +(define for-each + (lambda (proc . lists) + (if (memq '() lists) '() + (begin + (apply proc + (map-over-single-list car lists)) + (apply for-each + (cons proc (map-over-single-list cdr lists))))))) diff --git a/GScheme.app/Resources/library.scm~ b/GScheme.app/Resources/library.scm~ new file mode 100644 index 0000000..c1ae59e --- /dev/null +++ b/GScheme.app/Resources/library.scm~ @@ -0,0 +1,103 @@ +(define list-n + (lambda (n) + (if (zero? n) '() + (cons n (list-n (- n 1)))))) + +(define list-ref + (lambda (l n) + (if (zero? n) + (car l) + (list-ref (cdr l) (- n 1))))) + +(define length + (lambda (l) + (if (or (null? l) (not (pair? l))) 0 + (+ 1 (length (cdr l)))))) + +(define filter + (lambda (l f) + (if (null? l) '() + (if (f (car l)) + (cons (car l) (filter (cdr l) f)) + (filter (cdr l) f))))) + +(define reverse + (letrec + ((rev + (lambda (l acc) + (if (null? l) acc + (rev (cdr l) (cons (car l) acc)))))) + (lambda (l) + (rev l '())))) + +(define append + (lambda (l . ls) + (if (null? l) + (if (pair? ls) + (if (pair? (cdr ls)) + (apply append ls) + (car ls)) ls) + (cons (car l) + (apply append (cons (cdr l) ls)))))) + +(define eqv? eq?) +(define equal? + (lambda (obj1 obj2) + (if (and (pair? obj1) (pair? obj2)) + (and (equal? (car obj1) (car obj2)) + (equal? (cdr obj1) (cdr obj2))) + (if (or (pair? obj1) (pair? obj2)) #f + (eqv? obj1 obj2))))) + +(define memgeneric + (lambda (obj l pred) + (if (null? l) '() + (if (pred obj (car l)) l + (memgeneric obj (cdr l) pred))))) + +(define memq + (lambda (obj l) (memgeneric obj l eq?))) +(define memv + (lambda (obj l) (memgeneric obj l eqv?))) +(define member + (lambda (obj l) (memgeneric obj l equal?))) + +(define association + (lambda (obj l pred) + (if (null? l) #f + (if (and (pair? (car l)) + (pred obj (car (car l)))) + (car l) + (association obj (cdr l) pred))))) + +(define assq + (lambda (obj l) (association obj l eq?))) +(define assv + (lambda (obj l) (association obj l eqv?))) +(define assoc + (lambda (obj l) (association obj l equal?))) + + +(define map-over-single-list + (lambda (p l) + (if (null? l) '() + (cons (p (car l)) + (map-over-single-list p (cdr l)))))) + +(define map + (lambda (proc . lists) + (if (memq '() lists) '() + (cons + (apply proc + (map-over-single-list car lists)) + (apply map + (cons proc (map-over-single-list cdr lists))))))) + +(define for-each + (lambda (proc . lists) + (if (memq '() lists) '() + (begin + (apply proc + (map-over-single-list car lists)) + (apply for-each + (cons proc (map-over-single-list cdr lists))))))) diff --git a/GSchemeInfo.plist b/GSchemeInfo.plist new file mode 100644 index 0000000..8f9e1b1 --- /dev/null +++ b/GSchemeInfo.plist @@ -0,0 +1,19 @@ +{ + ApplicationName = "GScheme"; + ApplicationDescription = "A scheme interpreter"; + ApplicationRelease = "GScheme 0.1"; + FullVersionID = "0.1, June 2002"; + Authors = ("Marko Riedel "); + Copyright = "Copyright (C) 2002 Free Software Foundation, Inc."; + CopyrightDescription = "This program is released under the GNU General Public License"; + NSTypes = ( + { + NSName = "scm"; + NSHumanReadableName = "Scheme program"; + NSUnixExtensions = ("scm"); + NSDOSExtensions = ("scm"); + NSRole = Editor; + NSDocumentClass = Document; + } + ); +} diff --git a/Primitive.h b/Primitive.h new file mode 100644 index 0000000..a86d8ce --- /dev/null +++ b/Primitive.h @@ -0,0 +1,249 @@ +#import +#import + +#import + +#import "SchemeTypes.h" +#import "EnvWindow.h" + +#define PRIM_CLASS_PREF @"PRM" + +BOOL isBoolean(id item); +BOOL isChar(id item); +BOOL isInt(id item); +BOOL isDouble(id item); +BOOL isSymbol(id item); +BOOL isString(id item); +BOOL isPair(id item); +BOOL isVector(id item); +BOOL isTriple(id item); +BOOL isPrimitive(id item); +BOOL isClosure(id item); +BOOL isThunk(id item); +BOOL isFalse(id item); + +BOOL isEqual(id itema, id itemb); + +typedef enum { + NT_INTEGERS, + NT_DOUBLE, + NT_OTHER +} NUMTYPE; + +@interface Primitive : SCMType +{ + id value; + NSString *errmsg; +} + +- init; + +- (NUMTYPE)checkArgsNumeric:(NSMutableArray *)args offset:(int)offs; + +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; + +- (NSString *)primName; +- value; +- errmsg; + +@end + +@interface PRMVectorPred : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMPairPred : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMNullPred : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMZeroPred : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMNumberPred : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMEqPred : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMNot : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMNumEqual : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMNumLT : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMNumGT : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMPlus : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMTimes : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMMinus : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMDivide : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMQuotient : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMRemainder : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMList : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMCons : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMCar : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMCdr : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMSetCar : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMSetCdr : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMDisplay : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMNewline : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMDrawMove : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMDrawLine : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMDrawColor : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMSin : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMCos : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMASin : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMACos : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMSqrt : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMMakeVector : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMListToVector : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMVectorToList : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMVectorLength : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMVectorRef : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMVectorSet : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMVectorFill : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end + +@interface PRMBrowseEnvironment : Primitive +- (NSString *)primName; +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs; +@end diff --git a/Primitive.m b/Primitive.m new file mode 100644 index 0000000..227221d --- /dev/null +++ b/Primitive.m @@ -0,0 +1,1566 @@ + +#import "Primitive.h" +#import "VScheme.h" +#import "SchemeDelegate.h" + +BOOL isBoolean(id item) +{ + return [item isKindOfClass:[Boolean class]]; +} + +BOOL isChar(id item) +{ + return [item isKindOfClass:[Char class]]; +} + +BOOL isInt(id item) +{ + return [item isKindOfClass:[Int class]]; +} + +BOOL isDouble(id item) +{ + return [item isKindOfClass:[Double class]]; +} + +BOOL isSymbol(id item) +{ + return [item isKindOfClass:[Symbol class]]; +} + +BOOL isString(id item) +{ + return [item isKindOfClass:[String class]]; +} + +BOOL isPair(id item) +{ + return [item isKindOfClass:[Pair class]]; +} + +BOOL isVector(id item) +{ + return [item isKindOfClass:[Vector class]]; +} + +BOOL isTriple(id item) +{ + return [item isKindOfClass:[Triple class]]; +} + +BOOL isPrimitive(id item) +{ + return [item isKindOfClass:[Primitive class]]; +} + +BOOL isClosure(id item) +{ + return [item isKindOfClass:[Closure class]]; +} + +BOOL isThunk(id item) +{ + return [item isKindOfClass:[Thunk class]]; +} + +BOOL isFalse(id item) +{ + if(item==[NSNull null]){ + return YES; + } + + if([item isKindOfClass:[Boolean class]]){ + return ([item boolVal]==YES ? NO : YES); + } + + return NO; +} + +BOOL isEqual(id itema, id itemb) +{ + if([itema class]!=[itemb class]){ + return NO; + } + + if(isChar(itema)){ + return ([itema charVal]==[itemb charVal] ? YES : NO); + } + else if(isInt(itema)){ + return ([itema intVal]==[itemb intVal] ? YES : NO); + } + else if(isDouble(itema)){ + return ([itema doubleVal]==[itemb doubleVal] ? YES : NO); + } + else if(isBoolean(itema)){ + return ([itema boolVal]==[itemb boolVal] ? YES : NO); + } + else if(isString(itema)){ + return [[itema strVal] isEqual:[itemb strVal]]; + } + else if(isSymbol(itema)){ + return [[itema symVal] isEqual:[itemb symVal]]; + } + + return (itema==itemb ? YES : NO); +} + + +@implementation Primitive + +- init +{ + [super init]; + + value = [NSNull null]; + errmsg = nil; + + return self; +} + + +- (NUMTYPE)checkArgsNumeric:(NSMutableArray *)args offset:(int)offs +{ + int pos; + NUMTYPE res = NT_INTEGERS; + + for(pos=offs; pos<[args count]; pos++){ + id arg = [args objectAtIndex:pos]; + if(isInt(arg)==NO){ + if(isDouble(arg)==NO){ + return NT_OTHER; + } + res = NT_DOUBLE; + } + } + + return res; +} + +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs +{ + [self notImplemented: _cmd]; + return NO; +} + +- (NSString *)primName +{ + [self notImplemented: _cmd]; + return @"_not_implemented"; +} + +- value +{ + return value; +} + +- errmsg +{ + return errmsg; +} + +@end + +@implementation PRMVectorPred + +- (NSString *)primName +{ + return @"vector?"; +} + +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs +{ + id item; + + if(offs+1!=[args count]){ + errmsg = @"vector? takes one argument"; + return NO; + } + + item = [args objectAtIndex:offs]; + + value = [[Boolean alloc] initSCMBoolean:isVector(item)]; + return YES; +} + +@end + +@implementation PRMPairPred + +- (NSString *)primName +{ + return @"pair?"; +} + +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs +{ + id item; + + if(offs+1!=[args count]){ + errmsg = @"pair? takes one argument"; + return NO; + } + + item = [args objectAtIndex:offs]; + + value = [[Boolean alloc] initSCMBoolean:isPair(item)]; + return YES; +} + +@end + +@implementation PRMNullPred + +- (NSString *)primName +{ + return @"null?"; +} + +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs +{ + id item; + + if(offs+1!=[args count]){ + errmsg = @"null? takes one argument"; + return NO; + } + + item = [args objectAtIndex:offs]; + + value = [[Boolean alloc] + initSCMBoolean:(item==[NSNull null] ? YES : NO)]; + return YES; +} + +@end + +@implementation PRMZeroPred + +- (NSString *)primName +{ + return @"zero?"; +} + +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs +{ + NUMTYPE nt = [self checkArgsNumeric:args offset:offs]; + id item; + BOOL res = NO; + + + if(offs+1!=[args count]){ + errmsg = @"zero? takes one argument"; + return NO; + } + + item = [args objectAtIndex:offs]; + + if(nt==NT_OTHER){ + errmsg = @"Argument to zero? must be numeric"; + return NO; + } + + if(nt==NT_INTEGERS){ + if(![item intVal]){ + res = YES; + } + } + else{ + if([item doubleVal]==(double)0.0){ + res = YES; + } + } + + value = [[Boolean alloc] initSCMBoolean:res]; + return YES; +} + +@end + +@implementation PRMNumberPred + +- (NSString *)primName +{ + return @"number?"; +} + +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs +{ + NUMTYPE nt = [self checkArgsNumeric:args offset:offs]; + id item; + BOOL res = NO; + + + if(offs+1!=[args count]){ + errmsg = @"number? takes one argument"; + return NO; + } + + item = [args objectAtIndex:offs]; + + res = (nt!=NT_OTHER ? YES : NO); + + value = [[Boolean alloc] initSCMBoolean:res]; + return YES; +} + +@end + +@implementation PRMEqPred + +- (NSString *)primName +{ + return @"eq?"; +} + +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs +{ + id itema, itemb; + BOOL res = NO; + + if(offs+2!=[args count]){ + errmsg = @"eq? takes two arguments"; + return NO; + } + + itema = [args objectAtIndex:offs]; + itemb = [args objectAtIndex:offs+1]; + + value = [[Boolean alloc] initSCMBoolean:isEqual(itema, itemb)]; + return YES; +} + +@end + +@implementation PRMNot + +- (NSString *)primName +{ + return @"not"; +} + +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs +{ + id item; + + if(offs+1!=[args count]){ + errmsg = @"not takes one argument"; + return NO; + } + + item = [args objectAtIndex:offs]; + + value = [[Boolean alloc] initSCMBoolean:isFalse(item)]; + return YES; +} + +@end + +@implementation PRMNumEqual + +- (NSString *)primName +{ + return @"="; +} + +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs +{ + int icur, ires = 0; double dcur, dres = 0; + int pos = offs; + NUMTYPE nt = [self checkArgsNumeric:args offset:offs]; + BOOL res = YES; + + if(nt==NT_OTHER){ + errmsg = @"Arguments to = must be numeric"; + return NO; + } + + if(nt==NT_INTEGERS){ + ires = [[args objectAtIndex:offs] intVal]; + for(pos=offs+1; pos<[args count]; pos++){ + icur = [[args objectAtIndex:pos] intVal]; + if(!(ires==icur)){ + res = NO; + break; + } + ires = icur; + } + } + else{ + dres = [[args objectAtIndex:offs] doubleVal]; + for(pos=offs+1; pos<[args count]; pos++){ + dcur = [[args objectAtIndex:pos] doubleVal]; + if(!(dres==dcur)){ + res = NO; + break; + } + dres = dcur; + } + } + + value = [[Boolean alloc] initSCMBoolean:res]; + return YES; +} + +@end + +@implementation PRMNumLT + +- (NSString *)primName +{ + return @"<"; +} + +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs +{ + int icur, ires = 0; double dcur, dres = 0; + int pos = offs; + NUMTYPE nt = [self checkArgsNumeric:args offset:offs]; + BOOL res = YES; + + if(nt==NT_OTHER){ + errmsg = @"Arguments to < must be numeric"; + return NO; + } + + if(nt==NT_INTEGERS){ + ires = [[args objectAtIndex:offs] intVal]; + for(pos=offs+1; pos<[args count]; pos++){ + icur = [[args objectAtIndex:pos] intVal]; + if(!(ires"; +} + +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs +{ + int icur, ires = 0; double dcur, dres = 0; + int pos = offs; + NUMTYPE nt = [self checkArgsNumeric:args offset:offs]; + BOOL res = YES; + + if(nt==NT_OTHER){ + errmsg = @"Arguments to > must be numeric"; + return NO; + } + + if(nt==NT_INTEGERS){ + ires = [[args objectAtIndex:offs] intVal]; + for(pos=offs+1; pos<[args count]; pos++){ + icur = [[args objectAtIndex:pos] intVal]; + if(!(ires>icur)){ + res = NO; + break; + } + ires = icur; + } + } + else{ + dres = [[args objectAtIndex:offs] doubleVal]; + for(pos=offs+1; pos<[args count]; pos++){ + dcur = [[args objectAtIndex:pos] doubleVal]; + if(!(dres>dcur)){ + res = NO; + break; + } + dres = dcur; + } + } + + value = [[Boolean alloc] initSCMBoolean:res]; + return YES; +} + +@end + +@implementation PRMPlus + +- (NSString *)primName +{ + return @"+"; +} + +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs +{ + int ires = 0; double dres = 0; + int pos = offs; + NUMTYPE nt = [self checkArgsNumeric:args offset:offs]; + + if(nt==NT_OTHER){ + errmsg = @"Arguments to + must be numeric"; + return NO; + } + + if(nt==NT_INTEGERS){ + for(pos=offs; pos<[args count]; pos++){ + ires += [[args objectAtIndex:pos] intVal]; + } + + value = [[Int alloc] initSCMInt:ires]; + return YES; + } + + for(pos=offs; pos<[args count]; pos++){ + dres += [[args objectAtIndex:pos] doubleVal]; + } + + value = [[Double alloc] initSCMDouble:dres]; + return YES; +} + +@end + +@implementation PRMTimes + +- (NSString *)primName +{ + return @"*"; +} + +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs +{ + int ires = 1; double dres = 1; + int pos = offs; + NUMTYPE nt = [self checkArgsNumeric:args offset:offs]; + + if(nt==NT_OTHER){ + errmsg = @"Arguments to * must be numeric"; + return NO; + } + + if(nt==NT_INTEGERS){ + for(pos=offs; pos<[args count]; pos++){ + ires *= [[args objectAtIndex:pos] intVal]; + } + + value = [[Int alloc] initSCMInt:ires]; + return YES; + } + + for(pos=offs; pos<[args count]; pos++){ + dres *= [[args objectAtIndex:pos] doubleVal]; + } + + value = [[Double alloc] initSCMDouble:dres]; + return YES; +} + +@end + +@implementation PRMMinus + +- (NSString *)primName +{ + return @"-"; +} + +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs +{ + int ires = 1; double dres = 1; + int pos = offs; + NUMTYPE nt = [self checkArgsNumeric:args offset:offs]; + + if(offs==[args count]){ + errmsg = @"- needs at least one argument"; + return NO; + } + + if(nt==NT_OTHER){ + errmsg = @"Arguments to - must be numeric"; + return NO; + } + + if(nt==NT_INTEGERS){ + ires = [[args objectAtIndex:offs] intVal]; + if(offs+1==[args count]){ + ires = -ires; + } + else{ + for(pos=offs+1; pos<[args count]; pos++){ + ires -= [[args objectAtIndex:pos] intVal]; + } + } + value = [[Int alloc] initSCMInt:ires]; + return YES; + } + + dres = [[args objectAtIndex:offs] doubleVal]; + if(offs+1==[args count]){ + dres = -dres; + } + else{ + for(pos=offs+1; pos<[args count]; pos++){ + dres -= [[args objectAtIndex:pos] doubleVal]; + } + } + value = [[Double alloc] initSCMDouble:dres]; + return YES; +} + +@end + +@implementation PRMDivide + +- (NSString *)primName +{ + return @"/"; +} + +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs +{ + int ires = 1; double dres = 1; + int pos = offs; + NUMTYPE nt = [self checkArgsNumeric:args offset:offs]; + + if(offs==[args count]){ + errmsg = @"/ needs at least one argument"; + return NO; + } + + if(nt==NT_OTHER){ + errmsg = @"Arguments to / must be numeric"; + return NO; + } + + if(nt==NT_INTEGERS){ + ires = [[args objectAtIndex:offs] intVal]; + if(offs+1==[args count]){ + if(ires!=1){ + errmsg = @"no integer fractions"; + return NO; + } + } + else{ + for(pos=offs+1; pos<[args count]; pos++){ + ires /= [[args objectAtIndex:pos] intVal]; + } + } + value = [[Int alloc] initSCMInt:ires]; + return YES; + } + + dres = [[args objectAtIndex:offs] doubleVal]; + if(offs+1==[args count]){ + dres = ((double)1.0)/dres; + } + else{ + for(pos=offs+1; pos<[args count]; pos++){ + dres /= [[args objectAtIndex:pos] doubleVal]; + } + } + value = [[Double alloc] initSCMDouble:dres]; + return YES; +} + +@end + +@implementation PRMQuotient + +- (NSString *)primName +{ + return @"quotient"; +} + +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs +{ + NUMTYPE nt = [self checkArgsNumeric:args offset:offs]; + int a, b; + + if(offs+2!=[args count]){ + errmsg = @"quotient takes exactly two arguments"; + return NO; + } + + if(nt!=NT_INTEGERS){ + errmsg = @"Arguments to quotient must be integers"; + return NO; + } + + a = [[args objectAtIndex:offs] intVal]; + b = [[args objectAtIndex:offs+1] intVal]; + + if(!b){ + errmsg = @"divide by zero error in quotient"; + return NO; + } + + value = [[Int alloc] initSCMInt:(a/b)]; + return YES; +} + +@end + +@implementation PRMRemainder + +- (NSString *)primName +{ + return @"remainder"; +} + +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs +{ + NUMTYPE nt = [self checkArgsNumeric:args offset:offs]; + int a, b; + + if(offs+2!=[args count]){ + errmsg = @"remainder takes exactly two arguments"; + return NO; + } + + if(nt!=NT_INTEGERS){ + errmsg = @"Arguments to remainder must be integers"; + return NO; + } + + a = [[args objectAtIndex:offs] intVal]; + b = [[args objectAtIndex:offs+1] intVal]; + + if(!b){ + errmsg = @"divide by zero error in remainder"; + return NO; + } + + value = [[Int alloc] initSCMInt:(a%b)]; + return YES; +} + +@end + +@implementation PRMList + +- (NSString *)primName +{ + return @"list"; +} + +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs +{ + id res = [NSNull null]; + int pos; + + for(pos=[args count]-1; pos>=offs; pos--){ + res = [Pair newCar:[args objectAtIndex:pos] Cdr:res]; + } + + value = res; + return YES; +} + +@end + +@implementation PRMCons + +- (NSString *)primName +{ + return @"cons"; +} + +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs +{ + if(offs+2!=[args count]){ + errmsg = @"cons takes exactly two arguments"; + return NO; + } + + value = [Pair + newCar:[args objectAtIndex:offs] + Cdr:[args objectAtIndex:offs+1]]; + return YES; +} + +@end + +@implementation PRMCar + +- (NSString *)primName +{ + return @"car"; +} + +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs +{ + id item; + + if(offs+1!=[args count]){ + errmsg = @"car takes exactly one argument"; + return NO; + } + + item = [args objectAtIndex:offs]; + if(isPair(item)==NO){ + errmsg = @"argument to car must be a pair"; + return NO; + } + + value = [item car]; + return YES; +} + +@end + +@implementation PRMCdr + +- (NSString *)primName +{ + return @"cdr"; +} + +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs +{ + id item; + + if(offs+1!=[args count]){ + errmsg = @"cdr takes exactly one argument"; + return NO; + } + + item = [args objectAtIndex:offs]; + if(isPair(item)==NO){ + errmsg = @"argument to cdr must be a pair"; + return NO; + } + + value = [item cdr]; + return YES; +} + +@end + +@implementation PRMSetCar + +- (NSString *)primName +{ + return @"set-car!"; +} + +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs +{ + id item; + + if(offs+2!=[args count]){ + errmsg = @"set-car! takes two arguments"; + return NO; + } + + item = [args objectAtIndex:offs]; + if(isPair(item)==NO){ + errmsg = @"argument to set-car! must be a pair"; + return NO; + } + + [item setcar:[args objectAtIndex:(offs+1)]]; + + value = [item car]; + return YES; +} + +@end + +@implementation PRMSetCdr + +- (NSString *)primName +{ + return @"set-cdr!"; +} + +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs +{ + id item; + + if(offs+2!=[args count]){ + errmsg = @"set-cdr! takes two arguments"; + return NO; + } + + item = [args objectAtIndex:offs]; + if(isPair(item)==NO){ + errmsg = @"argument to set-cdr! must be a pair"; + return NO; + } + + [item setcdr:[args objectAtIndex:(offs+1)]]; + + value = [item cdr]; + return YES; +} + +@end + +@implementation PRMDisplay + +- (NSString *)primName +{ + return @"display"; +} + +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs +{ + id item; + NSString *res; + + if(offs+1!=[args count]){ + errmsg = @"display takes one argument"; + return NO; + } + + item = [args objectAtIndex:offs]; + + if(isString(item)){ + res = [[NSString alloc] + initWithFormat:@"%@" locale: nil, + [item strVal]]; + } + else if(isChar(item)){ + res = [[NSString alloc] + initWithFormat:@"%c" locale: nil, + [item charVal]]; + } + else{ + res = [VScheme valToString:item]; + } + [vm appendToOutput:res]; + + value = [NSNull null]; + return YES; +} + +@end + +@implementation PRMNewline + +- (NSString *)primName +{ + return @"newline"; +} + +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs +{ + id item; + + if(offs!=[args count]){ + errmsg = @"newline takes no arguments"; + return NO; + } + + [vm appendToOutput:@"\n"]; + + value = [NSNull null]; + return YES; +} + +@end + +@implementation PRMDrawMove +- (NSString *)primName +{ + return @"draw-move"; +} + +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs +{ + NUMTYPE nt = [self checkArgsNumeric:args offset:offs]; + DrawInst inst; + + if(offs+2!=[args count]){ + errmsg = @"draw-move takes two arguments"; + return NO; + } + + if(nt==NT_OTHER){ + errmsg = @"Arguments to draw-move must be numeric"; + return NO; + } + + inst.what = DRAW_MOVE; + inst.data.coord.x = [[args objectAtIndex:offs] doubleVal]; + inst.data.coord.y = [[args objectAtIndex:offs+1] doubleVal]; + + [vm recordImgInst:inst]; + + value = [NSNull null]; + return YES; +} + +@end + +@implementation PRMDrawLine +- (NSString *)primName +{ + return @"draw-line"; +} + +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs +{ + NUMTYPE nt = [self checkArgsNumeric:args offset:offs]; + DrawInst inst; + + if(offs+2!=[args count]){ + errmsg = @"draw-line takes two arguments"; + return NO; + } + + if(nt==NT_OTHER){ + errmsg = @"Arguments to draw-line must be numeric"; + return NO; + } + + inst.what = DRAW_LINE; + inst.data.coord.x = [[args objectAtIndex:offs] doubleVal]; + inst.data.coord.y = [[args objectAtIndex:offs+1] doubleVal]; + + [vm recordImgInst:inst]; + + value = [NSNull null]; + return YES; +} + +@end + +@implementation PRMDrawColor +- (NSString *)primName +{ + return @"draw-color"; +} + +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs +{ + NUMTYPE nt = [self checkArgsNumeric:args offset:offs]; + DrawInst inst; + + if(offs+3!=[args count]){ + errmsg = @"draw-color takes three arguments"; + return NO; + } + + if(nt==NT_OTHER){ + errmsg = @"Arguments to draw-color must be numeric"; + return NO; + } + + inst.what = DRAW_COLOR; + inst.data.color[0] = [[args objectAtIndex:offs] doubleVal]; + inst.data.color[1] = [[args objectAtIndex:offs+1] doubleVal]; + inst.data.color[2] = [[args objectAtIndex:offs+2] doubleVal]; + + if(inst.data.color[0]<(float)0 || + inst.data.color[0]>(float)255){ + errmsg = @"red color component out of range (0..255)"; + return NO; + } + if(inst.data.color[1]<(float)0 || + inst.data.color[1]>(float)255){ + errmsg = @"green color component out of range (0..255)"; + return NO; + } + if(inst.data.color[2]<(float)0 || + inst.data.color[2]>(float)255){ + errmsg = @"blue color component out of range (0..255)"; + return NO; + } + + inst.data.color[0]/=(float)255; + inst.data.color[1]/=(float)255; + inst.data.color[2]/=(float)255; + + [vm recordImgInst:inst]; + + value = [NSNull null]; + return YES; +} + +@end + +@implementation PRMSin +- (NSString *)primName +{ + return @"sin"; +} + +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs +{ + NUMTYPE nt = [self checkArgsNumeric:args offset:offs]; + double res; + + if(offs+1!=[args count]){ + errmsg = @"sin takes one argument"; + return NO; + } + + if(nt==NT_OTHER){ + errmsg = @"Argument to sin must be numeric"; + return NO; + } + + res = sin([[args objectAtIndex:offs] doubleVal]); + value = [[Double alloc] initSCMDouble:res]; + return YES; +} + +@end + +@implementation PRMASin +- (NSString *)primName +{ + return @"asin"; +} + +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs +{ + NUMTYPE nt = [self checkArgsNumeric:args offset:offs]; + double res, v; + + if(offs+1!=[args count]){ + errmsg = @"asin takes one argument"; + return NO; + } + + if(nt==NT_OTHER){ + errmsg = @"Argument to asin must be numeric"; + return NO; + } + + v = [[args objectAtIndex:offs] doubleVal]; + if(v<(double)-1.0 || (double)1.0vector"; +} + +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs +{ + id list; + + if(offs+1!=[args count]){ + errmsg = @"list->vector takes one argument"; + return NO; + } + + list = [args objectAtIndex:offs]; + + if(isPair(list)==NO && list!=[NSNull null]){ + errmsg = @"list->vector: list required"; + return NO; + } + + value = [Vector newFromList:list]; + + return YES; +} + + +@end + +@implementation PRMVectorToList +- (NSString *)primName +{ + return @"vector->list"; +} + +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs +{ + Vector *vect; + Pair *result; + id *data; + int index; + + if(offs+1!=[args count]){ + errmsg = @"vector->list takes one argument"; + return NO; + } + + vect = [args objectAtIndex:offs]; + + if(isVector(vect)==NO){ + errmsg = @"vector->list: vector required"; + return NO; + } + + data = [vect entries]; + + for(index=[vect count]-1, result=(Pair *)[NSNull null]; + index>=0; index--){ + result = + [Pair newCar:data[index] Cdr:result]; + } + + value = result; + + return YES; +} + +@end + +@implementation PRMVectorLength +- (NSString *)primName +{ + return @"vector-length"; +} + +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs +{ + Vector *vect; + + if(offs+1!=[args count]){ + errmsg = @"vector-length takes one argument"; + return NO; + } + + vect = [args objectAtIndex:offs]; + + if(isVector(vect)==NO){ + errmsg = @"vector-length: vector required"; + return NO; + } + + value = [[Int alloc] initSCMInt:[vect count]]; + + return YES; +} + +@end + +@implementation PRMVectorRef +- (NSString *)primName +{ + return @"vector-ref"; +} + +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs +{ + id *data; + Vector *vect; + int count, index; + Int *ind; + + if(offs+2!=[args count]){ + errmsg = @"vector-ref takes two arguments"; + return NO; + } + + vect = [args objectAtIndex:offs]; + if(isVector(vect)==NO){ + errmsg = @"vector-ref: vector required"; + return NO; + } + + data = [vect entries]; count = [vect count]; + + ind = [args objectAtIndex:offs+1]; + if(isInt(ind)==NO){ + errmsg = @"vector-ref: integer required"; + return NO; + } + + index = [ind intVal]; + if(index<0 || index>=count){ + errmsg = @"vector-ref: index out of bounds"; + return NO; + } + + value = data[index]; + + return YES; +} + +@end + +@implementation PRMVectorSet +- (NSString *)primName +{ + return @"vector-set!"; +} + +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs +{ + id *data; + Vector *vect; + int count, index; + Int *ind; + id obj; + + if(offs+3!=[args count]){ + errmsg = @"vector-set! takes three arguments"; + return NO; + } + + vect = [args objectAtIndex:offs]; + if(isVector(vect)==NO){ + errmsg = @"vector-set!: vector required"; + return NO; + } + + data = [vect entries]; count = [vect count]; + + ind = [args objectAtIndex:offs+1]; + if(isInt(ind)==NO){ + errmsg = @"vector-set!: integer required"; + return NO; + } + + index = [ind intVal]; + if(index<0 || index>=count){ + errmsg = @"vector-set!: index out of bounds"; + return NO; + } + + obj = [args objectAtIndex:offs+2]; + + data[index] = obj; [obj retain]; + + value = obj; + + return YES; +} + +@end + +@implementation PRMVectorFill +- (NSString *)primName +{ + return @"vector-fill!"; +} + +- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs +{ + id *data; + Vector *vect; + int count, index; + id obj; + + if(offs+2!=[args count]){ + errmsg = @"vector-fill! takes two arguments"; + return NO; + } + + vect = [args objectAtIndex:offs]; + if(isVector(vect)==NO){ + errmsg = @"vector-fill!: vector required"; + return NO; + } + + data = [vect entries]; count = [vect count]; + + obj = [args objectAtIndex:offs+1]; + for(index=0; index +#import + +#import "VScheme.h" + +@interface SCMTextView : NSTextView + +- (void)insertText:(id)aString; + +@end + +@interface SCMInteractive : SCMTextView +{ + int lastRetrieved; +} + +- (id)initWithFrame:(NSRect)frameRect; + +- (void)insertText:(id)aString; + +- placeCursorAtEnd; + +- (NSString *)getSuffix; +- (void)setString:(NSString *)aString; +- (void)appendString:(NSString *)aString; + +- (void)keyDown:(NSEvent *)theEvent; + +@end + diff --git a/SCMTextView.m b/SCMTextView.m new file mode 100644 index 0000000..17808d3 --- /dev/null +++ b/SCMTextView.m @@ -0,0 +1,155 @@ + +#import "SCMTextView.h" +#import "SchemeDelegate.h" + + +@implementation SCMTextView + +- (void)insertText:(id)aString +{ + int inslen = [aString length]; + unichar ch = [aString characterAtIndex:0]; + NSString *modified = @"", *single; + + if(inslen == 1 && ch==NSNewlineCharacter){ + NSString *data = [self string]; + NSRange range = [self selectedRange]; + NSCharacterSet *charset = + [NSCharacterSet whitespaceAndNewlineCharacterSet]; + int pos = range.location; + BOOL newline = NO; + + while(pos>0){ + pos--; + if([data characterAtIndex:pos]==NSNewlineCharacter){ + newline = YES; + break; + } + } + + if(newline == YES){ + int len = 0; int max = [data length]; + while(pos+len= lastRetrieved){ + [super delete:sender]; + } + else{ + NSBeep(); + } +} + +@end + diff --git a/Scheme/library.scm b/Scheme/library.scm new file mode 100644 index 0000000..b08daa4 --- /dev/null +++ b/Scheme/library.scm @@ -0,0 +1,109 @@ + +(define vector + (lambda args + (list->vector args))) + + +(define list-n + (lambda (n) + (if (zero? n) '() + (cons n (list-n (- n 1)))))) + +(define list-ref + (lambda (l n) + (if (zero? n) + (car l) + (list-ref (cdr l) (- n 1))))) + +(define length + (lambda (l) + (if (or (null? l) (not (pair? l))) 0 + (+ 1 (length (cdr l)))))) + +(define filter + (lambda (l f) + (if (null? l) '() + (if (f (car l)) + (cons (car l) (filter (cdr l) f)) + (filter (cdr l) f))))) + +(define reverse + (letrec + ((rev + (lambda (l acc) + (if (null? l) acc + (rev (cdr l) (cons (car l) acc)))))) + (lambda (l) + (rev l '())))) + +(define append + (lambda (l . ls) + (if (null? l) + (if (pair? ls) + (if (pair? (cdr ls)) + (apply append ls) + (car ls)) ls) + (cons (car l) + (apply append (cons (cdr l) ls)))))) + +(define eqv? eq?) +(define equal? + (lambda (obj1 obj2) + (if (and (pair? obj1) (pair? obj2)) + (and (equal? (car obj1) (car obj2)) + (equal? (cdr obj1) (cdr obj2))) + (if (or (pair? obj1) (pair? obj2)) #f + (eqv? obj1 obj2))))) + +(define memgeneric + (lambda (obj l pred) + (if (null? l) '() + (if (pred obj (car l)) l + (memgeneric obj (cdr l) pred))))) + +(define memq + (lambda (obj l) (memgeneric obj l eq?))) +(define memv + (lambda (obj l) (memgeneric obj l eqv?))) +(define member + (lambda (obj l) (memgeneric obj l equal?))) + +(define association + (lambda (obj l pred) + (if (null? l) #f + (if (and (pair? (car l)) + (pred obj (car (car l)))) + (car l) + (association obj (cdr l) pred))))) + +(define assq + (lambda (obj l) (association obj l eq?))) +(define assv + (lambda (obj l) (association obj l eqv?))) +(define assoc + (lambda (obj l) (association obj l equal?))) + + +(define map-over-single-list + (lambda (p l) + (if (null? l) '() + (cons (p (car l)) + (map-over-single-list p (cdr l)))))) + +(define map + (lambda (proc . lists) + (if (memq '() lists) '() + (cons + (apply proc + (map-over-single-list car lists)) + (apply map + (cons proc (map-over-single-list cdr lists))))))) + +(define for-each + (lambda (proc . lists) + (if (memq '() lists) '() + (begin + (apply proc + (map-over-single-list car lists)) + (apply for-each + (cons proc (map-over-single-list cdr lists))))))) diff --git a/Scheme/library.scm~ b/Scheme/library.scm~ new file mode 100644 index 0000000..c1ae59e --- /dev/null +++ b/Scheme/library.scm~ @@ -0,0 +1,103 @@ +(define list-n + (lambda (n) + (if (zero? n) '() + (cons n (list-n (- n 1)))))) + +(define list-ref + (lambda (l n) + (if (zero? n) + (car l) + (list-ref (cdr l) (- n 1))))) + +(define length + (lambda (l) + (if (or (null? l) (not (pair? l))) 0 + (+ 1 (length (cdr l)))))) + +(define filter + (lambda (l f) + (if (null? l) '() + (if (f (car l)) + (cons (car l) (filter (cdr l) f)) + (filter (cdr l) f))))) + +(define reverse + (letrec + ((rev + (lambda (l acc) + (if (null? l) acc + (rev (cdr l) (cons (car l) acc)))))) + (lambda (l) + (rev l '())))) + +(define append + (lambda (l . ls) + (if (null? l) + (if (pair? ls) + (if (pair? (cdr ls)) + (apply append ls) + (car ls)) ls) + (cons (car l) + (apply append (cons (cdr l) ls)))))) + +(define eqv? eq?) +(define equal? + (lambda (obj1 obj2) + (if (and (pair? obj1) (pair? obj2)) + (and (equal? (car obj1) (car obj2)) + (equal? (cdr obj1) (cdr obj2))) + (if (or (pair? obj1) (pair? obj2)) #f + (eqv? obj1 obj2))))) + +(define memgeneric + (lambda (obj l pred) + (if (null? l) '() + (if (pred obj (car l)) l + (memgeneric obj (cdr l) pred))))) + +(define memq + (lambda (obj l) (memgeneric obj l eq?))) +(define memv + (lambda (obj l) (memgeneric obj l eqv?))) +(define member + (lambda (obj l) (memgeneric obj l equal?))) + +(define association + (lambda (obj l pred) + (if (null? l) #f + (if (and (pair? (car l)) + (pred obj (car (car l)))) + (car l) + (association obj (cdr l) pred))))) + +(define assq + (lambda (obj l) (association obj l eq?))) +(define assv + (lambda (obj l) (association obj l eqv?))) +(define assoc + (lambda (obj l) (association obj l equal?))) + + +(define map-over-single-list + (lambda (p l) + (if (null? l) '() + (cons (p (car l)) + (map-over-single-list p (cdr l)))))) + +(define map + (lambda (proc . lists) + (if (memq '() lists) '() + (cons + (apply proc + (map-over-single-list car lists)) + (apply map + (cons proc (map-over-single-list cdr lists))))))) + +(define for-each + (lambda (proc . lists) + (if (memq '() lists) '() + (begin + (apply proc + (map-over-single-list car lists)) + (apply for-each + (cons proc (map-over-single-list cdr lists))))))) diff --git a/SchemeDelegate.h b/SchemeDelegate.h new file mode 100644 index 0000000..a0b2dba --- /dev/null +++ b/SchemeDelegate.h @@ -0,0 +1,39 @@ + +#import +#import +#import + +#import "Document.h" +#import "VScheme.h" +#import "SCMTextView.h" + +@interface SchemeDelegate : NSObject +{ + SCMInteractive *intTextView; + NSTextView *statTextView; + + NSMutableArray *imageWindows; + NSMutableArray *envWindows; +} + +- (void)applicationWillFinishLaunching:(NSNotification *)not; +- (void)applicationDidFinishLaunching:(NSNotification *)not; + +- makeInterpreterWindow; +- makeStatisticsWindow; + +- input:(NSString *)data; +- output:(NSString *)data; +- result:(id)item; +- statistics:(NSString *)stats; + +- imageWindow:(NSWindow *)window; +- envWindow:(NSWindow *)window; + +- closeImageWindows:(id)sender; +- closeEnvWindows:(id)sender; + + +- reset:(id)sender; + +@end diff --git a/SchemeDelegate.m b/SchemeDelegate.m new file mode 100644 index 0000000..9cd92d0 --- /dev/null +++ b/SchemeDelegate.m @@ -0,0 +1,462 @@ + +#import "SchemeDelegate.h" + +VScheme *vm = nil; + + +@implementation SchemeDelegate : NSObject + +- (void)applicationWillFinishLaunching:(NSNotification *)not +{ + // CREATE_AUTORELEASE_POOL(pool); + NSMenu *menu; + NSMenu *info; + NSMenu *file; + NSMenu *scheme; + NSMenu *env; + NSMenu *edit; + NSMenu *print; + NSMenu *services; + NSMenu *windows; + + // Create the app menu + menu = [NSMenu new]; + + [menu addItemWithTitle: @"Info" + action: NULL + keyEquivalent: @""]; + + [menu addItemWithTitle: @"File" + action: NULL + keyEquivalent: @""]; + + [menu addItemWithTitle: @"Edit" + action: NULL + keyEquivalent: @""]; + + [menu addItemWithTitle: @"Windows" + action: NULL + keyEquivalent: @""]; + + [menu addItemWithTitle: @"Scheme" + action: NULL + keyEquivalent: @""]; + + [menu addItemWithTitle: @"Environment" + action: NULL + keyEquivalent: @""]; + + [menu addItemWithTitle: @"Services" + action: NULL + keyEquivalent: @""]; + + [menu addItemWithTitle: @"Hide" + action: @selector(hide:) + keyEquivalent: @"h"]; + + [menu addItemWithTitle: @"Quit" + action: @selector(terminate:) + keyEquivalent: @"q"]; + + // Create the scheme submenu + scheme = [NSMenu new]; + [menu setSubmenu: scheme + forItem: [menu itemWithTitle: @"Scheme"]]; + + [scheme addItemWithTitle: @"Reset" + action: @selector(reset:) + keyEquivalent: @"+"]; + + [scheme addItemWithTitle: @"Evaluate" + action: @selector(evaluate:) + keyEquivalent: @"#"]; + + // Create the environment submenu + env = [NSMenu new]; + [menu setSubmenu: env + forItem: [menu itemWithTitle: @"Environment"]]; + + [env addItemWithTitle: @"Up" + action: @selector(up:) + keyEquivalent: @""]; + + [env addItemWithTitle: @"Down" + action: @selector(down:) + keyEquivalent: @""]; + + // Create the info submenu + info = [NSMenu new]; + [menu setSubmenu: info + forItem: [menu itemWithTitle: @"Info"]]; + + [info addItemWithTitle: @"Info Panel..." + action: @selector(orderFrontStandardInfoPanel:) + keyEquivalent: @""]; + +/* + [info addItemWithTitle: @"Preferences..." + action: NULL + keyEquivalent: @""]; +*/ + [info addItemWithTitle: @"Help" + action: @selector (orderFrontHelpPanel:) + keyEquivalent: @"?"]; + // RELEASE(info); + + // Create the file submenu + file = [NSMenu new]; + [menu setSubmenu: file + forItem: [menu itemWithTitle: @"File"]]; + + [file addItemWithTitle: @"Open Document" + action: @selector(openDocument:) + keyEquivalent: @"o"]; + + [file addItemWithTitle: @"New Document" + action: @selector(newDocument:) + keyEquivalent: @"n"]; + + [file addItemWithTitle: @"Save" + action: @selector(saveDocument:) + keyEquivalent: @"s"]; + + [file addItemWithTitle: @"Save To..." + action: @selector(saveDocumentTo:) + keyEquivalent: @"t"]; + + [file addItemWithTitle: @"Save As..." + action: @selector(saveDocumentAs:) + keyEquivalent: @"S"]; + + [file addItemWithTitle: @"Save All" + action: @selector(saveDocumentAll:) + keyEquivalent: @""]; + + [file addItemWithTitle: @"Revert to Saved" + action: @selector(revertDocumentToSaved:) + keyEquivalent: @"u"]; + + [file addItemWithTitle: @"Close" + action: @selector(close) + keyEquivalent: @""]; + + [file addItemWithTitle: @"Insert File..." + action: @selector(insertFile:) + keyEquivalent: @""]; + + // RELEASE(file); + + // Create the edit submenu + edit = [NSMenu new]; + [menu setSubmenu: edit + forItem: [menu itemWithTitle: @"Edit"]]; + + [edit addItemWithTitle: @"Cut" + action: @selector(cut:) + keyEquivalent: @"x"]; + + [edit addItemWithTitle: @"Copy" + action: @selector(copy:) + keyEquivalent: @"c"]; + + [edit addItemWithTitle: @"Paste" + action: @selector(paste:) + keyEquivalent: @"v"]; + + [edit addItemWithTitle: @"Delete" + action: @selector(delete:) + keyEquivalent: @""]; +/* + [edit addItemWithTitle: @"Undelete" + action: NULL + keyEquivalent: @""]; +*/ + [edit addItemWithTitle: @"Select All" + action: @selector(selectAll:) + keyEquivalent: @"a"]; + // RELEASE(edit); + + // Create the windows submenu + windows = [NSMenu new]; + [menu setSubmenu: windows + forItem: [menu itemWithTitle: @"Windows"]]; + + [windows addItemWithTitle: @"Arrange" + action: @selector(arrangeInFront:) + keyEquivalent: @""]; + + [windows addItemWithTitle: @"Miniaturize" + action: @selector(performMiniaturize:) + keyEquivalent: @"m"]; + + [windows addItemWithTitle: @"Close" + action: @selector(performClose:) + keyEquivalent: @"w"]; + + [windows addItemWithTitle: @"Close image windows" + action: @selector(closeImageWindows:) + keyEquivalent: @"W"]; + + [windows addItemWithTitle: @"Close environment windows" + action: @selector(closeEnvWindows:) + keyEquivalent: @""]; + + [NSApp setWindowsMenu: windows]; + // RELEASE(windows); + + // Create the service submenu + services = [NSMenu new]; + [menu setSubmenu: services + forItem: [menu itemWithTitle: @"Services"]]; + + [NSApp setServicesMenu: services]; + // RELEASE(services); + + [NSApp setMainMenu: menu]; + // RELEASE(menu); + + imageWindows = [NSMutableArray arrayWithCapacity:1]; + [imageWindows retain]; + + envWindows = [NSMutableArray arrayWithCapacity:1]; + [envWindows retain]; + + // RELEASE(pool); +} + +- (void)applicationDidFinishLaunching: (NSNotification *)not; +{ + vm = [[VScheme alloc] init]; + [vm setDelegate:self]; + + [self makeStatisticsWindow]; + [self makeInterpreterWindow]; + + // Make the DocumentController the delegate of the application, + // as this is the only way I know to bring it into the responder chain + [NSApp setDelegate:[NSDocumentController sharedDocumentController]]; +} + +NSWindow *interpreterWindow = nil; + +- makeInterpreterWindow +{ + NSWindow *window; + NSScrollView *scrollView; + SCMInteractive *textView; + NSRect scrollViewRect = {{0, 0}, {470, 400}}; + NSRect winRect = {{250, 100}, {470, 400}}; + NSRect textRect; + unsigned int style = NSTitledWindowMask | + NSMiniaturizableWindowMask | NSResizableWindowMask; + + // This is expected to be retained, as it would normaly come from a + // nib file, where the owner would retain it. + window = [[NSWindow alloc] initWithContentRect: winRect + styleMask: style + backing: NSBackingStoreRetained + defer: NO]; + [window setMinSize:NSMakeSize(300, 300)]; + + scrollView = [[NSScrollView alloc] initWithFrame: scrollViewRect]; + [scrollView setHasHorizontalScroller: NO]; + [scrollView setHasVerticalScroller: YES]; + [scrollView setAutoresizingMask: NSViewHeightSizable | NSViewWidthSizable]; + [[scrollView contentView] setAutoresizingMask: NSViewHeightSizable + | NSViewWidthSizable]; + [[scrollView contentView] setAutoresizesSubviews:YES]; + + // Build up the text network + textRect = [[scrollView contentView] frame]; + textView = [[SCMInteractive alloc] initWithFrame: textRect]; + + [textView setBackgroundColor: [NSColor whiteColor]]; + + [textView setString:GSCHEME]; + [textView appendString:@"> "]; + [textView setFont:[NSFont userFixedPitchFontOfSize:12]]; + + [textView setDelegate:vm]; + [textView setHorizontallyResizable: NO]; + [textView setVerticallyResizable: YES]; + [textView setMinSize: NSMakeSize(0, 0)]; + [textView setMaxSize: NSMakeSize(1E7, 1E7)]; + [textView setAutoresizingMask: NSViewHeightSizable | NSViewWidthSizable]; + [[textView textContainer] + setContainerSize:NSMakeSize(textRect.size.width, 1e7)]; + + + [[textView textContainer] setWidthTracksTextView: YES]; + // Store the text view in an ivar + intTextView = textView; + + [scrollView setDocumentView: textView]; + // RELEASE(textView); + [window setContentView: scrollView]; + // RELEASE(scrollView); + + // Make the Document the delegate of the window + [window setDelegate: self]; + + [window setTitle:@"GScheme"]; + [window display]; + [window makeKeyAndOrderFront:nil]; + // Make the text view the first responder + [textView placeCursorAtEnd]; + [window makeFirstResponder:textView]; + + interpreterWindow = window; + + return self; +} + +- makeStatisticsWindow +{ + NSWindow *window; + NSScrollView *scrollView; + SCMInteractive *textView; + NSRect scrollViewRect = {{0, 0}, {470, 400}}; + NSRect winRect = {{450, 75}, {470, 400}}; + NSRect textRect; + unsigned int style = NSTitledWindowMask | + NSMiniaturizableWindowMask | NSResizableWindowMask; + + // This is expected to be retained, as it would normaly come from a + // nib file, where the owner would retain it. + window = [[NSWindow alloc] initWithContentRect: winRect + styleMask: style + backing: NSBackingStoreRetained + defer: NO]; + [window setMinSize:NSMakeSize(300, 300)]; + + scrollView = [[NSScrollView alloc] initWithFrame: scrollViewRect]; + [scrollView setHasHorizontalScroller: NO]; + [scrollView setHasVerticalScroller: YES]; + [scrollView setAutoresizingMask: NSViewHeightSizable | NSViewWidthSizable]; + [[scrollView contentView] setAutoresizingMask: NSViewHeightSizable + | NSViewWidthSizable]; + [[scrollView contentView] setAutoresizesSubviews:YES]; + + // Build up the text network + textRect = [[scrollView contentView] frame]; + textView = [[NSTextView alloc] initWithFrame: textRect]; + + [textView setBackgroundColor: [NSColor whiteColor]]; + + [textView setString:GSCHEME]; + [textView setEditable:NO]; + [textView setFont:[NSFont userFixedPitchFontOfSize:12]]; + + [textView setDelegate:vm]; + [textView setHorizontallyResizable: NO]; + [textView setVerticallyResizable: YES]; + [textView setMinSize: NSMakeSize(0, 0)]; + [textView setMaxSize: NSMakeSize(1E7, 1E7)]; + [textView setAutoresizingMask: NSViewHeightSizable | NSViewWidthSizable]; + [[textView textContainer] + setContainerSize:NSMakeSize(textRect.size.width, 1e7)]; + + + [[textView textContainer] setWidthTracksTextView: YES]; + // Store the text view in an ivar + statTextView = textView; + + [scrollView setDocumentView: textView]; + // RELEASE(textView); + [window setContentView: scrollView]; + // RELEASE(scrollView); + + // Make the Document the delegate of the window + [window setDelegate: self]; + + // Make the text view the first responder + // [window makeFirstResponder:textView]; + [window setTitle:@"GScheme Statistics"]; + [window display]; + [window orderFront:nil]; + + return self; +} + +- input:(NSString *)data +{ + [intTextView appendString:data]; + return self; +} + +- output:(NSString *)data +{ + [intTextView appendString:data]; + return self; +} + +- result:(id)item +{ + [intTextView appendString:@"\n"]; + [intTextView appendString:[VScheme valToString:item]]; + [intTextView appendString:@"\n> "]; + [intTextView placeCursorAtEnd]; + return self; +} + +- statistics:(NSString *)stats +{ + NSString *sofar = [statTextView string]; + [statTextView setString:[sofar stringByAppendingString:stats]]; + return self; +} + +- reset:(id)sender +{ + [vm reset:self]; + + [intTextView setString:GSCHEME]; + [intTextView appendString:@"> "]; + [intTextView placeCursorAtEnd]; + [[intTextView window] makeFirstResponder:intTextView]; + + [statTextView setString:GSCHEME]; +} + +- imageWindow:(NSWindow *)window +{ + [imageWindows addObject:window]; + [window setDelegate:self]; + return self; +} + +- envWindow:(NSWindow *)window +{ + [envWindows addObject:window]; + [window setDelegate:self]; + return self; +} + +- (void)windowWillClose:(NSNotification *)aNotification +{ + NSWindow *win = [aNotification object]; + + if([imageWindows containsObject:win]==YES){ + [imageWindows removeObject:win]; + } + else if([envWindows containsObject:win]==YES){ + [envWindows removeObject:win]; + [win releaseForms]; + } +} + +- closeImageWindows:(id)sender +{ + [imageWindows + makeObjectsPerformSelector:@selector(close)]; + return self; +} + +- closeEnvWindows:(id)sender +{ + [envWindows + makeObjectsPerformSelector:@selector(close)]; + return self; +} + +@end diff --git a/SchemeTypes.h b/SchemeTypes.h new file mode 100644 index 0000000..af63d24 --- /dev/null +++ b/SchemeTypes.h @@ -0,0 +1,316 @@ +#import +#import + + +@interface NSMutableArray (Wrap) + +- (void)prependObjWRP:(id)anObject; +- (void)addObjWRP:(id)anObject; + +- (void)replaceObjWRPAtIndex:(unsigned)index withObject:(id)anObject; + +@end + +@interface NSMutableDictionary (Wrap) + +- (void)setObjWRP:(id)anObject forKey:(id)aKey; + +@end + +#define MARKABLE(_item) \ + ((_item)!=nil && ((id)(_item))!=(id)[NSNull null] && \ + [(_item) isKindOfClass:[SCMType class]]) + +@interface SCMType : NSObject +{ + int mark; +} + ++ (int)allocatedAfterGC; ++ (int)totalAllocated; ++ (int)nextMark; + ++ runGC; + ++ alloc; + + ++ addToMarkables:(id)item; ++ removeFromMarkables:(id)item; ++ currentMarkForMarkables; + +- (int)mark; +- setMark:(int)newMark; +- setMarkToCurrent; + +- (void)free; +@end + +// type name fix by Matt Rice +@interface Boolean : SCMType +{ + BOOL value; +} + +- initSCMBoolean:(BOOL)val; +- (BOOL)boolVal; + +@end + +@interface Char : SCMType +{ + char value; +} + + +- initSCMChar:(char)val; +- (char)charVal; + +@end + +@interface Int : SCMType +{ + long int value; +} + + +- initSCMInt:(long int)val; +- (long int)intVal; +- (double)doubleVal; + +@end + +@interface Double : SCMType +{ + double value; +} + + +- initSCMDouble:(double)val; +- (double)doubleVal; + +@end + +@interface Symbol : SCMType +{ + NSString *value; +} + +- initSCMSymbol:(char *)val; +- (NSString *)symVal; + +- (void)free; +@end + +@interface String : SCMType +{ + NSString *value; +} + +- initSCMString:(char *)val; +- (NSString *)strVal; + +- (void)free; +@end + +@interface Pair : SCMType +{ + id car; + id cdr; +} + ++ (int)length:(Pair *)list; + ++ newCar:(id)carval Cdr:(id)cdrval; +- initCar:(id)carval Cdr:(id)cdrval; + +- car; +- cdr; + +- setcar:(id)carval; +- setcdr:(id)cdrval; + +- setMarkToCurrent; + +@end + +@interface Vector : SCMType +{ + id *data; + unsigned count; +} + ++ newFromList:(Pair *)list; ++ newWithItem:(id)item count:(int)cval; + +- initWithList:(Pair *)list; +- initWithItem:(id)item count:(int)cval; + +- (id *)entries; +- (unsigned)count; + +- setMarkToCurrent; + +- (void)free; + +@end + + +@interface Closure : SCMType +{ + id args; + id body; + id env; +} + ++ newArgs:(id)argsval Body:(id)codes Env:(id)envval; +- initArgs:(id)argsval Body:(id)codes Env:(id)envval; + +- args; +- body; +- env; + +- setMarkToCurrent; + +@end + +@interface Thunk : SCMType +{ + int argp; + int envp; + int codep; +} + ++ newArgp:(int)argpval Envp:(int)envpval Codep:(int)codepval; + +- initArgp:(int)argpval Envp:(int)envpval Codep:(int)codepval; + +- (int)argp; +- setArgp:(int)argpval; + +- (int)envp; +- setEnvp:(int)envpval; + +- (int)codep; +- setCodep:(int)envpval; + +@end + +@interface Environment : SCMType +{ + Environment *parent; + NSMutableDictionary *data; +} + ++ newParent:(Environment *)par Data:(NSMutableDictionary *)entries; +- initParent:(Environment *)par Data:(NSMutableDictionary *)entries; + +- (int)chainLength; + +- (NSMutableDictionary *)lookup:(NSString *)sym; + +- (Environment *)parent; +- (NSMutableDictionary *)data; + +- setMarkToCurrent; + +- (void)free; + +@end + +typedef enum { + FORM_TOP = 0, + FORM_DEFINE1, + FORM_DEFINE2, + FORM_SET, + FORM_LAMBDA1, + FORM_LAMBDA2, + FORM_QUOTE, + FORM_BINDING, + FORM_LET, + FORM_LETSTAR, + FORM_LETREC, + FORM_IF1, + FORM_IF2, + FORM_AND, + FORM_OR, + FORM_BEGIN, + FORM_APPLY, + FORM_CASE, + FORM_SCOND1, + FORM_SCOND2, + FORM_SCOND3, + FORM_COND, + FORM_CALLCC +} FORMTYPE; + +@interface Triple : SCMType +{ + int tag; + id items[3]; +} + ++ newTag:(int)tagval; ++ newTag:(int)tagval IntArg1:(int)arg1; ++ newTag:(int)tagval Arg1:(id)arg1; ++ newTag:(int)tagval Arg1:(id)arg1 Arg2:(id)arg2; ++ newTag:(int)tagval Arg1:(id)arg1 Arg2:(id)arg2 Arg3:(id)arg3; + +- initTag:(int)tagval Arg1:(id)arg1 Arg2:(id)arg2 Arg3:(id)arg3; + +- (int)tag; +- (int)intarg1; +- setIntArg1:(int)val; + +- arg1; +- arg2; +- arg3; + +- setMarkToCurrent; + +@end + + +typedef enum { + IN_TO_ARGS = 0, + IN_LOOKUP, + IN_CHECK_PTC, + IN_POP_ENV, + IN_POP_ARGS, + IN_APPLIC, + IN_LIST_APPLIC, + IN_DEFINE, + IN_SET, + IN_CLOSURE, + IN_IF, + IN_LAYER, + IN_MEMQ, + IN_DUP_ARG, + IN_EXCH_ARGS, + IN_STATE_TO_THUNK, + IN_MARK_THUNK, + INSTR_COUNT +} INSTRUCTION; + +@interface ByteCodes : SCMType +{ + NSMutableArray *data; +} + ++ new; +- initWithMutableArray:(NSMutableArray *)theData; + + +- prependTriple:(Triple *)theTriple; +- addTriple:(Triple *)theTriple; + +- appendByteCodes:(ByteCodes *)codes; + +- (NSMutableArray *)codes; + +- setMarkToCurrent; + +- (void)free; + +@end + diff --git a/SchemeTypes.m b/SchemeTypes.m new file mode 100644 index 0000000..aba34c0 --- /dev/null +++ b/SchemeTypes.m @@ -0,0 +1,864 @@ + +#import "SchemeTypes.h" + +@implementation NSMutableArray (Wrap) + +- (void)addObjWRP:(id)anObject +{ + [anObject retain]; + [self addObject:anObject]; + return; +} + +- (void)replaceObjWRPAtIndex:(unsigned)index withObject:(id)anObject +{ + [anObject retain]; + [self replaceObjectAtIndex:index withObject:anObject]; + return; +} + +- (void)prependObjWRP:(id)anObject +{ + [anObject retain]; + [self insertObject:anObject atIndex:0]; + return; +} + +@end + +@implementation NSMutableDictionary (Wrap) + +- (void)setObjWRP:(id)anObject forKey:(id)aKey +{ + [anObject retain]; + [self setObject:anObject forKey:aKey]; + return; +} + +@end + +@implementation SCMType + +static int allocatedAfterGC = 0; +static NSMutableSet *scmobjects = nil; +static NSMutableSet *scmmarkables = nil; +static int currentMark = -1; +static int totalAllocated = 0; + + ++ (int)allocatedAfterGC +{ + return allocatedAfterGC; +} + ++ (int)totalAllocated +{ + return totalAllocated; +} + ++ (int)nextMark +{ + currentMark++; + return currentMark; +} + ++ addToMarkables:(id)item +{ + NSValue *entry = + [NSValue valueWithBytes:&item objCType:@encode(id)]; + + if(scmmarkables==nil){ + scmmarkables = [NSMutableSet setWithCapacity:1]; + [scmmarkables retain]; + } + + [scmmarkables addObject:entry]; + + return self; +} + ++ removeFromMarkables:(id)item +{ + NSValue *entry = + [NSValue valueWithBytes:&item objCType:@encode(id)]; + + if(scmmarkables==nil){ + scmmarkables = [NSMutableSet setWithCapacity:1]; + [scmmarkables retain]; + } + + [scmmarkables removeObject:entry]; + + return self; +} + ++ currentMarkForMarkables +{ + NSEnumerator *enumerator; + NSValue *curval; + id markable; + + if(scmmarkables==nil){ + scmmarkables = [NSMutableSet setWithCapacity:1]; + } + enumerator = [scmmarkables objectEnumerator]; + + while((curval = (NSValue *)[enumerator nextObject])!=nil){ + [curval getValue:&markable]; + if(MARKABLE(markable)){ + [markable setMarkToCurrent]; + } + } + + return self; +} + ++ runGC +{ + NSMutableSet *nextobjects = [NSMutableSet setWithCapacity:1]; + NSEnumerator *enumerator = [scmobjects objectEnumerator]; + // NSValue *curval; + SCMType *current; + + while((current = (SCMType *)[enumerator nextObject])!=nil){ + // [curval getValue:¤t]; + if([current mark]!=currentMark){ + [current free]; + } + else{ + [nextobjects addObject:current]; // curval]; + } + } + + [scmobjects release]; + + scmobjects = nextobjects; + [scmobjects retain]; + + allocatedAfterGC = totalAllocated = [scmobjects count]; +} + ++ alloc +{ + id inst = [super alloc]; + /* NSValue *entry = + [NSValue valueWithBytes:&inst objCType:@encode(id)]; */ + + if(scmobjects==nil){ + scmobjects = [NSMutableSet setWithCapacity:1]; + [scmobjects retain]; + } + + [scmobjects addObject:inst]; // entry]; + totalAllocated++; + + return [inst setMark:-1]; +} + + +- (int)mark +{ + return mark; +} + +- setMark:(int)newMark +{ + mark = newMark; + return self; +} + +- setMarkToCurrent +{ + mark = currentMark; + return self; +} + + +- (void)free +{ + int count = [self retainCount]; + + while(count>2){ // count>1 (leave one release for the set) + count--; + [self release]; + } + + [super release]; +} +@end + +@implementation Pair + ++ (int)length:(Pair *)list +{ + return (list==(Pair *)[NSNull null] ? + 0 : 1+[self length:[list cdr]]); +} + ++ newCar:(id)carval Cdr:(id)cdrval +{ + return [[super alloc] initCar:carval Cdr:cdrval]; +} + +- initCar:(id)carval Cdr:(id)cdrval +{ + car = carval; [car retain]; + cdr = cdrval; [cdr retain]; + + return self; +} + + +- car +{ + return car; +} + +- cdr +{ + return cdr; +} + +- setcar:(id)carval +{ + car = carval; [car retain]; + return self; +} + +- setcdr:(id)cdrval +{ + cdr = cdrval; [cdr retain]; + return self; +} + +- setMarkToCurrent +{ + if([self mark]==currentMark){ + return; + } + + [super setMarkToCurrent]; + if(MARKABLE(car)){ + [car setMarkToCurrent]; + } + if(MARKABLE(cdr)){ + [cdr setMarkToCurrent]; + } + + return self; +} + + +@end + +@implementation Vector + ++ newFromList:(Pair *)list +{ + return [[super alloc] + initWithList:list]; +} + ++ newWithItem:(id)item count:(int)cval +{ + return [[super alloc] + initWithItem:item count:cval]; +} + + +- initWithList:(Pair *)list +{ + Pair *current = list; + int index = 0, length = [Pair length:list]; + + count = length; + data = NSZoneMalloc([self zone], length*sizeof(id)); + + while(isPair(current)){ + data[index] = [current car]; [data[index++] retain]; + current = [current cdr]; + } + + return self; +} + +- initWithItem:(id)item count:(int)cval +{ + count = cval; + data = NSZoneMalloc([self zone], cval*sizeof(id)); + + while(cval--){ + data[cval] = item; [item retain]; + } + + return self; +} + + +- (id *)entries +{ + return data; +} + +- (unsigned)count +{ + return count; +} + +- setMarkToCurrent +{ + int index; + + if([self mark]==currentMark){ + return; + } + + [super setMarkToCurrent]; + + for(index=0; index + +@interface GSMutableDictionary : NSDictionary +{ +@public + GSIMapTable_t map; +} +@end + +typedef struct { + @defs(GSMutableDictionary) +} *GSMDictPtr; + +- (void)free +{ + GSIMapEmptyMap(&(((GSMDictPtr)data)->map)); + while([data retainCount]>1){ + [data release]; + } + + [super free]; +} + +@end + + +@implementation Triple + ++ newTag:(int)tagval +{ + return [[super alloc] + initTag:tagval + Arg1:nil Arg2:nil Arg3:nil]; +} + ++ newTag:(int)tagval IntArg1:(int)arg1; +{ + NSNumber *num = [NSNumber numberWithInt:arg1]; + return [[super alloc] + initTag:tagval + Arg1:num Arg2:nil Arg3:nil]; +} + ++ newTag:(int)tagval Arg1:(id)arg1 +{ + return [[super alloc] + initTag:tagval + Arg1:arg1 Arg2:nil Arg3:nil]; +} + ++ newTag:(int)tagval Arg1:(id)arg1 Arg2:(id)arg2 +{ + return [[super alloc] + initTag:tagval + Arg1:arg1 Arg2:arg2 Arg3:nil]; +} + ++ newTag:(int)tagval Arg1:(id)arg1 Arg2:(id)arg2 Arg3:(id)arg3 +{ + return [[super alloc] + initTag:tagval + Arg1:arg1 Arg2:arg2 Arg3:arg3]; +} + + +- initTag:(int)tagval Arg1:(id)arg1 Arg2:(id)arg2 Arg3:(id)arg3 +{ + tag = tagval; + + items[0] = arg1; [arg1 retain]; + items[1] = arg2; [arg2 retain]; + items[2] = arg3; [arg3 retain]; + + return self; +} + +- (int)tag +{ + return tag; +} + +- (int)intarg1 +{ + return [items[0] intValue]; +} + +- setIntArg1:(int)val +{ + items[0] = [NSNumber numberWithInt:val]; + return self; +} + +- arg1 +{ + return items[0]; +} + +- arg2 +{ + return items[1]; +} + +- arg3 +{ + return items[2]; +} + +- setMarkToCurrent +{ + if([self mark]==currentMark){ + return; + } + + [super setMarkToCurrent]; + if(MARKABLE(items[0])){ + [items[0] setMarkToCurrent]; + } + if(MARKABLE(items[1])){ + [items[1] setMarkToCurrent]; + } + if(MARKABLE(items[2])){ + [items[2] setMarkToCurrent]; + } + + return self; +} + +@end + +@implementation Boolean + +- initSCMBoolean:(BOOL)val +{ + [super init]; + value = val; + return self; +} + +- (BOOL)boolVal +{ + return value; +} + +@end + +@implementation Char + +- initSCMChar:(char)val +{ + [super init]; + value = val; + return self; +} + +- (char)charVal +{ + return value; +} + +@end + +@implementation Int + +- initSCMInt:(long int)val +{ + [super init]; + value = val; + return self; +} + +- (long int)intVal +{ + return value; +} + +- (double)doubleVal +{ + return (double)value; +} + +@end + +@implementation Double + +- initSCMDouble:(double)val +{ + [super init]; + value = val; + return self; +} + +- (double)doubleVal +{ + return value; +} + +@end + +@implementation Symbol + +- initSCMSymbol:(char *)val +{ + [super init]; + value = [NSString stringWithCString:val]; + [value retain]; + return self; +} + +- (NSString *)symVal +{ + return value; +} + +- (void)free +{ + [value release]; + [super free]; +} + +@end + +@implementation String + +- initSCMString:(char *)val +{ + char *cp, *buf, *from, *to; + int len = strlen(val); + + [super init]; + + cp = strdup(val); from = cp+1; cp[len-1] = 0; + buf = to = malloc(len-1); + + while(*from){ + if(*from == '\\'){ + from++; + } + *to++ = *from++; + } + *to = 0; + + value = [NSString stringWithCString:buf]; + [value retain]; + + free(buf); + free(cp); + + return self; +} + +- (NSString *)strVal +{ + return value; +} + +- (void)free +{ + [value release]; + [super free]; +} + +@end + +@implementation ByteCodes + ++ new +{ + id inst = [super alloc]; + [inst initWithMutableArray:[NSMutableArray arrayWithCapacity:1]]; + return inst; +} + +- initWithMutableArray:(NSMutableArray *)theData +{ + [super init]; + data = theData; + [data retain]; + + return self; +} + +- prependTriple:(Triple *)theTriple +{ + [data prependObjWRP:theTriple]; + return self; +} + +- addTriple:(Triple *)theTriple +{ + [data addObjWRP:theTriple]; + return self; +} + +- appendByteCodes:(ByteCodes *)codes +{ + [data addObjectsFromArray:[codes codes]]; + return self; +} + + +- (NSMutableArray *)codes +{ + return data; +} + +- setMarkToCurrent +{ + int index, count = [data count]; + + if([self mark]==currentMark){ + return; + } + + [super setMarkToCurrent]; + + for(index=0; index_count = 0; + while([data retainCount]>1){ + [data release]; + } + + [super free]; +} + +@end diff --git a/TestScheme.app/Resources/Info-gnustep.plist b/TestScheme.app/Resources/Info-gnustep.plist new file mode 100644 index 0000000..a1b1f52 --- /dev/null +++ b/TestScheme.app/Resources/Info-gnustep.plist @@ -0,0 +1,6 @@ +{ + NOTE = "Automatically generated, do not edit!"; + NSExecutable = "TestScheme"; + NSMainNibFile = ""; + NSPrincipalClass = "NSApplication"; +} diff --git a/TestScheme.app/Resources/TestScheme.desktop b/TestScheme.app/Resources/TestScheme.desktop new file mode 100644 index 0000000..e651203 --- /dev/null +++ b/TestScheme.app/Resources/TestScheme.desktop @@ -0,0 +1,5 @@ +[Desktop Entry] +Encoding=UTF-8 +Type=Application +Exec=openapp TestScheme.app +#TryExec=TestScheme.app diff --git a/TestScheme.app/TestScheme b/TestScheme.app/TestScheme new file mode 100755 index 0000000..86f732b --- /dev/null +++ b/TestScheme.app/TestScheme @@ -0,0 +1,218 @@ +#!/bin/sh +# +# Copyright (C) 1999 Free Software Foundation, Inc. +# +# Author: Adam Fedor +# Date: May 1999 +# +# This file is part of the GNUstep Makefile Package. +# +# This library 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. +# +# You should have received a copy of the GNU General Public +# License along with this library; see the file COPYING.LIB. +# If not, write to the Free Software Foundation, +# 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +# This is a shell script which attempts to find the GNUstep executable +# of the same name based on the current host and library_combo. + +#-------------------------------------------------------------------------- +# Main body +#-------------------------------------------------------------------------- +if [ -z "$EXEEXT" ]; then + EXEEXT= +fi +if [ -z "$LIBRARY_COMBO" ]; then + LIBRARY_COMBO=gnu-gnu-gnu +fi + +# Process arguments +app=$0 +show_available_platforms=0 +show_relative_path=0 +show_full_path=0 +while true +do + case $1 in + + --script-help) + echo usage: `basename $0` [--library-combo=...] + echo " [--available-platforms][--full-executable-path]" + echo " [--relative-executable-path] [arguments...]" + echo + echo " --library-combo=... specifies a GNUstep backend to use." + echo " It overrides the default LIBRARY_COMBO environment variable." + echo + echo " --available-platforms displays a list of valid exec hosts" + echo " --full-executable-path displays full path to executable" + echo " --relative-executable-path displays subdirectory path" + echo " arguments... are the arguments to the application." + exit 0 + ;; + --library-combo=*) + LIBRARY_COMBO=`echo $1 | sed 's/--library-combo=//'` + shift + ;; + --available-platforms) + show_available_platforms=1 + exit 0 + ;; + --full-executable-path) + show_full_path=1 + break + ;; + --relative-executable-path) + show_relative_path=1 + break + ;; + *) + break;; + esac +done + +if [ "$LIBRARY_COMBO" = nx ]; then + LIBRARY_COMBO=nx-nx-nx +elif [ "$LIBRARY_COMBO" = gnu ]; then + LIBRARY_COMBO=gnu-gnu-gnu +elif [ "$LIBRARY_COMBO" = fd ]; then + LIBRARY_COMBO=gnu-fd-gnu +fi +export LIBRARY_COMBO + +# Find path to ourself +app=`echo $app | sed 's%/*$%%'` +dir=`dirname $app` + +case $app in + /*) # An absolute path. + full_appname=$dir;; + */*) # A relative path + full_appname=`(cd $dir; pwd)`;; + *) # A path that needs to be searched + if [ -n $GNUSTEP_PATHPREFIX_LIST ]; then + SPATH=$GNUSTEP_PATHPREFIX_LIST + else + SPATH=$PATH + fi + SPATH=.:$SPATH + IFS=: + for path_dir in $SPATH; do + if [ -d $path_dir/$dir ]; then + full_appname=`(cd $path_dir/$dir; pwd)` + break; + fi + if [ -d $path_dir/Applications/$dir ]; then + full_appname=`(cd $path_dir/Applications/$dir; pwd)` + break; + fi + done;; +esac + +if [ -z "$full_appname" ]; then + echo "Can't find absolute path for $app! Please specify full path when" + echo "invoking executable" + exit 1 +fi + +# +# get base app name +# +app=`echo $app | sed 's/\.[a-z]*$//'` +app=`basename $app` +appname= +if [ -f "$full_appname/Resources/Info-gnustep.plist" ]; then +# -n disable auto-print (for portability reasons) +# /^ *NSExecutable *=/ matches every line beginning with +# zero or more spaces, followed by 'NSExecutable', followed by zero or +# more spaces, followed by '=' +# to this line we apply the following commands: +# s/"//g; which deletes all " in the line. +# s/^ *NSExecutable *= *\([^ ;]*\) *;.*/\1/p; +# which replaces 'NSExecutable = Gorm; ' with 'Gorm', then, because +# of the 'p' at the end, prints out the result +# q; which quits sed since we know there must be only a single line +# to replace. + appname=`sed -n -e '/^ *NSExecutable *=/ \ + {s/"//g; s/^ *NSExecutable *= *\([^ ;]*\) *;.*/\1/p; q;}' \ + "$full_appname/Resources/Info-gnustep.plist"` +fi +if [ -z "$appname" ]; then + appname=$app +fi + +appname="$appname$EXEEXT" + +if [ $show_available_platforms = 1 ]; then + cd $full_appname + #available_platforms + exit 0 +fi + +# +# Determine the host information +# +if [ -z "$GNUSTEP_HOST" ]; then + GNUSTEP_HOST=`(cd /tmp; $GNUSTEP_SYSTEM_ROOT/Makefiles/config.guess)` + GNUSTEP_HOST=`(cd /tmp; $GNUSTEP_SYSTEM_ROOT/Makefiles/config.sub $GNUSTEP_HOST)` + export GNUSTEP_HOST +fi +if [ -z "$GNUSTEP_HOST_CPU" ]; then + GNUSTEP_HOST_CPU=`$GNUSTEP_SYSTEM_ROOT/Makefiles/cpu.sh $GNUSTEP_HOST` + GNUSTEP_HOST_CPU=`$GNUSTEP_SYSTEM_ROOT/Makefiles/clean_cpu.sh $GNUSTEP_HOST_CPU` + export GNUSTEP_HOST_CPU +fi +if [ -z "$GNUSTEP_HOST_VENDOR" ]; then + GNUSTEP_HOST_VENDOR=`$GNUSTEP_SYSTEM_ROOT/Makefiles/vendor.sh $GNUSTEP_HOST` + GNUSTEP_HOST_VENDOR=`$GNUSTEP_SYSTEM_ROOT/Makefiles/clean_vendor.sh $GNUSTEP_HOST_VENDOR` + export GNUSTEP_HOST_VENDOR +fi +if [ -z "$GNUSTEP_HOST_OS" ]; then + GNUSTEP_HOST_OS=`$GNUSTEP_SYSTEM_ROOT/Makefiles/os.sh $GNUSTEP_HOST` + GNUSTEP_HOST_OS=`$GNUSTEP_SYSTEM_ROOT/Makefiles/clean_os.sh $GNUSTEP_HOST_OS` + export GNUSTEP_HOST_OS +fi + +# +# Make sure the executable is there +# +if [ -x $full_appname/$GNUSTEP_HOST_CPU/$GNUSTEP_HOST_OS/$LIBRARY_COMBO/$appname ]; then + relative_path=$GNUSTEP_HOST_CPU/$GNUSTEP_HOST_OS/$LIBRARY_COMBO/$appname +elif [ -x $full_appname/$GNUSTEP_HOST_CPU/$GNUSTEP_HOST_OS/$appname ]; then + relative_path=$GNUSTEP_HOST_CPU/$GNUSTEP_HOST_OS/$appname +elif [ -x $full_appname/$GNUSTEP_HOST_CPU/$appname ]; then + relative_path=$GNUSTEP_HOST_CPU/$appname +elif [ $appname != $app -a -x $full_appname/$appname ]; then + relative_path=$appname +else + echo "$full_appname application does not have a binary for this kind of machine/operating system ($GNUSTEP_HOST_CPU/$GNUSTEP_HOST_OS)." + exit 1 +fi + +if [ $show_relative_path = 1 ]; then + echo $relative_path + exit 0 +fi +if [ $show_full_path = 1 ]; then + echo $full_appname/$relative_path + exit 0 +fi + +if [ "$LIBRARY_COMBO" = nx-nx-nx -a $GNUSTEP_HOST_OS = nextstep4 ]; then + if [ -f "$full_appname/library_paths.openapp" ]; then + additional_library_paths="`cat $full_appname/library_paths.openapp`" + fi +else + if [ -f "$full_appname/$GNUSTEP_HOST_CPU/$GNUSTEP_HOST_OS/$LIBRARY_COMBO/library_paths.openapp" ]; then + additional_library_paths="`cat $full_appname/$GNUSTEP_HOST_CPU/$GNUSTEP_HOST_OS/$LIBRARY_COMBO/library_paths.openapp`" + fi +fi + +# Load up LD_LIBRARY_PATH +. $GNUSTEP_SYSTEM_ROOT/Makefiles/ld_lib_path.sh + +exec $full_appname/$relative_path "$@" + diff --git a/USAGE b/USAGE new file mode 100644 index 0000000..2e84234 --- /dev/null +++ b/USAGE @@ -0,0 +1,40 @@ + + +GScheme + +A GNUstep-aware scheme interpreter. Includes many examples, e.g. the +sieve of Erathostenes to compute primes, a Koch curve plotter, graphs +of various functions etc. GScheme is fully tail recursive. The garbage +collector bypasses GNUstep's retain/release mechanism in order to deal +with circular data structures. + +GScheme is document-based and you can edit more than one file at the +same time. + +Speed leaves something to be desired as there is a lot of overhead due +to Objective C. + +Press Ctrl-Return in the interpreter window to evaluate the last form +that you have entered. + +Special forms implemented include + + define, set!, lambda, + if, and, or + begin, apply, + quote, case, cond, + let, let, letrec, + call-with-current-continuation + +Primitives implemented include + + +, *, -, /, =, >, <, + draw-move, draw-line, draw-color, + sin, cos, sqrt, + quotient, remainder, not, + zero?, pair?, number?, eqv?, eq?, + cons, car, cdr, list, null?, + set-car!, set-cdr!, + display, newline + +There is a library of additional primitives that are loaded on start-up. diff --git a/VScheme.h b/VScheme.h new file mode 100644 index 0000000..83de895 --- /dev/null +++ b/VScheme.h @@ -0,0 +1,120 @@ +#import +#import + +#import "SchemeTypes.h" +#import "Primitive.h" + +#define GSCHEME @"GScheme by Marko Riedel, mriedel@neuearbeit.de\n" + +typedef enum { + MODE_INTERACTIVE, + MODE_EVALUATE, + MODE_LOAD +} PROCESS_MODE; + +typedef enum { + DRAW_MOVE, + DRAW_LINE, + DRAW_COLOR +} DRAW_INST; + +typedef struct _DrawInst { + DRAW_INST what; + union { + NSPoint coord; + float color[3]; + } data; +} DrawInst; + +@interface VScheme : NSObject +{ + BOOL errflag; + NSString *errmsg; + + NSMutableArray *codeStack; + NSMutableArray *pcStack; + NSMutableArray *argStack; + NSMutableArray *envStack; + + id curcodes; + int curpc; + + NSString *output; + + int maxcode, maxpc, maxarg, maxenv; + + id delegate; + + BOOL atImgStart; + NSPoint imgMin, imgMax; + NSMutableArray *imgCodes; + + long int curRecDepth, maxRecDepth; +} + ++ (NSString *)valToString:(id)item seen:(NSMutableSet *)mem; ++ (NSString *)valToString:(id)item; + ++ printInstr:(Triple *)instr; ++ printCodes:(NSMutableArray *)codes; + +- init; + +- delegate; +- setDelegate:(id)aDelegate; + +- makeStartEnvironment; + +- (int)maxcode; +- (int)maxpc; +- (int)maxarg; +- (int)maxenv; + +- resetStacks; +- reset:(id)sender; + +- appendToOutput:(NSString *)data; +- (NSString *)output; +- clearOutput; + +- recordImgInst:(DrawInst)inst; +- clearImage; +- produceImage; + +- (NSMutableArray *)argStack; +- (NSMutableArray *)envStack; +- (NSMutableArray *)codeStack; + +- (BOOL)errflag; +- (NSString *)errmsg; + +- args2list:(int)lower; + +- pushCodes:(NSMutableArray *)codes; +- (BOOL)run:(ByteCodes *)prog; + +- special:(id)data output:(ByteCodes *)codes popenv:(int)ec; +- sequence:(id)data output:(ByteCodes *)codes popenv:(int)ec; +- compile:(id)data output:(ByteCodes *)codes popenv:(int)ec; + +- (BOOL)compile:(id)data output:(ByteCodes *)codes; + +- (BOOL)processString:(NSString *)data mode:(PROCESS_MODE)pmode; + +@end + +@interface SCMImageView : NSView +{ + NSImage *image; +} + +- (id)initWithFrame:(NSRect)frameRect; + +- (NSImage *)image; +- setImage:(NSImage *)anImage; + +- (void)drawRect:(NSRect)aRect; + +@end + + diff --git a/VScheme.m b/VScheme.m new file mode 100644 index 0000000..eaeda14 --- /dev/null +++ b/VScheme.m @@ -0,0 +1,1722 @@ + +#import "VScheme.h" +#import "SchemeDelegate.h" + + + +static char *forms[] = { + "top", + "define1", "define2", "set", + "lambda1", "lambda2", + "quote", "binding", + "let", "let*", "letrec", + "if1", "if2", + "and", "or", + "begin", "apply", + "case", "scond1", "scond2", "scond3", "cond", + "callcc" +}; + +void print_tree(id item, int indent) +{ + int pos; + + for(pos=0; pos\n"); + } + else if(c=='\t'){ + printf("CHAR: <\\tab>\n"); + } + else if(c==' '){ + printf("CHAR: <\\space>\n"); + } + else{ + printf("CHAR: <%c>\n", c); + } + } + else if([item isKindOfClass:[Int class]]){ + printf("INT: %ld\n", [item intVal]); + } + else if([item isKindOfClass:[Double class]]){ + printf("DOUBLE: %le\n", [item doubleVal]); + } + else if([item isKindOfClass:[Symbol class]]){ + printf("SYMBOL: <%s>\n", [[item symVal] cString]); + } + else if([item isKindOfClass:[String class]]){ + printf("STRING: <%s>\n", [[item strVal] cString]); + } + else if([item isKindOfClass:[Closure class]]){ + printf("CLOSURE %s\n", + [[VScheme valToString:[item args]] cString]); + } + else if([item isKindOfClass:[Primitive class]]){ + printf("PRIMITIVE\n"); + } + else if([item isKindOfClass:[Thunk class]]){ + printf("THUNK %d %d %d\n", [item argp], [item envp], [item codep]); + } + else if([item isKindOfClass:[Pair class]]){ + printf("PAIR %s\n", [[VScheme valToString:item] cString]); + } + else if([item isKindOfClass:[Vector class]]){ + printf("PAIR %s\n", [[VScheme valToString:item] cString]); + } + else if([item isKindOfClass:[ByteCodes class]]){ + printf("CODES: %u\n", [[item codes] count]); + } + else{ + printf("FORM %s\n", forms[[item tag]]); + if([item arg1]!=nil){ + print_tree([item arg1], indent+1); + } + if([item arg2]!=nil){ + print_tree([item arg2], indent+1); + } + if([item arg3]!=nil){ + print_tree([item arg3], indent+1); + } + } +} + +void print_scheme_item(id item) +{ + print_tree(item, 0); +} + + +@implementation VScheme + +static char *codenames[] = { + "TO_ARGS", + "LOOKUP", + "CHECK_PTC", + "POP_ENV", + "POP_ARGS", + "APPLIC", + "LIST_APPLIC", + "DEFINE", + "SET", + "CLOSURE", + "IF", + "LAYER", + "MEMQ", + "DUP_ARG", + "EXCH_ARGS", + "STATE_TO_THUNK", + "MARK_THUNK" +}; + + ++ (NSString *)valToString:(id)item seen:(NSMutableSet *)mem +{ + if(item==[NSNull null]){ + return @"()"; + } + + if((isPair(item) || isVector(item)) && + [mem containsObject:item]==YES){ + return @""; + } + + if(isBoolean(item)){ + return ([item boolVal]==YES ? @"#t" : @"#f"); + } + else if(isChar(item)){ + NSString *format; + char c = [item charVal]; + if(c=='\n'){ + format = @"#\\newline"; + } + else if(c=='\t'){ + format = @"#\\tab"; + } + else if(c==' '){ + format = @"#\\space"; + } + else{ + format = @"#\\%c"; + } + return [[NSString alloc] + initWithFormat:format locale: nil, c]; + } + else if(isInt(item)){ + return [[NSString alloc] + initWithFormat:@"%d" locale: nil, [item intVal]]; + } + else if(isDouble(item)){ + return [[NSString alloc] + initWithFormat:@"%le" locale: nil, [item doubleVal]]; + } + else if(isSymbol(item)){ + return [[NSString alloc] + initWithFormat:@"%@" locale: nil, [item symVal]]; + } + else if(isString(item)){ + return [[NSString alloc] + initWithFormat:@"\"%@\"" locale: nil, [item strVal]]; + } + else if(isClosure(item)){ + return [[NSString alloc] + initWithFormat:@"" + locale: nil, + [VScheme valToString:[item args] seen:mem]]; + } + else if(isPrimitive(item)){ + return [[NSString alloc] + initWithFormat:@"" + locale: nil, [item primName]]; + } + else if(isThunk(item)){ + return [[NSString alloc] + initWithFormat:@"" + locale: nil, [item argp], [item envp], [item codep]]; + } + else if(isPair(item)){ + NSString *str; + NSMutableSet *local = [NSMutableSet setWithCapacity:1]; + NSEnumerator *en; + + [mem addObject:item]; [local addObject:item]; + str = [VScheme valToString:[item car] seen:mem]; + + item = [item cdr]; + while(isPair(item) && [mem containsObject:item]==NO){ + [mem addObject:item]; [local addObject:item]; + str = [str stringByAppendingFormat:@" %@", + [VScheme valToString:[item car] seen:mem]]; + + item = [item cdr]; + } + + if(isPair(item)){ + str = [str stringByAppendingString:@" "]; + } + else if(item!=[NSNull null]){ + str = [str stringByAppendingFormat:@" . %@", + [VScheme valToString:item seen:mem]]; + } + + en = [local objectEnumerator]; + while((item = [en nextObject])!=nil){ + [mem removeObject:item]; + } + + [local removeAllObjects]; + + return [NSString stringWithFormat:@"(%@)", str]; + } + else if(isVector(item)){ + id *entries = [item entries]; + NSString *str; + int count = [item count], index; + + if(!count){ + return @"#()"; + } + + [mem addObject:item]; + + str = [NSString stringWithFormat:@"#(%@", + [VScheme valToString:entries[0] seen:mem]]; + for(index=1; indexinst.data.coord.x){ + imgMin.x = inst.data.coord.x; + } + if(imgMin.y>inst.data.coord.y){ + imgMin.y = inst.data.coord.y; + } + if(imgMax.x=lower){ + res = [Pair newCar:[argStack objectAtIndex:pos] + Cdr:res]; + pos--; + } + + return res; +} + +- pushCodes:(NSMutableArray *)newcodes +{ + if(curpc==[[codeStack lastObject] count]){ + [codeStack removeLastObject]; + } + else{ + [pcStack addObjWRP:[NSNumber numberWithInt:curpc]]; + } + [codeStack addObjWRP:newcodes]; + + curpc = 0; curcodes = newcodes; + + return self; +} + +#define MAXREC 1000 + +- (BOOL)run:(ByteCodes *)prog +{ + NSAutoreleasePool *pool = [NSAutoreleasePool new]; + id instr; + + curRecDepth = 0; + maxRecDepth = MAXREC; + + codeStack = [NSMutableArray arrayWithCapacity:1]; + pcStack = [NSMutableArray arrayWithCapacity:1]; + argStack = [NSMutableArray arrayWithCapacity:1]; + + [codeStack retain]; + [pcStack retain]; + [argStack retain]; + + [codeStack addObjWRP:[prog codes]]; + + curcodes = [prog codes]; + curpc = 0; + + while(1){ + if(!(curpc<[curcodes count])){ + [codeStack removeLastObject]; + if(![codeStack count]){ + break; + } + + curcodes = [codeStack lastObject]; + curpc = [[pcStack lastObject] intValue]; + [pcStack removeLastObject]; + } + + // printf("-%d-%d- ", [codeStack count], curpc); + + instr = [curcodes objectAtIndex:curpc++]; + // [VScheme printInstr:instr]; + + + switch([instr tag]){ + case IN_TO_ARGS: + [argStack addObjWRP:[instr arg1]]; + break; + case IN_LOOKUP:{ + NSString *sym = [[argStack lastObject] symVal]; + NSMutableDictionary *layer = + [[envStack lastObject] lookup:sym]; + if(layer==nil){ + errflag = YES; + errmsg = + [[NSString alloc] + initWithFormat:@"symbol %@ not bound" + locale: nil, sym]; + } + else{ + [argStack removeLastObject]; + [argStack addObjWRP:[layer objectForKey:sym]]; + } + } break; + case IN_CHECK_PTC:{ + id item = [argStack lastObject]; + if(!(isPrimitive(item) || isClosure(item) || + isThunk(item))){ + NSString *format = + @"primitive, thunk or closure required, got %@"; + errflag = YES; + errmsg = + [[NSString alloc] + initWithFormat:format + locale: nil, NSStringFromClass([item class])]; + } + } break; + case IN_POP_ENV:{ + int count = [instr intarg1]; + while(count--){ + [envStack removeLastObject]; + } + } break; + case IN_POP_ARGS:{ + int count = [instr intarg1]; + while(count--){ + [argStack removeLastObject]; + } + } break; + case IN_LIST_APPLIC:{ + id list = [argStack lastObject]; + int argc = 0; + + [argStack removeLastObject]; + while(isPair(list)){ + [argStack addObjWRP:[list car]]; + list = [list cdr]; + argc++; + } + if(list!=[NSNull null]){ + errflag = YES; + errmsg = @"second arg to apply not a proper list"; + break; + } + [instr setIntArg1:argc]; + } + case IN_APPLIC:{ + int argc = [instr intarg1]; + int offs = [argStack count]-argc; + id op = [argStack objectAtIndex:(offs-1)]; + id res = nil; + + if(isPrimitive(op)){ + if([op evalVM:self Args:argStack offset:offs]==YES){ + res = [op value]; + } + else{ + errflag = YES; + errmsg = [op errmsg]; + break; + } + } + else if(isThunk(op)){ + int + argp = [op argp], + envp = [op envp], + codep = [op codep], + curargp = [argStack count], + curenvp = [envStack count], + curcodep = [codeStack count]; + if(argp<0 || envp<0 || codep<0){ + errflag = YES; + errmsg = @"this thunk has expired"; + break; + } + + if(argc!=1){ + errflag = YES; + errmsg = @"thunk requires a single argument"; + break; + } + + res = [argStack lastObject]; + + while(curargp-->argp){ + [argStack removeLastObject]; + } + while(curenvp-->envp){ + [envStack removeLastObject]; + } + while(curcodep-->codep){ + [codeStack removeLastObject]; + if(curcodep>codep){ + [pcStack removeLastObject]; + } + } + + curpc = [[pcStack lastObject] intValue]; + [pcStack removeLastObject]; + + curcodes = [codeStack lastObject]; + } + else if(isClosure(op)){ + NSMutableDictionary *layer = + [NSMutableDictionary dictionaryWithCapacity:1]; + id argl = [op args]; + id env; + + if(isSymbol(argl)){ + [layer setObjWRP:[self args2list:offs] + forKey:[argl symVal]]; + } + else{ + int symc = 0; + while(isPair(argl)){ + symc++; + if(symc>argc){ + errflag = YES; + errmsg = @"not enough arguments"; + break; + } + [layer setObjWRP:[argStack objectAtIndex:offs++] + forKey:[[argl car] symVal]]; + argl = [argl cdr]; + } + if(symcmaxRecDepth){ + int cont = + NSRunAlertPanel(@"Alert", + @"Deep recursion. Continue?", + @"Yes", @"No", nil); + if(cont==NSAlertAlternateReturn){ + errflag = YES; + errmsg = @"abort on deep recursion"; + } + + maxRecDepth *= 4; + } + } + + if(isThunk(op)==NO){ + while(argc--){ + [argStack removeLastObject]; + } + [argStack removeLastObject]; + } + + if(res!=nil){ + [argStack addObjWRP:res]; + } + } break; + case IN_DEFINE:{ + int offs = [argStack count]-2; + NSMutableDictionary *layer = [[envStack lastObject] data]; + [layer setObjWRP:[argStack objectAtIndex:(offs+1)] + forKey:[[argStack objectAtIndex:offs] symVal]]; + [argStack removeLastObject]; + } break; + case IN_SET:{ + int offs = [argStack count]-2; + NSString *sym = [[argStack objectAtIndex:offs] symVal]; + id val = [argStack objectAtIndex:offs+1]; + NSMutableDictionary *layer = + [[envStack lastObject] lookup:sym]; + + if(layer==nil){ + NSString *format = + @"symbol %@ not bound; can't assign to it"; + errflag = YES; + errmsg = + [[NSString alloc] + initWithFormat:format + locale: nil, sym]; + break; + } + + [layer setObjWRP:[argStack objectAtIndex:(offs+1)] + forKey:[[argStack objectAtIndex:offs] symVal]]; + [argStack removeObjectAtIndex:offs]; + } break; + case IN_CLOSURE:{ + int pos = [argStack count]-2; + id closure = + [Closure newArgs:[argStack objectAtIndex:pos] + Body:[argStack objectAtIndex:(pos+1)] + Env:[envStack lastObject]]; + [argStack removeLastObject]; + [argStack removeLastObject]; + [argStack addObjWRP:closure]; + } break; + case IN_IF:{ + BOOL isfalse = isFalse([argStack lastObject]); + [self pushCodes:[(isfalse==YES ? + [instr arg2] : [instr arg1]) codes]]; + [argStack removeLastObject]; + } break; + case IN_LAYER:{ + int count = [instr intarg1]; + int offs = [argStack count]-2; + NSMutableDictionary *layer = + [NSMutableDictionary dictionaryWithCapacity:1]; + id env; + + while(count--){ + [layer setObjWRP:[argStack objectAtIndex:(offs+1)] + forKey:[[argStack objectAtIndex:offs] symVal]]; + [argStack removeLastObject]; + [argStack removeLastObject]; + offs-=2; + } + + env = [Environment + newParent:[envStack lastObject] Data:layer]; + [envStack addObjWRP:env]; + } break; + case IN_MEMQ:{ + id list = [argStack lastObject]; + id search; + + [argStack removeLastObject]; + search = [argStack lastObject]; + + while(isPair(list)){ + if(isEqual(search, [list car])==YES){ + break; + } + list = [list cdr]; + } + + [argStack addObjWRP:list]; + } break; + case IN_DUP_ARG: { + if([argStack count]<1){ + errflag = YES; + errmsg = @"missing item (duplicate)"; + } + else{ + [argStack addObjWRP:[argStack lastObject]]; + } + } break; + case IN_EXCH_ARGS: { + if([argStack count]<2){ + errflag = YES; + errmsg = @"missing items (exchange)"; + } + else{ + id item1, item2; + item1 = [argStack lastObject]; + [argStack removeLastObject]; + item2 = [argStack lastObject]; + [argStack removeLastObject]; + [argStack addObjWRP:item1]; + [argStack addObjWRP:item2]; + } + } break; + case IN_STATE_TO_THUNK:{ + Thunk *t = [instr arg1]; + [t setArgp:[argStack count]]; + [t setEnvp:[envStack count]]; + [t setCodep:[codeStack count]]; + } break; + case IN_MARK_THUNK:{ + Thunk *t = [instr arg1]; + [t setArgp:-1]; + [t setEnvp:-1]; + [t setCodep:-1]; + } break; + default: + errflag = YES; + errmsg = + [[NSString alloc] + initWithFormat:@"instruction unknown (tag %d)" + locale: nil, [instr tag]]; + + } + + if([codeStack count]>maxcode){ + maxcode = [codeStack count]; + } + if([pcStack count]>maxpc){ + maxpc = [pcStack count]; + } + if([argStack count]>maxarg){ + maxarg = [argStack count]; + } + if([envStack count]>maxenv){ + maxenv = [envStack count]; + } + + + if(errflag==YES){ + break; + } + + if([SCMType totalAllocated]>4*[SCMType allocatedAfterGC]){ + int ptotal = [SCMType totalAllocated]; + NSString *msg, + *format = @"\nGC prev: %d now: %d\n", + *cformat = @"%@ prev: %d now: %d\n"; + struct { + Class cl; + int prev; + } *cent, classes[] = { + { [Pair class], 0 }, + { [Environment class], 0 }, + { [Closure class], 0 }, + { [Vector class], 0 }, + { [Triple class], 0 }, + { [ByteCodes class], 0 }, + { [NSForm class], 0 }, + { [NSFormCell class], 0 }, + { [NSScrollView class], 0 }, + { [NSWindow class], 0 }, + { nil, 0 } + }; + int argind, argmx; + + for(cent=classes; cent->cl!=nil; cent++){ + cent->prev = GSDebugAllocationCount(cent->cl); + } + + [SCMType nextMark]; + [SCMType currentMarkForMarkables]; + + // [source setMarkToCurrent]; + + [prog setMarkToCurrent]; + + argmx = [argStack count]; + for(argind=0; argindcl!=nil; cent++){ + msg = [NSString stringWithFormat:cformat, + NSStringFromClass(cent->cl), + cent->prev, + GSDebugAllocationCount(cent->cl)]; + [delegate statistics:msg]; + } + + [delegate statistics:@"\n"]; + } + } + } + + [pool release]; + + return (errflag==YES ? NO : YES); +} + +- special:(id)data output:(ByteCodes *)codes popenv:(int)ec +{ + int tag = [data tag]; + + switch(tag){ + case FORM_DEFINE1: + [codes addTriple:[Triple newTag:IN_TO_ARGS Arg1:[data arg1]]]; + [self compile:[data arg2] output:codes popenv:ec]; + [codes addTriple:[Triple newTag:IN_DEFINE]]; + break; + case FORM_DEFINE2: { + ByteCodes *body = [ByteCodes new]; + + [codes addTriple:[Triple newTag:IN_TO_ARGS + Arg1:[[data arg1] car]]]; + [codes addTriple:[Triple newTag:IN_TO_ARGS + Arg1:[[data arg1] cdr]]]; + [self sequence:[data arg2] output:body popenv:1]; + [codes addTriple:[Triple newTag:IN_TO_ARGS Arg1:body]]; + [codes addTriple:[Triple newTag:IN_CLOSURE]]; + + if(ec>0){ + [codes addTriple:[Triple newTag:IN_POP_ENV IntArg1:ec]]; + } + [codes addTriple:[Triple newTag:IN_DEFINE]]; + } break; + case FORM_SET: + [codes addTriple:[Triple newTag:IN_TO_ARGS Arg1:[data arg1]]]; + // [self compile:[data arg2] output:codes popenv:ec]; + [self compile:[data arg2] output:codes popenv:0]; + [codes addTriple:[Triple newTag:IN_SET]]; + [codes addTriple:[Triple newTag:IN_POP_ENV IntArg1:ec]]; + break; + case FORM_LAMBDA1: + case FORM_LAMBDA2: { + ByteCodes *body = [ByteCodes new]; + + [codes addTriple:[Triple newTag:IN_TO_ARGS Arg1:[data arg1]]]; + [self sequence:[data arg2] output:body popenv:1]; + [codes addTriple:[Triple newTag:IN_TO_ARGS Arg1:body]]; + [codes addTriple:[Triple newTag:IN_CLOSURE]]; + + if(ec>0){ + [codes addTriple:[Triple newTag:IN_POP_ENV IntArg1:ec]]; + } + } break; + case FORM_BEGIN: + [self sequence:[data arg1] output:codes popenv:ec]; + break; + case FORM_APPLY: + [self compile:[data arg1] output:codes popenv:0]; + [codes addTriple:[Triple newTag:IN_CHECK_PTC]]; + [self compile:[data arg2] output:codes popenv:ec]; + [codes addTriple:[Triple newTag:IN_LIST_APPLIC]]; + break; + case FORM_QUOTE: + if(ec>0){ + [codes addTriple:[Triple newTag:IN_POP_ENV IntArg1:ec]]; + } + [codes addTriple:[Triple newTag:IN_TO_ARGS Arg1:[data arg1]]]; + break; + case FORM_CALLCC:{ + Thunk *t = [Thunk newArgp:-1 Envp:-1 Codep:-1]; + + [codes addTriple:[Triple newTag:IN_STATE_TO_THUNK Arg1:t]]; + [self compile:[data arg1] output:codes popenv:ec]; + [codes addTriple:[Triple newTag:IN_CHECK_PTC]]; + [codes addTriple:[Triple newTag:IN_TO_ARGS Arg1:t]]; + [codes addTriple:[Triple newTag:IN_APPLIC IntArg1:1]]; + [codes addTriple:[Triple newTag:IN_MARK_THUNK Arg1:t]]; + } break; + case FORM_LET: + case FORM_LETSTAR: + case FORM_LETREC:{ + int count = 0; + id bindings = [data arg1]; + + if(tag==FORM_LETREC){ + [codes addTriple:[Triple newTag:IN_LAYER IntArg1:0]]; + } + + while(isPair(bindings)){ + id binding = [bindings car]; + + [codes addTriple:[Triple newTag:IN_TO_ARGS + Arg1:[binding arg1]]]; + [self compile:[binding arg2] output:codes popenv:0]; + + if(tag==FORM_LETREC){ + [codes addTriple:[Triple newTag:IN_DEFINE]]; + [codes addTriple:[Triple newTag:IN_POP_ARGS IntArg1:1]]; + } + else if(tag==FORM_LETSTAR){ + [codes addTriple:[Triple newTag:IN_LAYER IntArg1:1]]; + } + + count++; bindings = [bindings cdr]; + } + + if(tag==FORM_LET){ + [codes addTriple:[Triple newTag:IN_LAYER IntArg1:count]]; + } + + [self sequence:[data arg2] output:codes + popenv:ec+(tag==FORM_LETSTAR? count : 1)]; + } break; + case FORM_IF1: + case FORM_IF2: { + ByteCodes + *trueClause = [ByteCodes new], + *falseClause = [ByteCodes new]; + + [self compile:[data arg1] output:codes popenv:0]; + [self compile:[data arg2] output:trueClause popenv:ec]; + if([data arg3]!=nil){ + [self compile:[data arg3] output:falseClause + popenv:ec]; + } + else{ + if(ec>0){ + [falseClause + addTriple:[Triple newTag:IN_POP_ENV IntArg1:ec]]; + } + [falseClause + addTriple:[Triple newTag:IN_TO_ARGS + Arg1:[NSNull null]]]; + } + // [trueClause retain]; [falseClause retain]; + [codes addTriple:[Triple newTag:IN_IF + Arg1:trueClause Arg2:falseClause]]; + } break; + case FORM_COND: { + ByteCodes + *current, *endClause = [ByteCodes new]; + id args, curcond; + + args = [data arg1]; + curcond = [args car]; + + if(isPair(curcond)){ + [self sequence:[curcond cdr] output:endClause popenv:ec]; + args = [args cdr]; + } + else{ + if(ec>0){ + [endClause + addTriple:[Triple newTag:IN_POP_ENV IntArg1:ec]]; + } + [endClause + addTriple:[Triple newTag:IN_TO_ARGS + Arg1:[NSNull null]]]; + } + + current = endClause; // [current retain]; + while(isPair(args)){ + ByteCodes + *clause = [ByteCodes new], + *match = [ByteCodes new]; + int tag; + + curcond = [args car]; tag = [curcond tag]; + + [self compile:[curcond arg1] output:clause popenv:0]; + + if(tag==FORM_SCOND1){ + [clause addTriple:[Triple newTag:IN_DUP_ARG]]; + [match addTriple:[Triple newTag:IN_POP_ENV IntArg1:ec]]; + } + else if(tag==FORM_SCOND2){ + [self sequence:[curcond arg2] output:match popenv:ec]; + } + else{ + [clause addTriple:[Triple newTag:IN_DUP_ARG]]; + [self compile:[curcond arg2] output:match popenv:ec]; + [match addTriple:[Triple newTag:IN_CHECK_PTC]]; + [match addTriple:[Triple newTag:IN_EXCH_ARGS]]; + [match addTriple:[Triple newTag:IN_APPLIC IntArg1:1]]; + [current prependTriple: + [Triple newTag:IN_POP_ARGS IntArg1:1]]; + } + + [clause addTriple: + [Triple newTag:IN_IF + Arg1:match Arg2:current]]; + + current = clause; // [current retain]; + args = [args cdr]; + } + [codes appendByteCodes:current]; + } break; + case FORM_CASE: { + ByteCodes + *endClause = [ByteCodes new]; + id current, args, curcase; + + args = [data arg2]; + curcase = [args car]; + + [endClause addTriple:[Triple newTag:IN_POP_ARGS IntArg1:1]]; + if([curcase car]==[NSNull null]){ + [self sequence:[curcase cdr] output:endClause popenv:ec]; + args = [args cdr]; + } + else{ + if(ec>0){ + [endClause + addTriple:[Triple newTag:IN_POP_ENV IntArg1:ec]]; + } + [endClause + addTriple:[Triple newTag:IN_TO_ARGS + Arg1:[NSNull null]]]; + } + + [self compile:[data arg1] output:codes popenv:0]; + current = endClause; + while(isPair(args)){ + ByteCodes + *clause = [ByteCodes new], + *match = [ByteCodes new]; + + curcase = [args car]; + + [clause + addTriple:[Triple newTag:IN_TO_ARGS + Arg1:[curcase car]]]; + [clause addTriple:[Triple newTag:IN_MEMQ]]; + + [match addTriple:[Triple newTag:IN_POP_ARGS IntArg1:1]]; + [self sequence:[curcase cdr] output:match popenv:ec]; + + [clause addTriple: + [Triple newTag:IN_IF + Arg1:match Arg2:current]]; + + current = clause; // [current retain]; + args = [args cdr]; + } + [codes appendByteCodes:current]; + } break; + case FORM_AND: + case FORM_OR: { + ByteCodes + *trueClause = [ByteCodes new], + *falseClause = [ByteCodes new], + *current; + id args; + if(ec>0){ + [trueClause + addTriple:[Triple newTag:IN_POP_ENV IntArg1:ec]]; + } + [trueClause + addTriple:[Triple newTag:IN_TO_ARGS + Arg1:[[Boolean alloc] initSCMBoolean:YES]]]; + if(ec>0){ + [falseClause + addTriple:[Triple newTag:IN_POP_ENV IntArg1:ec]]; + } + [falseClause + addTriple:[Triple newTag:IN_TO_ARGS + Arg1:[[Boolean alloc] initSCMBoolean:NO]]]; + + current = (tag == FORM_AND ? trueClause : falseClause); + args = [data arg1]; + while(isPair(args)){ + ByteCodes + *clause = [ByteCodes new]; + [self compile:[args car] output:clause popenv:0]; + if(tag == FORM_AND){ + [clause addTriple: + [Triple newTag:IN_IF + Arg1:current Arg2:falseClause]]; + } + else{ + [clause addTriple: + [Triple newTag:IN_IF + Arg1:trueClause Arg2:current]]; + } + current = clause; // [current retain]; + args = [args cdr]; + } + [codes appendByteCodes:current]; + } break; + default: + errflag = YES; + errmsg = + [[NSString alloc] + initWithFormat:@"scheme form unknown (tag %d)" + locale: nil, [data tag]]; + } +} + +- sequence:(id)data output:(ByteCodes *)codes popenv:(int)ec +{ + while(isPair(data)){ + BOOL beforeLast = isPair([data cdr]); + [self compile:[data car] output:codes + popenv:(beforeLast==YES ? 0 : ec)]; + if(beforeLast==YES){ + [codes addTriple:[Triple newTag:IN_POP_ARGS IntArg1:1]]; + } + data = [data cdr]; + } +} + +- compile:(id)data output:(ByteCodes *)codes popenv:(int)ec +{ + BOOL application = NO; + int count = 0; + + if(isTriple(data)){ + return [self special:data output:codes popenv:ec]; + } + else if(isPair(data)){ + application = YES; + while(isPair(data)){ + [self compile:[data car] output:codes popenv:0]; + count++; + if(count==1){ + [codes addTriple:[Triple newTag:IN_CHECK_PTC]]; + } + data = [data cdr]; + } + } + else if(isSymbol(data)){ + [codes addTriple:[Triple newTag:IN_TO_ARGS Arg1:data]]; + [codes addTriple:[Triple newTag:IN_LOOKUP]]; + } + else{ + [codes addTriple:[Triple newTag:IN_TO_ARGS Arg1:data]]; + } + + if(ec>0){ + [codes addTriple:[Triple newTag:IN_POP_ENV IntArg1:ec]]; + } + if(application){ + [codes addTriple:[Triple newTag:IN_APPLIC IntArg1:(count-1)]]; + } +} + +- (BOOL)compile:(id)data output:(ByteCodes *)codes +{ + errflag = NO; + errmsg = @""; + + [self compile:data output:codes popenv:0]; + return errflag; +} + +void yyrestart(FILE *); + +extern char *yyinputstr, *yyinputstart; +extern int yysofar; +extern id yyresult; +extern int yyinputline; +extern int yyinputitem; +extern BOOL yyschemeerrflag; + +NSMutableArray *positions = nil; + +#define STATS @"code: %d %d (%d) args: %d (%d) envs: %d (%d)\n" +#define PARSE_ERROR @"Parse error at item %d, line %d.\n" + +- (BOOL)processString:(NSString *)data mode:(PROCESS_MODE)pmode +{ + id forms; + int curitem = 0, curpos = 0, nextpos = 0; + + yyinputline = 0; + yyinputitem = 0; + yyschemeerrflag = NO; + + positions = [NSMutableArray arrayWithCapacity:1]; + + yyinputstr = yyinputstart = + (char *)[[data stringByAppendingString:@"\n"] cString]; + yysofar = 0; + yyrestart(NULL); + yyparse(); + + if(yyschemeerrflag==YES){ + errmsg = [NSString stringWithFormat:PARSE_ERROR, + yyinputitem+1, yyinputline+1]; + errflag = YES; + + if(delegate!=nil && pmode!=MODE_LOAD && + [delegate respondsToSelector:@selector(result:)]){ + [delegate result:[NSNull null]]; + } + + + return NO; + } + + [SCMType addToMarkables:yyresult]; + + forms = yyresult; + if(forms==[NSNull null]){ + [delegate result:[NSNull null]]; + } + + while(forms!=[NSNull null]){ + ByteCodes *codes = [ByteCodes new]; + BOOL err = [self compile:[forms arg1] output:codes]; + NSRange range; + int lower, upper; + char *first, *fp; int flen; + + #define MAXLINE 41 + #define CENTER " ... " + #define HALF ((MAXLINE-5)/2) + char second[MAXLINE+1]; + + range = [[positions objectAtIndex:curitem] rangeValue]; + nextpos = range.location; + + lower = curpos; + while(isspace(yyinputstart[lower])){ + lower++; + } + upper = nextpos; + while(isspace(yyinputstart[upper])){ + upper--; + } + + first = fp = malloc(upper-lower+2); + while(lower<=upper){ + if(isspace(yyinputstart[lower])){ + BOOL foundRet = NO; int len=0; + while(isspace(yyinputstart[lower]) && + lower<=upper){ + if(yyinputstart[lower]=='\n'){ + foundRet = YES; + } + lower++; len++; + } + + if(foundRet==YES){ + *fp++ = ' '; + } + else{ + strncpy(fp, yyinputstart+lower-len, len); + fp += len; + } + } + else{ + *fp++ = yyinputstart[lower]; + lower++; + } + } + *fp = 0; + + if((flen=strlen(first))<=MAXLINE){ + strcpy(second, first); + } + else{ + strncpy(second, first, HALF); + strcpy(second+HALF, CENTER); + strcpy(second+HALF+5, first+flen-HALF); + } + + curitem++; curpos = nextpos; + + if(err==NO){ + [self clearOutput]; + [self clearImage]; + if([self run:codes]==YES){ + NSString *msg; + + if(pmode==MODE_EVALUATE){ + [delegate + input:[NSString stringWithCString:second]]; + } + + if(pmode!=MODE_LOAD){ + if([output length]>0){ + [delegate output:@"\n"]; + [delegate output:output]; + } + if(atImgStart==NO){ + [delegate imageWindow:[self produceImage]]; + } + } + + if(pmode!=MODE_LOAD){ + [delegate result:[argStack lastObject]]; + } + + if(delegate!=nil && + [delegate respondsToSelector:@selector(statistics:)]){ + msg = [NSString stringWithFormat:STATS, + [codeStack count], maxpc, maxcode, + [argStack count], maxarg, + [envStack count], maxenv]; + [delegate statistics:msg]; + } + + [self resetStacks]; + } + } + + free(first); + + forms = [forms arg2]; + + if(errflag==YES){ + break; + } + } + + [SCMType removeFromMarkables:yyresult]; + + if(errflag==YES){ + [delegate result:[NSNull null]]; + [delegate statistics:errmsg]; + [delegate statistics:@"\n"]; + } + + // [positions release]; + + return (errflag == YES ? NO : YES); +} + +@end + +@implementation SCMImageView + +- (id)initWithFrame:(NSRect)frameRect +{ + image = nil; + return [super initWithFrame:frameRect]; +} + +- (NSImage *)image +{ + return image; +} + +- setImage:(NSImage *)anImage +{ + if(image!=nil){ + [image release]; + } + image = anImage; + if(image!=nil){ + [image retain]; + } + [self setNeedsDisplay:YES]; +} + +- (void)drawRect:(NSRect)aRect +{ + if(image!=nil){ + [image compositeToPoint:aRect.origin + fromRect:aRect + operation:NSCompositeCopy]; + } +} + +@end diff --git a/examples/allocate.scm b/examples/allocate.scm new file mode 100644 index 0000000..c087310 --- /dev/null +++ b/examples/allocate.scm @@ -0,0 +1,23 @@ + +(define l1 (list-n 500)) + +(define access-list + (lambda (l n) + (if (zero? n) l + (access-list (cdr l) (- n 1))))) +(set-cdr! (access-list l1 250) '()) + +(define l2 (list-n 500)) + +(define vectors + (lambda (mx) + (map (lambda (n) (make-vector n n)) + (list-n mx)))) + +(vectors 100) + +(list-n 1000) + +(vectors 200) + + diff --git a/examples/and-or.scm b/examples/and-or.scm new file mode 100644 index 0000000..ee40adb --- /dev/null +++ b/examples/and-or.scm @@ -0,0 +1,10 @@ +(and) (and #t #f) +(and + (begin (display 1) #t) + (begin (display 2) #f) + (begin (display 3) #f)) +(or) (or #f #t) +(or + (begin (display 1) #f) + (begin (display 2) #t) + (begin (display 3) #t)) diff --git a/examples/browse.scm b/examples/browse.scm new file mode 100644 index 0000000..3ab8743 --- /dev/null +++ b/examples/browse.scm @@ -0,0 +1,35 @@ + +(define reduce + (lambda (op base l) + (if (null? l) + (begin (browse-environment) base) + (op (car l) (reduce op base (cdr l)))))) + +(reduce + 0 '(2 3 4)) + + +(define factit + (lambda (n) + (letrec + ((fit + (lambda (n acc) + (if (= n 0) + (begin + (browse-environment) acc) + (fit (- n 1) (* n acc)))))) + (fit n 1)))) + +(factit 6) + +(define rec + (lambda (n stop) + (display n) (newline) + (if (= n 0) + (begin + (browse-environment) + (stop 0)) + (begin + (rec (- n 1) stop) + (display n) (newline))))) + +(rec 6 (lambda (x) '())) diff --git a/examples/call-cc.scm b/examples/call-cc.scm new file mode 100644 index 0000000..9977f3a --- /dev/null +++ b/examples/call-cc.scm @@ -0,0 +1,11 @@ +(define rec + (lambda (n stop) + (display n) (newline) + (if (= n 0) (stop 0) + (begin + (rec (- n 1) stop) + (display n) (newline))))) +(rec 6 (lambda (x) '())) +(call-with-current-continuation + (lambda (t) (rec 6 t))) + diff --git a/examples/call-cc1.scm b/examples/call-cc1.scm new file mode 100644 index 0000000..381d59c --- /dev/null +++ b/examples/call-cc1.scm @@ -0,0 +1,15 @@ +(define jumper + (lambda (n m) + (letrec + ((rec + (lambda (n m jump) + (if (= n 0) (jump '()) + (if (= n m) + (call-with-current-continuation + (lambda (t) (rec (- n 1) m t))) + (rec (- n 1) m jump))) + (display n) (newline)))) + (rec n m (lambda (v) v))))) +(jumper 10 3) +(jumper 6 4) + diff --git a/examples/case.scm b/examples/case.scm new file mode 100644 index 0000000..02c0aa5 --- /dev/null +++ b/examples/case.scm @@ -0,0 +1,13 @@ +(case (* 2 3) + ((2 3 5 7) 'prime) + ((1 4 6 8 9) 'composite)) +(case (car '(c d)) + ((a) 'a) + ((b) 'b)) +(case (car '(c d)) + ((a e i o u) 'vowel) + ((w y) 'semivowel) + (else 'consonant)) +(case 'a + ((b c) (display "not reached") (newline) 'b) + ((a d) (display "reached") (newline) 'a)) diff --git a/examples/characters.scm b/examples/characters.scm new file mode 100644 index 0000000..8db4326 --- /dev/null +++ b/examples/characters.scm @@ -0,0 +1,15 @@ + + +(for-each display + '(#\( #\" #\' #\a #\space #\b #\tab #\c #\))) + +;;; from comp.lang.scheme + +(let ((x (list 1)) (y (list 2))) + (for-each display + (list "Before: " "x = " (car x) " and y = " (car y) + #\newline)) + (set-car! (if #t x y) 3.1415) + (for-each display + (list "After: " "x = " (car x) " and y = " (car y) + #\newline))) diff --git a/examples/circle.scm b/examples/circle.scm new file mode 100644 index 0000000..46f12d3 --- /dev/null +++ b/examples/circle.scm @@ -0,0 +1,55 @@ + +(define pi (* 2 (acos 0))) + +(define res 200) + +(define data + (letrec + ((delta (/ (* 2 pi) res)) + (vect (make-vector res)) + (iter + (lambda (q) + (if (< q res) + (begin + (vector-set! + vect q + (cons (cos (* q delta)) + (sin (* q delta)))) + (iter (+ 1 q))))))) + (iter 0) + vect)) + +(define draw-circle + (lambda (radius) + (letrec + ((iter + (lambda (q) + (if (< q res) + (begin + (draw-line + (* radius (car (vector-ref data q))) + (* radius (cdr (vector-ref data q)))) + (iter (+ 1 q))))))) + (draw-move radius 0) + (iter 0) + (draw-line radius 0)))) + +(define steps 8) + +(define circles + (lambda (maxrad) + (letrec + ((iter + (lambda (q) + (if (< q maxrad) + (begin + (draw-color 0 (/ (* 255.0 q) maxrad) 0) + (draw-circle q) + (iter (+ q steps))))))) + (iter 1)))) + +(circles 100) + + + + diff --git a/examples/circular.scm b/examples/circular.scm new file mode 100644 index 0000000..ff4f939 --- /dev/null +++ b/examples/circular.scm @@ -0,0 +1,19 @@ +(define a '(1 2 (3 4) (5 6) 7 8)) + +(set-cdr! (car (cdr (cdr a))) (cdr a)) +(begin (display a) (newline)) + +(set-cdr! (cdr (cdr (cdr (cdr (cdr a))))) a) +(begin (display a) (newline)) + +(define v (make-vector 5 '())) +(vector-set! v 2 v) +(begin (display v) (newline)) + +(define a '(1 2)) +(define v (make-vector 2)) +(set-cdr! a v) +(vector-set! v 0 a) + +a +v diff --git a/examples/cond.scm b/examples/cond.scm new file mode 100644 index 0000000..db6ea26 --- /dev/null +++ b/examples/cond.scm @@ -0,0 +1,28 @@ +;;; library required + +(cond ((> 3 2) (display 'here) (newline) 'greater) + ((< 3 2) (display 'there) (newline) 'less)) +(cond ((> 3 3) 'greater) + ((< 3 3) 'less) + (else 'equal)) +(cond + (#f 'not-reached) + ((assq 'c '((a 1) (b 2) (c 3))) => cdr)) + +;;; syntax errors +;;; (cond ()) +;;; (cond (else 'a) (else 'b)) +;;; (cond (#t =>)) + +(define testcond + (lambda (l) + (cond + ((assq 'a l) => (lambda (p) (set-car! p 'd))) + ((assq 'b l) => (lambda (p) (set-car! p 'e))) + ((assq 'c l) => (lambda (p) (set-car! p 'f)))))) + +(define l '((a 1) (b 2) (c 3))) +(testcond l) +(testcond l) +(testcond l) +l diff --git a/examples/deep-recursion.scm b/examples/deep-recursion.scm new file mode 100644 index 0000000..659bd38 --- /dev/null +++ b/examples/deep-recursion.scm @@ -0,0 +1,11 @@ + +(define r + (lambda (n) + (if (= n 0) '() + (r (- n 1))))) + + +(r 10) + + +(r -10) diff --git a/examples/eq-mem-association.scm b/examples/eq-mem-association.scm new file mode 100644 index 0000000..a654273 --- /dev/null +++ b/examples/eq-mem-association.scm @@ -0,0 +1,10 @@ +;;; library required + +(define l '(a (1 2 (3 4) 5) b)) +(memv 'a l) +(memv '(1 2 (3 4) 5) l) +(member '(1 2 (3 4) 5) l) +(define k '((a 1) (b 2) ((((a))) 3))) +(assq 'a k) +(assq '(((a))) k) +(assoc '(((a))) k) diff --git a/examples/factorial.scm b/examples/factorial.scm new file mode 100644 index 0000000..f533a9c --- /dev/null +++ b/examples/factorial.scm @@ -0,0 +1,16 @@ +(define factorial + (lambda (n) + (if (= 0 n) 1 + (* n (factorial (- n 1)))))) + +(factorial 6) + +(define factit + (lambda (n) + (letrec + ((fit + (lambda (n acc) + (if (= n 0) acc (fit (- n 1) (* n acc)))))) + (fit n 1)))) + +(factit 6) diff --git a/examples/koch-curve.scm b/examples/koch-curve.scm new file mode 100644 index 0000000..10650e4 --- /dev/null +++ b/examples/koch-curve.scm @@ -0,0 +1,27 @@ +(define koch + (let ((s (/ (sqrt 3) 2 3))) + (lambda (res depth) + (letrec + ((iter + (lambda (x1 y1 x2 y2 d) + (if (zero? d) + (draw-line x2 y2) + (let* ((dx (- x2 x1)) + (dy (- y2 y1)) + (thx (+ x1 (/ dx 3))) + (thy (+ y1 (/ dy 3))) + (thx2 (+ x1 (* 2 (/ dx 3)))) + (thy2 (+ y1 (* 2 (/ dy 3)))) + (mx (/ (+ x1 x2) 2)) + (my (/ (+ y1 y2) 2)) + (midx (+ mx (* (- dy) s))) + (midy (+ my (* dx s)))) + (iter x1 y1 thx thy (- d 1)) + (iter thx thy midx midy (- d 1)) + (iter midx midy thx2 thy2 (- d 1)) + (iter thx2 thy2 x2 y2 (- d 1))))))) + (draw-move 0 0) + (draw-color 0 255 0) + (iter 0 0 res 0 depth))))) + +(koch 200 4) diff --git a/examples/let-over-lambda.scm b/examples/let-over-lambda.scm new file mode 100644 index 0000000..6305120 --- /dev/null +++ b/examples/let-over-lambda.scm @@ -0,0 +1,3 @@ +(define count + (let ((c 0)) (lambda () (set! c (+ 1 c)) c))) +(count) (count) (count) diff --git a/examples/letrec.scm b/examples/letrec.scm new file mode 100644 index 0000000..6d318c8 --- /dev/null +++ b/examples/letrec.scm @@ -0,0 +1,11 @@ + +(define (a proc) + (proc 5)) + +(letrec + ((res '())) + (a + (lambda (arg) + (if (< arg 0) + (set! res (- arg)) + (set! res arg))))) diff --git a/examples/library.scm b/examples/library.scm new file mode 100644 index 0000000..b08daa4 --- /dev/null +++ b/examples/library.scm @@ -0,0 +1,109 @@ + +(define vector + (lambda args + (list->vector args))) + + +(define list-n + (lambda (n) + (if (zero? n) '() + (cons n (list-n (- n 1)))))) + +(define list-ref + (lambda (l n) + (if (zero? n) + (car l) + (list-ref (cdr l) (- n 1))))) + +(define length + (lambda (l) + (if (or (null? l) (not (pair? l))) 0 + (+ 1 (length (cdr l)))))) + +(define filter + (lambda (l f) + (if (null? l) '() + (if (f (car l)) + (cons (car l) (filter (cdr l) f)) + (filter (cdr l) f))))) + +(define reverse + (letrec + ((rev + (lambda (l acc) + (if (null? l) acc + (rev (cdr l) (cons (car l) acc)))))) + (lambda (l) + (rev l '())))) + +(define append + (lambda (l . ls) + (if (null? l) + (if (pair? ls) + (if (pair? (cdr ls)) + (apply append ls) + (car ls)) ls) + (cons (car l) + (apply append (cons (cdr l) ls)))))) + +(define eqv? eq?) +(define equal? + (lambda (obj1 obj2) + (if (and (pair? obj1) (pair? obj2)) + (and (equal? (car obj1) (car obj2)) + (equal? (cdr obj1) (cdr obj2))) + (if (or (pair? obj1) (pair? obj2)) #f + (eqv? obj1 obj2))))) + +(define memgeneric + (lambda (obj l pred) + (if (null? l) '() + (if (pred obj (car l)) l + (memgeneric obj (cdr l) pred))))) + +(define memq + (lambda (obj l) (memgeneric obj l eq?))) +(define memv + (lambda (obj l) (memgeneric obj l eqv?))) +(define member + (lambda (obj l) (memgeneric obj l equal?))) + +(define association + (lambda (obj l pred) + (if (null? l) #f + (if (and (pair? (car l)) + (pred obj (car (car l)))) + (car l) + (association obj (cdr l) pred))))) + +(define assq + (lambda (obj l) (association obj l eq?))) +(define assv + (lambda (obj l) (association obj l eqv?))) +(define assoc + (lambda (obj l) (association obj l equal?))) + + +(define map-over-single-list + (lambda (p l) + (if (null? l) '() + (cons (p (car l)) + (map-over-single-list p (cdr l)))))) + +(define map + (lambda (proc . lists) + (if (memq '() lists) '() + (cons + (apply proc + (map-over-single-list car lists)) + (apply map + (cons proc (map-over-single-list cdr lists))))))) + +(define for-each + (lambda (proc . lists) + (if (memq '() lists) '() + (begin + (apply proc + (map-over-single-list car lists)) + (apply for-each + (cons proc (map-over-single-list cdr lists))))))) diff --git a/examples/list-misc.scm b/examples/list-misc.scm new file mode 100644 index 0000000..89da052 --- /dev/null +++ b/examples/list-misc.scm @@ -0,0 +1,12 @@ +;;; library required + +(reverse '(a b c d e f)) + +(filter '(1 2 a b 3 c 4 5 d e f) number?) + +(define l '(1 2 3 4 5)) +(append l '(6 7 8)) +(append l '(6 7 8) '(9 10 11)) +(append l '(6 7 8 (9 10 11))) +(append l 6) + diff --git a/examples/misc.scm b/examples/misc.scm new file mode 100644 index 0000000..35dd3fe --- /dev/null +++ b/examples/misc.scm @@ -0,0 +1,4 @@ + +(define (a x y . rest ) (+ x y (apply * rest))) +(a 1 2 3 4 5) + diff --git a/examples/plotter.scm b/examples/plotter.scm new file mode 100644 index 0000000..85b3197 --- /dev/null +++ b/examples/plotter.scm @@ -0,0 +1,26 @@ +(define plotter + (lambda (f res x1 x2 y1 y2) + (let* ((dx (- x2 x1)) (dy (- y2 y1)) (delta (/ dx res))) + (letrec + ((scaled + (lambda (f x y) + (f + (* res (/ (- x x1) dx)) + (* res (/ (- y y1) dy))))) + (plotit + (lambda (x) + (scaled draw-line x (f x)) + (if (< x x2) (plotit (+ x delta)))))) + (draw-color 0 0 0) + (scaled draw-move 0 y1) + (scaled draw-line 0 y2) + (scaled draw-move x1 0) + (scaled draw-line x2 0) + (draw-color 255 0 0) + (scaled draw-move x1 (f x1)) + (plotit x1))))) + +(plotter (lambda (x) (* x x x)) 70 -5.0 5.0 -50.0 50.0) +(plotter sin 50 -5.0 5.0 -1.0 1.0) +(plotter (lambda (x) (* x (sin x))) 100 -25.0 25.0 -25.0 25.0) +(plotter (lambda (x) (+ (* x x) (* -5 x) 6)) 80 -1.0 5.0 -3.0 10.0) diff --git a/examples/primes.scm b/examples/primes.scm new file mode 100644 index 0000000..05d0142 --- /dev/null +++ b/examples/primes.scm @@ -0,0 +1,32 @@ +(define primes + ;;; check for composite numbers by testing the + ;;; most probable divisors first + (let* ((start (list 2)) + (end start)) + (letrec + ((composite? + (lambda (v l) + (let ((d (car l))) + (if (> (* d d) v) #f + (if (zero? (remainder v d)) #t + (composite? v (cdr l))))))) + (findnext + (lambda (v) + (if (composite? v start) + (findnext (+ v 1)) v)))) + (lambda () + (let* ((current (car end)) + (next (findnext (+ current 1))) + (p (cons next '()))) + (set-cdr! end p) + (set! end p) + current))))) + +(define displayprimes + (lambda (n) + (if (not (zero? n)) + (begin + (display (primes)) (newline) + (displayprimes (- n 1)))))) + +(displayprimes 14) diff --git a/examples/queens.scm b/examples/queens.scm new file mode 100644 index 0000000..53d54e0 --- /dev/null +++ b/examples/queens.scm @@ -0,0 +1,103 @@ + +(define allqueens + (lambda (n doneproc) + (letrec + ((diag1 + (lambda (board col) + (if (null? board) '() + (cons (+ col (car board)) + (diag1 (cdr board) (+ col 1)))))) + (diag2 + (lambda (board col) + (if (null? board) '() + (cons (- col (car board)) + (diag2 (cdr board) (+ col 1)))))) + (consistent? + (lambda (board col new) + (not + (or (member new board) + (member (+ col new) + (diag1 board 1)) + (member (- col new) + (diag2 board 1)))))) + (check + (lambda (board col) + (if (> col n) (doneproc board) + (for-each + (lambda (row) + (if (consistent? board col row) + (check (append board (list row)) + (+ 1 col)))) + (list-n n)))))) + (check '() 1)))) + +(define showqueens + (lambda (n) + (allqueens + n (lambda (sol) (display sol) (newline))))) + +(showqueens 4) + +(define queens + (lambda (n) + (letrec + ((y-reflect reverse) + (rotate + (lambda (board) + (map + (lambda (row) + (- (+ 1 n) (length (member row board)))) + (list-n n)))) + (symmetries + (lambda (board) + (list + board + (rotate board) + (rotate (rotate board)) + (rotate (rotate (rotate board))) + (y-reflect board) + (rotate (y-reflect board)) + (rotate (rotate (y-reflect board))) + (rotate (rotate (rotate (y-reflect board))))))) + (result '()) + (new? + (lambda (rlist sol) + (if (null? rlist) #t + (if (member sol (car rlist)) #f + (new? (cdr rlist) sol)))))) + (allqueens + n + (lambda (sol) + (if (new? result sol) + (set! result (cons (symmetries sol) result))))) + (map car result)))) + +(define printunique + (lambda (n) + (for-each + (lambda (sol) + (let ((vect (make-vector (* n n) #\.))) + (for-each + (lambda (col) + (vector-set! + vect + (- (+ (* n (- n (list-ref sol (- col 1)))) col) 1) + #\*)) + (list-n n)) + (for-each + (lambda (pos) + (display (vector-ref vect (- pos 1))) + (display #\space) + (if (zero? (remainder pos n)) (newline))) + (reverse (list-n (* n n)))) + (newline))) + (queens n)))) + +(printunique 5) + +(define values + (lambda (n) + (map length + (map (lambda (k) + (display k) (newline) (queens k)) + (reverse (list-n n)))))) diff --git a/examples/reduce.scm b/examples/reduce.scm new file mode 100644 index 0000000..9cf53d5 --- /dev/null +++ b/examples/reduce.scm @@ -0,0 +1,8 @@ +(define reduce + (lambda (op base l) + (if (null? l) base + (op (car l) (reduce op base (cdr l)))))) +(reduce + 0 '(2 3 4)) +(reduce * 1 '(2 3 4)) +(reduce cons '() '(2 3 4)) + diff --git a/examples/rootfinder.scm b/examples/rootfinder.scm new file mode 100644 index 0000000..b6142d7 --- /dev/null +++ b/examples/rootfinder.scm @@ -0,0 +1,32 @@ +(define rootfinder + (let ((epsilon 1e-8)) + (lambda (p a b) + (let ((mid (/ (+ a b) 2.0))) + (if (< (- b a) epsilon) mid + (let + ((s1 (if (> (p a) 0) 'pos 'neg)) + (s2 (if (> (p mid) 0) 'pos 'neg))) + (if (eq? s1 s2) + (rootfinder p mid b) + (rootfinder p a mid)))))))) + +(define sqrteq + (lambda (a) + (lambda (x) + (- (* x x) a)))) + +(define r5 (rootfinder (sqrteq 5) 0 5)) +r5 +(* r5 r5) + +(define cbrteq + (lambda (a) + (lambda (x) + (- (* x x x) a)))) + +(define cr7 (rootfinder (cbrteq 7) 0 7)) +cr7 +(* cr7 cr7 cr7) + +(define pi (rootfinder (lambda (x) (cos (/ x 2))) 3 4)) +pi diff --git a/examples/simple.scm b/examples/simple.scm new file mode 100644 index 0000000..687d1c4 --- /dev/null +++ b/examples/simple.scm @@ -0,0 +1,13 @@ +(define a + (lambda (x) + (lambda (y) + (+ x y)))) + + +(define a5 (a 5)) +(define a7 (a 7)) + + +(a5 4) +(a7 2) + diff --git a/examples/tail-recursion.scm b/examples/tail-recursion.scm new file mode 100644 index 0000000..28b85b9 --- /dev/null +++ b/examples/tail-recursion.scm @@ -0,0 +1,7 @@ +(define tailrec + (lambda (n) + (display n) (newline) + (if (= n 0) '() + (tailrec (- n 1))))) +(tailrec 5) + diff --git a/lex.yy.c b/lex.yy.c new file mode 100644 index 0000000..bd210a7 --- /dev/null +++ b/lex.yy.c @@ -0,0 +1,1939 @@ +/* A lexical scanner generated by flex */ + +/* Scanner skeleton version: + * $Header: /home/daffy/u0/vern/flex/RCS/flex.skl,v 2.91 96/09/10 16:58:48 vern Exp $ + */ + +#define FLEX_SCANNER +#define YY_FLEX_MAJOR_VERSION 2 +#define YY_FLEX_MINOR_VERSION 5 + +#include + + +/* cfront 1.2 defines "c_plusplus" instead of "__cplusplus" */ +#ifdef c_plusplus +#ifndef __cplusplus +#define __cplusplus +#endif +#endif + + +#ifdef __cplusplus + +#include +#include + +/* Use prototypes in function declarations. */ +#define YY_USE_PROTOS + +/* The "const" storage-class-modifier is valid. */ +#define YY_USE_CONST + +#else /* ! __cplusplus */ + +#if __STDC__ + +#define YY_USE_PROTOS +#define YY_USE_CONST + +#endif /* __STDC__ */ +#endif /* ! __cplusplus */ + +#ifdef __TURBOC__ + #pragma warn -rch + #pragma warn -use +#include +#include +#define YY_USE_CONST +#define YY_USE_PROTOS +#endif + +#ifdef YY_USE_CONST +#define yyconst const +#else +#define yyconst +#endif + + +#ifdef YY_USE_PROTOS +#define YY_PROTO(proto) proto +#else +#define YY_PROTO(proto) () +#endif + +/* Returned upon end-of-file. */ +#define YY_NULL 0 + +/* Promotes a possibly negative, possibly signed char to an unsigned + * integer for use as an array index. If the signed char is negative, + * we want to instead treat it as an 8-bit unsigned char, hence the + * double cast. + */ +#define YY_SC_TO_UI(c) ((unsigned int) (unsigned char) c) + +/* Enter a start condition. This macro really ought to take a parameter, + * but we do it the disgusting crufty way forced on us by the ()-less + * definition of BEGIN. + */ +#define BEGIN yy_start = 1 + 2 * + +/* Translate the current start state into a value that can be later handed + * to BEGIN to return to the state. The YYSTATE alias is for lex + * compatibility. + */ +#define YY_START ((yy_start - 1) / 2) +#define YYSTATE YY_START + +/* Action number for EOF rule of a given start state. */ +#define YY_STATE_EOF(state) (YY_END_OF_BUFFER + state + 1) + +/* Special action meaning "start processing a new file". */ +#define YY_NEW_FILE yyrestart( yyin ) + +#define YY_END_OF_BUFFER_CHAR 0 + +/* Size of default input buffer. */ +#define YY_BUF_SIZE 16384 + +typedef struct yy_buffer_state *YY_BUFFER_STATE; + +extern int yyleng; +extern FILE *yyin, *yyout; + +#define EOB_ACT_CONTINUE_SCAN 0 +#define EOB_ACT_END_OF_FILE 1 +#define EOB_ACT_LAST_MATCH 2 + +/* The funky do-while in the following #define is used to turn the definition + * int a single C statement (which needs a semi-colon terminator). This + * avoids problems with code like: + * + * if ( condition_holds ) + * yyless( 5 ); + * else + * do_something_else(); + * + * Prior to using the do-while the compiler would get upset at the + * "else" because it interpreted the "if" statement as being all + * done when it reached the ';' after the yyless() call. + */ + +/* Return all but the first 'n' matched characters back to the input stream. */ + +#define yyless(n) \ + do \ + { \ + /* Undo effects of setting up yytext. */ \ + *yy_cp = yy_hold_char; \ + YY_RESTORE_YY_MORE_OFFSET \ + yy_c_buf_p = yy_cp = yy_bp + n - YY_MORE_ADJ; \ + YY_DO_BEFORE_ACTION; /* set up yytext again */ \ + } \ + while ( 0 ) + +#define unput(c) yyunput( c, yytext_ptr ) + +/* The following is because we cannot portably get our hands on size_t + * (without autoconf's help, which isn't available because we want + * flex-generated scanners to compile on their own). + */ +typedef unsigned int yy_size_t; + + +struct yy_buffer_state + { + FILE *yy_input_file; + + char *yy_ch_buf; /* input buffer */ + char *yy_buf_pos; /* current position in input buffer */ + + /* Size of input buffer in bytes, not including room for EOB + * characters. + */ + yy_size_t yy_buf_size; + + /* Number of characters read into yy_ch_buf, not including EOB + * characters. + */ + int yy_n_chars; + + /* Whether we "own" the buffer - i.e., we know we created it, + * and can realloc() it to grow it, and should free() it to + * delete it. + */ + int yy_is_our_buffer; + + /* Whether this is an "interactive" input source; if so, and + * if we're using stdio for input, then we want to use getc() + * instead of fread(), to make sure we stop fetching input after + * each newline. + */ + int yy_is_interactive; + + /* Whether we're considered to be at the beginning of a line. + * If so, '^' rules will be active on the next match, otherwise + * not. + */ + int yy_at_bol; + + /* Whether to try to fill the input buffer when we reach the + * end of it. + */ + int yy_fill_buffer; + + int yy_buffer_status; +#define YY_BUFFER_NEW 0 +#define YY_BUFFER_NORMAL 1 + /* When an EOF's been seen but there's still some text to process + * then we mark the buffer as YY_EOF_PENDING, to indicate that we + * shouldn't try reading from the input source any more. We might + * still have a bunch of tokens to match, though, because of + * possible backing-up. + * + * When we actually see the EOF, we change the status to "new" + * (via yyrestart()), so that the user can continue scanning by + * just pointing yyin at a new input file. + */ +#define YY_BUFFER_EOF_PENDING 2 + }; + +static YY_BUFFER_STATE yy_current_buffer = 0; + +/* We provide macros for accessing buffer states in case in the + * future we want to put the buffer states in a more general + * "scanner state". + */ +#define YY_CURRENT_BUFFER yy_current_buffer + + +/* yy_hold_char holds the character lost when yytext is formed. */ +static char yy_hold_char; + +static int yy_n_chars; /* number of characters read into yy_ch_buf */ + + +int yyleng; + +/* Points to current character in buffer. */ +static char *yy_c_buf_p = (char *) 0; +static int yy_init = 1; /* whether we need to initialize */ +static int yy_start = 0; /* start state number */ + +/* Flag which is used to allow yywrap()'s to do buffer switches + * instead of setting up a fresh yyin. A bit of a hack ... + */ +static int yy_did_buffer_switch_on_eof; + +void yyrestart YY_PROTO(( FILE *input_file )); + +void yy_switch_to_buffer YY_PROTO(( YY_BUFFER_STATE new_buffer )); +void yy_load_buffer_state YY_PROTO(( void )); +YY_BUFFER_STATE yy_create_buffer YY_PROTO(( FILE *file, int size )); +void yy_delete_buffer YY_PROTO(( YY_BUFFER_STATE b )); +void yy_init_buffer YY_PROTO(( YY_BUFFER_STATE b, FILE *file )); +void yy_flush_buffer YY_PROTO(( YY_BUFFER_STATE b )); +#define YY_FLUSH_BUFFER yy_flush_buffer( yy_current_buffer ) + +YY_BUFFER_STATE yy_scan_buffer YY_PROTO(( char *base, yy_size_t size )); +YY_BUFFER_STATE yy_scan_string YY_PROTO(( yyconst char *yy_str )); +YY_BUFFER_STATE yy_scan_bytes YY_PROTO(( yyconst char *bytes, int len )); + +static void *yy_flex_alloc YY_PROTO(( yy_size_t )); +static void *yy_flex_realloc YY_PROTO(( void *, yy_size_t )); +static void yy_flex_free YY_PROTO(( void * )); + +#define yy_new_buffer yy_create_buffer + +#define yy_set_interactive(is_interactive) \ + { \ + if ( ! yy_current_buffer ) \ + yy_current_buffer = yy_create_buffer( yyin, YY_BUF_SIZE ); \ + yy_current_buffer->yy_is_interactive = is_interactive; \ + } + +#define yy_set_bol(at_bol) \ + { \ + if ( ! yy_current_buffer ) \ + yy_current_buffer = yy_create_buffer( yyin, YY_BUF_SIZE ); \ + yy_current_buffer->yy_at_bol = at_bol; \ + } + +#define YY_AT_BOL() (yy_current_buffer->yy_at_bol) + +typedef unsigned char YY_CHAR; +FILE *yyin = (FILE *) 0, *yyout = (FILE *) 0; +typedef int yy_state_type; +extern char *yytext; +#define yytext_ptr yytext + +static yy_state_type yy_get_previous_state YY_PROTO(( void )); +static yy_state_type yy_try_NUL_trans YY_PROTO(( yy_state_type current_state )); +static int yy_get_next_buffer YY_PROTO(( void )); +static void yy_fatal_error YY_PROTO(( yyconst char msg[] )); + +/* Done after the current pattern has been matched and before the + * corresponding action - sets up yytext. + */ +#define YY_DO_BEFORE_ACTION \ + yytext_ptr = yy_bp; \ + yyleng = (int) (yy_cp - yy_bp); \ + yy_hold_char = *yy_cp; \ + *yy_cp = '\0'; \ + yy_c_buf_p = yy_cp; + +#define YY_NUM_RULES 37 +#define YY_END_OF_BUFFER 38 +static yyconst short int yy_accept[143] = + { 0, + 0, 0, 38, 36, 34, 35, 27, 36, 36, 2, + 31, 32, 27, 33, 26, 36, 27, 27, 27, 28, + 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, + 34, 0, 29, 0, 30, 0, 20, 0, 26, 22, + 0, 23, 0, 0, 27, 3, 28, 28, 28, 28, + 28, 28, 28, 28, 28, 10, 28, 28, 13, 28, + 28, 21, 21, 21, 21, 0, 0, 0, 24, 0, + 1, 12, 28, 28, 28, 28, 28, 28, 28, 28, + 17, 28, 28, 0, 0, 0, 0, 25, 28, 28, + 28, 14, 15, 28, 16, 28, 18, 28, 28, 8, + + 0, 0, 6, 11, 28, 28, 28, 28, 4, 0, + 0, 28, 7, 9, 19, 0, 28, 0, 28, 28, + 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, + 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, + 5, 0 + } ; + +static yyconst int yy_ec[256] = + { 0, + 1, 1, 1, 1, 1, 1, 1, 1, 2, 3, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 2, 4, 5, 6, 1, 1, 1, 7, 8, + 9, 10, 11, 1, 12, 13, 14, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 1, 16, 17, + 18, 19, 20, 1, 21, 21, 21, 21, 22, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 1, 23, 1, 1, 1, 1, 24, 25, 26, 27, + + 28, 29, 30, 31, 32, 21, 21, 33, 34, 35, + 36, 37, 38, 39, 40, 41, 42, 21, 43, 21, + 44, 21, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1 + } ; + +static yyconst int yy_meta[45] = + { 0, + 1, 2, 3, 4, 1, 1, 1, 1, 1, 4, + 4, 4, 1, 4, 4, 1, 4, 4, 4, 4, + 4, 4, 1, 4, 4, 4, 4, 4, 4, 4, + 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, + 4, 4, 4, 4 + } ; + +static yyconst short int yy_base[148] = + { 0, + 0, 0, 341, 389, 334, 389, 389, 40, 38, 389, + 389, 389, 34, 319, 40, 0, 312, 295, 282, 38, + 40, 44, 46, 61, 63, 49, 64, 66, 70, 75, + 297, 86, 389, 88, 389, 59, 389, 281, 95, 103, + 76, 279, 109, 269, 389, 389, 77, 106, 109, 112, + 117, 118, 120, 123, 124, 125, 136, 140, 143, 147, + 149, 389, 240, 222, 228, 120, 150, 225, 210, 218, + 389, 156, 158, 162, 164, 165, 169, 167, 178, 182, + 185, 190, 199, 143, 156, 148, 156, 139, 191, 194, + 203, 198, 202, 206, 207, 210, 218, 222, 223, 224, + + 108, 113, 226, 229, 235, 237, 238, 243, 244, 81, + 74, 250, 246, 251, 257, 66, 263, 37, 264, 269, + 265, 266, 270, 277, 278, 282, 283, 295, 300, 291, + 302, 303, 308, 311, 309, 315, 322, 323, 328, 337, + 339, 389, 372, 376, 53, 380, 384 + } ; + +static yyconst short int yy_def[148] = + { 0, + 142, 1, 142, 142, 142, 142, 142, 143, 142, 142, + 142, 142, 142, 142, 142, 144, 142, 142, 142, 145, + 145, 145, 145, 145, 145, 145, 145, 145, 145, 145, + 142, 143, 142, 142, 142, 146, 142, 142, 142, 142, + 142, 142, 142, 147, 142, 142, 145, 145, 145, 145, + 145, 145, 145, 145, 145, 145, 145, 145, 145, 145, + 145, 142, 142, 142, 142, 142, 142, 142, 142, 147, + 142, 145, 145, 145, 145, 145, 145, 145, 145, 145, + 145, 145, 145, 142, 142, 142, 142, 142, 145, 145, + 145, 145, 145, 145, 145, 145, 145, 145, 145, 145, + + 142, 142, 145, 145, 145, 145, 145, 145, 145, 142, + 142, 145, 145, 145, 145, 142, 145, 142, 145, 145, + 145, 145, 145, 145, 145, 145, 145, 145, 145, 145, + 145, 145, 145, 145, 145, 145, 145, 145, 145, 145, + 145, 0, 142, 142, 142, 142, 142 + } ; + +static yyconst short int yy_nxt[434] = + { 0, + 4, 5, 6, 7, 8, 9, 10, 11, 12, 7, + 13, 13, 14, 7, 15, 16, 17, 18, 19, 7, + 20, 20, 4, 21, 22, 23, 24, 25, 20, 20, + 20, 26, 27, 20, 20, 28, 20, 29, 20, 30, + 20, 20, 20, 20, 33, 35, 38, 48, 39, 48, + 41, 41, 42, 48, 39, 48, 47, 48, 48, 48, + 36, 43, 34, 48, 62, 48, 37, 43, 48, 52, + 48, 51, 48, 48, 49, 48, 50, 56, 37, 48, + 48, 53, 48, 48, 48, 48, 48, 57, 54, 48, + 33, 58, 32, 63, 48, 55, 48, 43, 64, 65, + + 118, 62, 61, 43, 59, 41, 41, 42, 34, 39, + 32, 60, 116, 66, 66, 48, 43, 40, 48, 68, + 68, 48, 43, 69, 67, 48, 48, 48, 48, 48, + 67, 48, 48, 48, 48, 72, 48, 48, 111, 48, + 110, 67, 48, 48, 48, 48, 74, 67, 73, 48, + 75, 78, 48, 88, 77, 48, 48, 76, 48, 48, + 87, 87, 48, 79, 88, 48, 48, 48, 48, 80, + 88, 48, 62, 48, 48, 48, 48, 48, 48, 102, + 81, 48, 82, 48, 48, 101, 48, 48, 48, 83, + 89, 48, 92, 90, 97, 93, 91, 48, 94, 48, + + 48, 48, 100, 48, 48, 95, 96, 48, 48, 48, + 48, 48, 48, 48, 105, 48, 48, 48, 48, 48, + 71, 48, 48, 98, 69, 48, 48, 48, 104, 48, + 99, 48, 48, 48, 103, 48, 107, 48, 48, 69, + 106, 48, 48, 48, 48, 48, 48, 48, 48, 108, + 109, 86, 48, 48, 48, 48, 48, 48, 85, 48, + 48, 114, 48, 48, 113, 48, 48, 84, 115, 48, + 48, 71, 48, 48, 48, 48, 48, 112, 48, 48, + 121, 117, 48, 48, 48, 48, 48, 48, 48, 48, + 122, 48, 48, 40, 120, 40, 48, 48, 31, 45, + + 48, 48, 48, 119, 48, 126, 129, 123, 124, 48, + 48, 48, 48, 46, 48, 125, 127, 48, 48, 48, + 48, 48, 48, 128, 48, 130, 131, 48, 48, 45, + 48, 48, 48, 40, 48, 31, 132, 48, 137, 134, + 142, 48, 48, 133, 142, 135, 48, 48, 48, 142, + 136, 142, 142, 142, 139, 142, 48, 142, 48, 142, + 142, 142, 138, 140, 142, 142, 142, 142, 142, 142, + 142, 141, 32, 32, 142, 32, 44, 44, 142, 44, + 62, 142, 142, 62, 70, 70, 70, 70, 3, 142, + 142, 142, 142, 142, 142, 142, 142, 142, 142, 142, + + 142, 142, 142, 142, 142, 142, 142, 142, 142, 142, + 142, 142, 142, 142, 142, 142, 142, 142, 142, 142, + 142, 142, 142, 142, 142, 142, 142, 142, 142, 142, + 142, 142, 142 + } ; + +static yyconst short int yy_chk[434] = + { 0, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 8, 9, 13, 20, 13, 21, + 15, 15, 15, 22, 15, 23, 145, 20, 26, 21, + 9, 15, 8, 22, 118, 23, 9, 15, 26, 23, + 24, 22, 25, 27, 21, 28, 21, 26, 9, 29, + 24, 23, 25, 27, 30, 28, 47, 27, 24, 29, + 32, 27, 34, 36, 30, 25, 47, 41, 36, 36, + + 116, 111, 30, 41, 28, 39, 39, 39, 32, 39, + 34, 29, 110, 40, 40, 48, 39, 40, 49, 43, + 43, 50, 39, 43, 40, 48, 51, 52, 49, 53, + 40, 50, 54, 55, 56, 49, 51, 52, 102, 53, + 101, 66, 54, 55, 56, 57, 51, 66, 50, 58, + 52, 54, 59, 88, 53, 57, 60, 52, 61, 58, + 67, 67, 59, 55, 67, 72, 60, 73, 61, 57, + 87, 74, 86, 75, 76, 72, 78, 73, 77, 85, + 58, 74, 60, 75, 76, 84, 78, 79, 77, 61, + 73, 80, 76, 74, 81, 77, 75, 79, 78, 82, + + 89, 80, 83, 90, 81, 79, 80, 92, 83, 82, + 89, 93, 91, 90, 91, 94, 95, 92, 83, 96, + 70, 93, 91, 81, 69, 94, 95, 97, 90, 96, + 82, 98, 99, 100, 89, 103, 96, 97, 104, 68, + 94, 98, 99, 100, 105, 103, 106, 107, 104, 98, + 99, 65, 108, 109, 105, 113, 106, 107, 64, 112, + 114, 107, 108, 109, 106, 113, 115, 63, 108, 112, + 114, 44, 117, 119, 121, 122, 115, 105, 120, 123, + 120, 112, 117, 119, 121, 122, 124, 125, 120, 123, + 121, 126, 127, 42, 119, 38, 124, 125, 31, 19, + + 130, 126, 127, 117, 128, 125, 128, 122, 123, 129, + 130, 131, 132, 18, 128, 124, 126, 133, 135, 129, + 134, 131, 132, 127, 136, 129, 130, 133, 135, 17, + 134, 137, 138, 14, 136, 5, 131, 139, 136, 133, + 3, 137, 138, 132, 0, 134, 140, 139, 141, 0, + 135, 0, 0, 0, 138, 0, 140, 0, 141, 0, + 0, 0, 137, 139, 0, 0, 0, 0, 0, 0, + 0, 140, 143, 143, 0, 143, 144, 144, 0, 144, + 146, 0, 0, 146, 147, 147, 147, 147, 142, 142, + 142, 142, 142, 142, 142, 142, 142, 142, 142, 142, + + 142, 142, 142, 142, 142, 142, 142, 142, 142, 142, + 142, 142, 142, 142, 142, 142, 142, 142, 142, 142, + 142, 142, 142, 142, 142, 142, 142, 142, 142, 142, + 142, 142, 142 + } ; + +static yy_state_type yy_last_accepting_state; +static char *yy_last_accepting_cpos; + +/* The intent behind this definition is that it'll catch + * any uses of REJECT which flex missed. + */ +#define REJECT reject_used_but_not_detected +#define yymore() yymore_used_but_not_detected +#define YY_MORE_ADJ 0 +#define YY_RESTORE_YY_MORE_OFFSET +char *yytext; +#line 1 "scheme.flex" +#define INITIAL 0 +#line 2 "scheme.flex" +#import +#import + +#import "SchemeTypes.h" + +#define YYSTYPE id + +#include "scheme.tab.m.h" + +int yyinputline; +char *yyinputstr, *yyinputstart; +int yysofar; + +#define YY_INPUT(buf,result,max_size) \ + { \ + int c = *yyinputstr++; \ + result = (!c) ? YY_NULL : (buf[0] = c, 1); \ + } +#line 525 "lex.yy.c" + +/* Macros after this point can all be overridden by user definitions in + * section 1. + */ + +#ifndef YY_SKIP_YYWRAP +#ifdef __cplusplus +extern "C" int yywrap YY_PROTO(( void )); +#else +extern int yywrap YY_PROTO(( void )); +#endif +#endif + +#ifndef YY_NO_UNPUT +static void yyunput YY_PROTO(( int c, char *buf_ptr )); +#endif + +#ifndef yytext_ptr +static void yy_flex_strncpy YY_PROTO(( char *, yyconst char *, int )); +#endif + +#ifdef YY_NEED_STRLEN +static int yy_flex_strlen YY_PROTO(( yyconst char * )); +#endif + +#ifndef YY_NO_INPUT +#ifdef __cplusplus +static int yyinput YY_PROTO(( void )); +#else +static int input YY_PROTO(( void )); +#endif +#endif + +#if YY_STACK_USED +static int yy_start_stack_ptr = 0; +static int yy_start_stack_depth = 0; +static int *yy_start_stack = 0; +#ifndef YY_NO_PUSH_STATE +static void yy_push_state YY_PROTO(( int new_state )); +#endif +#ifndef YY_NO_POP_STATE +static void yy_pop_state YY_PROTO(( void )); +#endif +#ifndef YY_NO_TOP_STATE +static int yy_top_state YY_PROTO(( void )); +#endif + +#else +#define YY_NO_PUSH_STATE 1 +#define YY_NO_POP_STATE 1 +#define YY_NO_TOP_STATE 1 +#endif + +#ifdef YY_MALLOC_DECL +YY_MALLOC_DECL +#else +#if __STDC__ +#ifndef __cplusplus +#include +#endif +#else +/* Just try to get by without declaring the routines. This will fail + * miserably on non-ANSI systems for which sizeof(size_t) != sizeof(int) + * or sizeof(void*) != sizeof(int). + */ +#endif +#endif + +/* Amount of stuff to slurp up with each read. */ +#ifndef YY_READ_BUF_SIZE +#define YY_READ_BUF_SIZE 8192 +#endif + +/* Copy whatever the last rule matched to the standard output. */ + +#ifndef ECHO +/* This used to be an fputs(), but since the string might contain NUL's, + * we now use fwrite(). + */ +#define ECHO (void) fwrite( yytext, yyleng, 1, yyout ) +#endif + +/* Gets input and stuffs it into "buf". number of characters read, or YY_NULL, + * is returned in "result". + */ +#ifndef YY_INPUT +#define YY_INPUT(buf,result,max_size) \ + if ( yy_current_buffer->yy_is_interactive ) \ + { \ + int c = '*', n; \ + for ( n = 0; n < max_size && \ + (c = getc( yyin )) != EOF && c != '\n'; ++n ) \ + buf[n] = (char) c; \ + if ( c == '\n' ) \ + buf[n++] = (char) c; \ + if ( c == EOF && ferror( yyin ) ) \ + YY_FATAL_ERROR( "input in flex scanner failed" ); \ + result = n; \ + } \ + else if ( ((result = fread( buf, 1, max_size, yyin )) == 0) \ + && ferror( yyin ) ) \ + YY_FATAL_ERROR( "input in flex scanner failed" ); +#endif + +/* No semi-colon after return; correct usage is to write "yyterminate();" - + * we don't want an extra ';' after the "return" because that will cause + * some compilers to complain about unreachable statements. + */ +#ifndef yyterminate +#define yyterminate() return YY_NULL +#endif + +/* Number of entries by which start-condition stack grows. */ +#ifndef YY_START_STACK_INCR +#define YY_START_STACK_INCR 25 +#endif + +/* Report a fatal error. */ +#ifndef YY_FATAL_ERROR +#define YY_FATAL_ERROR(msg) yy_fatal_error( msg ) +#endif + +/* Default declaration of generated scanner - a define so the user can + * easily add parameters. + */ +#ifndef YY_DECL +#define YY_DECL int yylex YY_PROTO(( void )) +#endif + +/* Code executed at the beginning of each rule, after yytext and yyleng + * have been set up. + */ +#ifndef YY_USER_ACTION +#define YY_USER_ACTION +#endif + +/* Code executed at the end of each rule. */ +#ifndef YY_BREAK +#define YY_BREAK break; +#endif + +#define YY_RULE_SETUP \ + YY_USER_ACTION + +YY_DECL + { + register yy_state_type yy_current_state; + register char *yy_cp, *yy_bp; + register int yy_act; + +#line 32 "scheme.flex" + + +#line 679 "lex.yy.c" + + if ( yy_init ) + { + yy_init = 0; + +#ifdef YY_USER_INIT + YY_USER_INIT; +#endif + + if ( ! yy_start ) + yy_start = 1; /* first start state */ + + if ( ! yyin ) + yyin = stdin; + + if ( ! yyout ) + yyout = stdout; + + if ( ! yy_current_buffer ) + yy_current_buffer = + yy_create_buffer( yyin, YY_BUF_SIZE ); + + yy_load_buffer_state(); + } + + while ( 1 ) /* loops until end-of-file is reached */ + { + yy_cp = yy_c_buf_p; + + /* Support of yytext. */ + *yy_cp = yy_hold_char; + + /* yy_bp points to the position in yy_ch_buf of the start of + * the current run. + */ + yy_bp = yy_cp; + + yy_current_state = yy_start; +yy_match: + do + { + register YY_CHAR yy_c = yy_ec[YY_SC_TO_UI(*yy_cp)]; + if ( yy_accept[yy_current_state] ) + { + yy_last_accepting_state = yy_current_state; + yy_last_accepting_cpos = yy_cp; + } + while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) + { + yy_current_state = (int) yy_def[yy_current_state]; + if ( yy_current_state >= 143 ) + yy_c = yy_meta[(unsigned int) yy_c]; + } + yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; + ++yy_cp; + } + while ( yy_base[yy_current_state] != 389 ); + +yy_find_action: + yy_act = yy_accept[yy_current_state]; + if ( yy_act == 0 ) + { /* have to back up */ + yy_cp = yy_last_accepting_cpos; + yy_current_state = yy_last_accepting_state; + yy_act = yy_accept[yy_current_state]; + } + + YY_DO_BEFORE_ACTION; + + +do_action: /* This label is used only to access EOF actions. */ + + + switch ( yy_act ) + { /* beginning of action switch */ + case 0: /* must back up */ + /* undo the effects of YY_DO_BEFORE_ACTION */ + *yy_cp = yy_hold_char; + yy_cp = yy_last_accepting_cpos; + yy_current_state = yy_last_accepting_state; + goto yy_find_action; + +case 1: +*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ +yy_c_buf_p = yy_cp -= 1; +YY_DO_BEFORE_ACTION; /* set up yytext again */ +YY_RULE_SETUP +#line 34 "scheme.flex" +{ /* skip comments */ + yyinputline++; + yysofar += yyleng; +} + YY_BREAK +case 2: +YY_RULE_SETUP +#line 39 "scheme.flex" +{ + yysofar += yyleng; return QUOTECHAR; +} + YY_BREAK +case 3: +YY_RULE_SETUP +#line 43 "scheme.flex" +{ + yysofar += yyleng; return ARROW; +} + YY_BREAK +case 4: +YY_RULE_SETUP +#line 47 "scheme.flex" +{ + yysofar += yyleng; return QUOTE; +} + YY_BREAK +case 5: +YY_RULE_SETUP +#line 51 "scheme.flex" +{ + yysofar += yyleng; return CALLCC; +} + YY_BREAK +case 6: +YY_RULE_SETUP +#line 55 "scheme.flex" +{ + yysofar += yyleng; return APPLY; +} + YY_BREAK +case 7: +YY_RULE_SETUP +#line 59 "scheme.flex" +{ + yysofar += yyleng; return DEFINE; +} + YY_BREAK +case 8: +YY_RULE_SETUP +#line 63 "scheme.flex" +{ + yysofar += yyleng; return SET; +} + YY_BREAK +case 9: +YY_RULE_SETUP +#line 67 "scheme.flex" +{ + yysofar += yyleng; return LAMBDA; +} + YY_BREAK +case 10: +YY_RULE_SETUP +#line 71 "scheme.flex" +{ + yysofar += yyleng; return IF; +} + YY_BREAK +case 11: +YY_RULE_SETUP +#line 75 "scheme.flex" +{ + yysofar += yyleng; return BEGINTOK; +} + YY_BREAK +case 12: +YY_RULE_SETUP +#line 79 "scheme.flex" +{ + yysofar += yyleng; return AND; +} + YY_BREAK +case 13: +YY_RULE_SETUP +#line 83 "scheme.flex" +{ + yysofar += yyleng; return OR; +} + YY_BREAK +case 14: +YY_RULE_SETUP +#line 87 "scheme.flex" +{ + yysofar += yyleng; return CASE; +} + YY_BREAK +case 15: +YY_RULE_SETUP +#line 91 "scheme.flex" +{ + yysofar += yyleng; return COND; +} + YY_BREAK +case 16: +YY_RULE_SETUP +#line 95 "scheme.flex" +{ + yysofar += yyleng; return ELSE; +} + YY_BREAK +case 17: +YY_RULE_SETUP +#line 99 "scheme.flex" +{ + yysofar += yyleng; return LET; +} + YY_BREAK +case 18: +YY_RULE_SETUP +#line 103 "scheme.flex" +{ + yysofar += yyleng; return LETSTAR; +} + YY_BREAK +case 19: +YY_RULE_SETUP +#line 107 "scheme.flex" +{ + yysofar += yyleng; return LETREC; +} + YY_BREAK +case 20: +YY_RULE_SETUP +#line 111 "scheme.flex" +{ + BOOL val = (yytext[1]=='t' ? YES : NO); + yylval = [[Boolean alloc] initSCMBoolean:val]; + yysofar += yyleng; return BOOLEAN; +} + YY_BREAK +case 21: +YY_RULE_SETUP +#line 117 "scheme.flex" +{ + char val; + if(!strcmp(yytext, "#\\newline")){ + val = '\n'; + } + else if(!strcmp(yytext, "#\\tab")){ + val = '\t'; + } + else if(!strcmp(yytext, "#\\space")){ + val = ' '; + } + else{ + val = yytext[2]; + } + + yylval = [[Char alloc] initSCMChar:val]; + yysofar += yyleng; return CHAR; +} + YY_BREAK +case 22: +YY_RULE_SETUP +#line 136 "scheme.flex" +{ + double val; + sscanf(yytext, "%le", &val); + yylval = [[Double alloc] initSCMDouble:val]; + yysofar += yyleng; return DOUBLE; +} + YY_BREAK +case 23: +YY_RULE_SETUP +#line 143 "scheme.flex" +{ + double val; + sscanf(yytext, "%le", &val); + yylval = [[Double alloc] initSCMDouble:val]; + yysofar += yyleng; return DOUBLE; +} + YY_BREAK +case 24: +YY_RULE_SETUP +#line 150 "scheme.flex" +{ + double val; + sscanf(yytext, "%le", &val); + yylval = [[Double alloc] initSCMDouble:val]; + yysofar += yyleng; return DOUBLE; +} + YY_BREAK +case 25: +YY_RULE_SETUP +#line 157 "scheme.flex" +{ + double val; + sscanf(yytext, "%le", &val); + yylval = [[Double alloc] initSCMDouble:val]; + yysofar += yyleng; return DOUBLE; +} + YY_BREAK +case 26: +YY_RULE_SETUP +#line 164 "scheme.flex" +{ + long int val; + sscanf(yytext, "%ld", &val); + yylval = [[Int alloc] initSCMInt:val]; + yysofar += yyleng; return INTEGER; +} + YY_BREAK +case 27: +YY_RULE_SETUP +#line 171 "scheme.flex" +{ + yylval = [[Symbol alloc] initSCMSymbol:yytext]; + yysofar += yyleng; return SYMBOL; +} + YY_BREAK +case 28: +YY_RULE_SETUP +#line 177 "scheme.flex" +{ + yylval = [[Symbol alloc] initSCMSymbol:yytext]; + yysofar += yyleng; return SYMBOL; +} + YY_BREAK +case 29: +YY_RULE_SETUP +#line 182 "scheme.flex" +{ + yylval = [[String alloc] initSCMString:yytext]; + yysofar += yyleng; return STRING; +} + YY_BREAK +case 30: +YY_RULE_SETUP +#line 187 "scheme.flex" +{ + yysofar += yyleng; return LVECTPAREN; +} + YY_BREAK +case 31: +YY_RULE_SETUP +#line 191 "scheme.flex" +{ + yysofar += yyleng; return LPAREN; +} + YY_BREAK +case 32: +YY_RULE_SETUP +#line 195 "scheme.flex" +{ + yysofar += yyleng; return RPAREN; +} + YY_BREAK +case 33: +YY_RULE_SETUP +#line 199 "scheme.flex" +{ + yysofar += yyleng; return DOT; +} + YY_BREAK +case 34: +YY_RULE_SETUP +#line 203 "scheme.flex" +yysofar += yyleng; /* eat up whitespace */ + YY_BREAK +case 35: +YY_RULE_SETUP +#line 205 "scheme.flex" +yysofar += yyleng; yyinputline++; + YY_BREAK +case 36: +YY_RULE_SETUP +#line 207 "scheme.flex" +printf( "Unrecognized character: %s\n", yytext); yysofar += yyleng; + YY_BREAK +case 37: +YY_RULE_SETUP +#line 209 "scheme.flex" +ECHO; + YY_BREAK +#line 1052 "lex.yy.c" +case YY_STATE_EOF(INITIAL): + yyterminate(); + + case YY_END_OF_BUFFER: + { + /* Amount of text matched not including the EOB char. */ + int yy_amount_of_matched_text = (int) (yy_cp - yytext_ptr) - 1; + + /* Undo the effects of YY_DO_BEFORE_ACTION. */ + *yy_cp = yy_hold_char; + YY_RESTORE_YY_MORE_OFFSET + + if ( yy_current_buffer->yy_buffer_status == YY_BUFFER_NEW ) + { + /* We're scanning a new file or input source. It's + * possible that this happened because the user + * just pointed yyin at a new source and called + * yylex(). If so, then we have to assure + * consistency between yy_current_buffer and our + * globals. Here is the right place to do so, because + * this is the first action (other than possibly a + * back-up) that will match for the new input source. + */ + yy_n_chars = yy_current_buffer->yy_n_chars; + yy_current_buffer->yy_input_file = yyin; + yy_current_buffer->yy_buffer_status = YY_BUFFER_NORMAL; + } + + /* Note that here we test for yy_c_buf_p "<=" to the position + * of the first EOB in the buffer, since yy_c_buf_p will + * already have been incremented past the NUL character + * (since all states make transitions on EOB to the + * end-of-buffer state). Contrast this with the test + * in input(). + */ + if ( yy_c_buf_p <= &yy_current_buffer->yy_ch_buf[yy_n_chars] ) + { /* This was really a NUL. */ + yy_state_type yy_next_state; + + yy_c_buf_p = yytext_ptr + yy_amount_of_matched_text; + + yy_current_state = yy_get_previous_state(); + + /* Okay, we're now positioned to make the NUL + * transition. We couldn't have + * yy_get_previous_state() go ahead and do it + * for us because it doesn't know how to deal + * with the possibility of jamming (and we don't + * want to build jamming into it because then it + * will run more slowly). + */ + + yy_next_state = yy_try_NUL_trans( yy_current_state ); + + yy_bp = yytext_ptr + YY_MORE_ADJ; + + if ( yy_next_state ) + { + /* Consume the NUL. */ + yy_cp = ++yy_c_buf_p; + yy_current_state = yy_next_state; + goto yy_match; + } + + else + { + yy_cp = yy_c_buf_p; + goto yy_find_action; + } + } + + else switch ( yy_get_next_buffer() ) + { + case EOB_ACT_END_OF_FILE: + { + yy_did_buffer_switch_on_eof = 0; + + if ( yywrap() ) + { + /* Note: because we've taken care in + * yy_get_next_buffer() to have set up + * yytext, we can now set up + * yy_c_buf_p so that if some total + * hoser (like flex itself) wants to + * call the scanner after we return the + * YY_NULL, it'll still work - another + * YY_NULL will get returned. + */ + yy_c_buf_p = yytext_ptr + YY_MORE_ADJ; + + yy_act = YY_STATE_EOF(YY_START); + goto do_action; + } + + else + { + if ( ! yy_did_buffer_switch_on_eof ) + YY_NEW_FILE; + } + break; + } + + case EOB_ACT_CONTINUE_SCAN: + yy_c_buf_p = + yytext_ptr + yy_amount_of_matched_text; + + yy_current_state = yy_get_previous_state(); + + yy_cp = yy_c_buf_p; + yy_bp = yytext_ptr + YY_MORE_ADJ; + goto yy_match; + + case EOB_ACT_LAST_MATCH: + yy_c_buf_p = + &yy_current_buffer->yy_ch_buf[yy_n_chars]; + + yy_current_state = yy_get_previous_state(); + + yy_cp = yy_c_buf_p; + yy_bp = yytext_ptr + YY_MORE_ADJ; + goto yy_find_action; + } + break; + } + + default: + YY_FATAL_ERROR( + "fatal flex scanner internal error--no action found" ); + } /* end of action switch */ + } /* end of scanning one token */ + } /* end of yylex */ + + +/* yy_get_next_buffer - try to read in a new buffer + * + * Returns a code representing an action: + * EOB_ACT_LAST_MATCH - + * EOB_ACT_CONTINUE_SCAN - continue scanning from current position + * EOB_ACT_END_OF_FILE - end of file + */ + +static int yy_get_next_buffer() + { + register char *dest = yy_current_buffer->yy_ch_buf; + register char *source = yytext_ptr; + register int number_to_move, i; + int ret_val; + + if ( yy_c_buf_p > &yy_current_buffer->yy_ch_buf[yy_n_chars + 1] ) + YY_FATAL_ERROR( + "fatal flex scanner internal error--end of buffer missed" ); + + if ( yy_current_buffer->yy_fill_buffer == 0 ) + { /* Don't try to fill the buffer, so this is an EOF. */ + if ( yy_c_buf_p - yytext_ptr - YY_MORE_ADJ == 1 ) + { + /* We matched a single character, the EOB, so + * treat this as a final EOF. + */ + return EOB_ACT_END_OF_FILE; + } + + else + { + /* We matched some text prior to the EOB, first + * process it. + */ + return EOB_ACT_LAST_MATCH; + } + } + + /* Try to read more data. */ + + /* First move last chars to start of buffer. */ + number_to_move = (int) (yy_c_buf_p - yytext_ptr) - 1; + + for ( i = 0; i < number_to_move; ++i ) + *(dest++) = *(source++); + + if ( yy_current_buffer->yy_buffer_status == YY_BUFFER_EOF_PENDING ) + /* don't do the read, it's not guaranteed to return an EOF, + * just force an EOF + */ + yy_current_buffer->yy_n_chars = yy_n_chars = 0; + + else + { + int num_to_read = + yy_current_buffer->yy_buf_size - number_to_move - 1; + + while ( num_to_read <= 0 ) + { /* Not enough room in the buffer - grow it. */ +#ifdef YY_USES_REJECT + YY_FATAL_ERROR( +"input buffer overflow, can't enlarge buffer because scanner uses REJECT" ); +#else + + /* just a shorter name for the current buffer */ + YY_BUFFER_STATE b = yy_current_buffer; + + int yy_c_buf_p_offset = + (int) (yy_c_buf_p - b->yy_ch_buf); + + if ( b->yy_is_our_buffer ) + { + int new_size = b->yy_buf_size * 2; + + if ( new_size <= 0 ) + b->yy_buf_size += b->yy_buf_size / 8; + else + b->yy_buf_size *= 2; + + b->yy_ch_buf = (char *) + /* Include room in for 2 EOB chars. */ + yy_flex_realloc( (void *) b->yy_ch_buf, + b->yy_buf_size + 2 ); + } + else + /* Can't grow it, we don't own it. */ + b->yy_ch_buf = 0; + + if ( ! b->yy_ch_buf ) + YY_FATAL_ERROR( + "fatal error - scanner input buffer overflow" ); + + yy_c_buf_p = &b->yy_ch_buf[yy_c_buf_p_offset]; + + num_to_read = yy_current_buffer->yy_buf_size - + number_to_move - 1; +#endif + } + + if ( num_to_read > YY_READ_BUF_SIZE ) + num_to_read = YY_READ_BUF_SIZE; + + /* Read in more data. */ + YY_INPUT( (&yy_current_buffer->yy_ch_buf[number_to_move]), + yy_n_chars, num_to_read ); + + yy_current_buffer->yy_n_chars = yy_n_chars; + } + + if ( yy_n_chars == 0 ) + { + if ( number_to_move == YY_MORE_ADJ ) + { + ret_val = EOB_ACT_END_OF_FILE; + yyrestart( yyin ); + } + + else + { + ret_val = EOB_ACT_LAST_MATCH; + yy_current_buffer->yy_buffer_status = + YY_BUFFER_EOF_PENDING; + } + } + + else + ret_val = EOB_ACT_CONTINUE_SCAN; + + yy_n_chars += number_to_move; + yy_current_buffer->yy_ch_buf[yy_n_chars] = YY_END_OF_BUFFER_CHAR; + yy_current_buffer->yy_ch_buf[yy_n_chars + 1] = YY_END_OF_BUFFER_CHAR; + + yytext_ptr = &yy_current_buffer->yy_ch_buf[0]; + + return ret_val; + } + + +/* yy_get_previous_state - get the state just before the EOB char was reached */ + +static yy_state_type yy_get_previous_state() + { + register yy_state_type yy_current_state; + register char *yy_cp; + + yy_current_state = yy_start; + + for ( yy_cp = yytext_ptr + YY_MORE_ADJ; yy_cp < yy_c_buf_p; ++yy_cp ) + { + register YY_CHAR yy_c = (*yy_cp ? yy_ec[YY_SC_TO_UI(*yy_cp)] : 1); + if ( yy_accept[yy_current_state] ) + { + yy_last_accepting_state = yy_current_state; + yy_last_accepting_cpos = yy_cp; + } + while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) + { + yy_current_state = (int) yy_def[yy_current_state]; + if ( yy_current_state >= 143 ) + yy_c = yy_meta[(unsigned int) yy_c]; + } + yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; + } + + return yy_current_state; + } + + +/* yy_try_NUL_trans - try to make a transition on the NUL character + * + * synopsis + * next_state = yy_try_NUL_trans( current_state ); + */ + +#ifdef YY_USE_PROTOS +static yy_state_type yy_try_NUL_trans( yy_state_type yy_current_state ) +#else +static yy_state_type yy_try_NUL_trans( yy_current_state ) +yy_state_type yy_current_state; +#endif + { + register int yy_is_jam; + register char *yy_cp = yy_c_buf_p; + + register YY_CHAR yy_c = 1; + if ( yy_accept[yy_current_state] ) + { + yy_last_accepting_state = yy_current_state; + yy_last_accepting_cpos = yy_cp; + } + while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) + { + yy_current_state = (int) yy_def[yy_current_state]; + if ( yy_current_state >= 143 ) + yy_c = yy_meta[(unsigned int) yy_c]; + } + yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; + yy_is_jam = (yy_current_state == 142); + + return yy_is_jam ? 0 : yy_current_state; + } + + +#ifndef YY_NO_UNPUT +#ifdef YY_USE_PROTOS +static void yyunput( int c, register char *yy_bp ) +#else +static void yyunput( c, yy_bp ) +int c; +register char *yy_bp; +#endif + { + register char *yy_cp = yy_c_buf_p; + + /* undo effects of setting up yytext */ + *yy_cp = yy_hold_char; + + if ( yy_cp < yy_current_buffer->yy_ch_buf + 2 ) + { /* need to shift things up to make room */ + /* +2 for EOB chars. */ + register int number_to_move = yy_n_chars + 2; + register char *dest = &yy_current_buffer->yy_ch_buf[ + yy_current_buffer->yy_buf_size + 2]; + register char *source = + &yy_current_buffer->yy_ch_buf[number_to_move]; + + while ( source > yy_current_buffer->yy_ch_buf ) + *--dest = *--source; + + yy_cp += (int) (dest - source); + yy_bp += (int) (dest - source); + yy_current_buffer->yy_n_chars = + yy_n_chars = yy_current_buffer->yy_buf_size; + + if ( yy_cp < yy_current_buffer->yy_ch_buf + 2 ) + YY_FATAL_ERROR( "flex scanner push-back overflow" ); + } + + *--yy_cp = (char) c; + + + yytext_ptr = yy_bp; + yy_hold_char = *yy_cp; + yy_c_buf_p = yy_cp; + } +#endif /* ifndef YY_NO_UNPUT */ + + +#ifdef __cplusplus +static int yyinput() +#else +static int input() +#endif + { + int c; + + *yy_c_buf_p = yy_hold_char; + + if ( *yy_c_buf_p == YY_END_OF_BUFFER_CHAR ) + { + /* yy_c_buf_p now points to the character we want to return. + * If this occurs *before* the EOB characters, then it's a + * valid NUL; if not, then we've hit the end of the buffer. + */ + if ( yy_c_buf_p < &yy_current_buffer->yy_ch_buf[yy_n_chars] ) + /* This was really a NUL. */ + *yy_c_buf_p = '\0'; + + else + { /* need more input */ + int offset = yy_c_buf_p - yytext_ptr; + ++yy_c_buf_p; + + switch ( yy_get_next_buffer() ) + { + case EOB_ACT_LAST_MATCH: + /* This happens because yy_g_n_b() + * sees that we've accumulated a + * token and flags that we need to + * try matching the token before + * proceeding. But for input(), + * there's no matching to consider. + * So convert the EOB_ACT_LAST_MATCH + * to EOB_ACT_END_OF_FILE. + */ + + /* Reset buffer status. */ + yyrestart( yyin ); + + /* fall through */ + + case EOB_ACT_END_OF_FILE: + { + if ( yywrap() ) + return EOF; + + if ( ! yy_did_buffer_switch_on_eof ) + YY_NEW_FILE; +#ifdef __cplusplus + return yyinput(); +#else + return input(); +#endif + } + + case EOB_ACT_CONTINUE_SCAN: + yy_c_buf_p = yytext_ptr + offset; + break; + } + } + } + + c = *(unsigned char *) yy_c_buf_p; /* cast for 8-bit char's */ + *yy_c_buf_p = '\0'; /* preserve yytext */ + yy_hold_char = *++yy_c_buf_p; + + + return c; + } + + +#ifdef YY_USE_PROTOS +void yyrestart( FILE *input_file ) +#else +void yyrestart( input_file ) +FILE *input_file; +#endif + { + if ( ! yy_current_buffer ) + yy_current_buffer = yy_create_buffer( yyin, YY_BUF_SIZE ); + + yy_init_buffer( yy_current_buffer, input_file ); + yy_load_buffer_state(); + } + + +#ifdef YY_USE_PROTOS +void yy_switch_to_buffer( YY_BUFFER_STATE new_buffer ) +#else +void yy_switch_to_buffer( new_buffer ) +YY_BUFFER_STATE new_buffer; +#endif + { + if ( yy_current_buffer == new_buffer ) + return; + + if ( yy_current_buffer ) + { + /* Flush out information for old buffer. */ + *yy_c_buf_p = yy_hold_char; + yy_current_buffer->yy_buf_pos = yy_c_buf_p; + yy_current_buffer->yy_n_chars = yy_n_chars; + } + + yy_current_buffer = new_buffer; + yy_load_buffer_state(); + + /* We don't actually know whether we did this switch during + * EOF (yywrap()) processing, but the only time this flag + * is looked at is after yywrap() is called, so it's safe + * to go ahead and always set it. + */ + yy_did_buffer_switch_on_eof = 1; + } + + +#ifdef YY_USE_PROTOS +void yy_load_buffer_state( void ) +#else +void yy_load_buffer_state() +#endif + { + yy_n_chars = yy_current_buffer->yy_n_chars; + yytext_ptr = yy_c_buf_p = yy_current_buffer->yy_buf_pos; + yyin = yy_current_buffer->yy_input_file; + yy_hold_char = *yy_c_buf_p; + } + + +#ifdef YY_USE_PROTOS +YY_BUFFER_STATE yy_create_buffer( FILE *file, int size ) +#else +YY_BUFFER_STATE yy_create_buffer( file, size ) +FILE *file; +int size; +#endif + { + YY_BUFFER_STATE b; + + b = (YY_BUFFER_STATE) yy_flex_alloc( sizeof( struct yy_buffer_state ) ); + if ( ! b ) + YY_FATAL_ERROR( "out of dynamic memory in yy_create_buffer()" ); + + b->yy_buf_size = size; + + /* yy_ch_buf has to be 2 characters longer than the size given because + * we need to put in 2 end-of-buffer characters. + */ + b->yy_ch_buf = (char *) yy_flex_alloc( b->yy_buf_size + 2 ); + if ( ! b->yy_ch_buf ) + YY_FATAL_ERROR( "out of dynamic memory in yy_create_buffer()" ); + + b->yy_is_our_buffer = 1; + + yy_init_buffer( b, file ); + + return b; + } + + +#ifdef YY_USE_PROTOS +void yy_delete_buffer( YY_BUFFER_STATE b ) +#else +void yy_delete_buffer( b ) +YY_BUFFER_STATE b; +#endif + { + if ( ! b ) + return; + + if ( b == yy_current_buffer ) + yy_current_buffer = (YY_BUFFER_STATE) 0; + + if ( b->yy_is_our_buffer ) + yy_flex_free( (void *) b->yy_ch_buf ); + + yy_flex_free( (void *) b ); + } + + +#ifndef YY_ALWAYS_INTERACTIVE +#ifndef YY_NEVER_INTERACTIVE +#include +#endif +#endif + +#ifdef YY_USE_PROTOS +void yy_init_buffer( YY_BUFFER_STATE b, FILE *file ) +#else +void yy_init_buffer( b, file ) +YY_BUFFER_STATE b; +FILE *file; +#endif + + + { + yy_flush_buffer( b ); + + b->yy_input_file = file; + b->yy_fill_buffer = 1; + +#if YY_ALWAYS_INTERACTIVE + b->yy_is_interactive = 1; +#else +#if YY_NEVER_INTERACTIVE + b->yy_is_interactive = 0; +#else + b->yy_is_interactive = file ? (isatty( fileno(file) ) > 0) : 0; +#endif +#endif + } + + +#ifdef YY_USE_PROTOS +void yy_flush_buffer( YY_BUFFER_STATE b ) +#else +void yy_flush_buffer( b ) +YY_BUFFER_STATE b; +#endif + + { + if ( ! b ) + return; + + b->yy_n_chars = 0; + + /* We always need two end-of-buffer characters. The first causes + * a transition to the end-of-buffer state. The second causes + * a jam in that state. + */ + b->yy_ch_buf[0] = YY_END_OF_BUFFER_CHAR; + b->yy_ch_buf[1] = YY_END_OF_BUFFER_CHAR; + + b->yy_buf_pos = &b->yy_ch_buf[0]; + + b->yy_at_bol = 1; + b->yy_buffer_status = YY_BUFFER_NEW; + + if ( b == yy_current_buffer ) + yy_load_buffer_state(); + } + + +#ifndef YY_NO_SCAN_BUFFER +#ifdef YY_USE_PROTOS +YY_BUFFER_STATE yy_scan_buffer( char *base, yy_size_t size ) +#else +YY_BUFFER_STATE yy_scan_buffer( base, size ) +char *base; +yy_size_t size; +#endif + { + YY_BUFFER_STATE b; + + if ( size < 2 || + base[size-2] != YY_END_OF_BUFFER_CHAR || + base[size-1] != YY_END_OF_BUFFER_CHAR ) + /* They forgot to leave room for the EOB's. */ + return 0; + + b = (YY_BUFFER_STATE) yy_flex_alloc( sizeof( struct yy_buffer_state ) ); + if ( ! b ) + YY_FATAL_ERROR( "out of dynamic memory in yy_scan_buffer()" ); + + b->yy_buf_size = size - 2; /* "- 2" to take care of EOB's */ + b->yy_buf_pos = b->yy_ch_buf = base; + b->yy_is_our_buffer = 0; + b->yy_input_file = 0; + b->yy_n_chars = b->yy_buf_size; + b->yy_is_interactive = 0; + b->yy_at_bol = 1; + b->yy_fill_buffer = 0; + b->yy_buffer_status = YY_BUFFER_NEW; + + yy_switch_to_buffer( b ); + + return b; + } +#endif + + +#ifndef YY_NO_SCAN_STRING +#ifdef YY_USE_PROTOS +YY_BUFFER_STATE yy_scan_string( yyconst char *yy_str ) +#else +YY_BUFFER_STATE yy_scan_string( yy_str ) +yyconst char *yy_str; +#endif + { + int len; + for ( len = 0; yy_str[len]; ++len ) + ; + + return yy_scan_bytes( yy_str, len ); + } +#endif + + +#ifndef YY_NO_SCAN_BYTES +#ifdef YY_USE_PROTOS +YY_BUFFER_STATE yy_scan_bytes( yyconst char *bytes, int len ) +#else +YY_BUFFER_STATE yy_scan_bytes( bytes, len ) +yyconst char *bytes; +int len; +#endif + { + YY_BUFFER_STATE b; + char *buf; + yy_size_t n; + int i; + + /* Get memory for full buffer, including space for trailing EOB's. */ + n = len + 2; + buf = (char *) yy_flex_alloc( n ); + if ( ! buf ) + YY_FATAL_ERROR( "out of dynamic memory in yy_scan_bytes()" ); + + for ( i = 0; i < len; ++i ) + buf[i] = bytes[i]; + + buf[len] = buf[len+1] = YY_END_OF_BUFFER_CHAR; + + b = yy_scan_buffer( buf, n ); + if ( ! b ) + YY_FATAL_ERROR( "bad buffer in yy_scan_bytes()" ); + + /* It's okay to grow etc. this buffer, and we should throw it + * away when we're done. + */ + b->yy_is_our_buffer = 1; + + return b; + } +#endif + + +#ifndef YY_NO_PUSH_STATE +#ifdef YY_USE_PROTOS +static void yy_push_state( int new_state ) +#else +static void yy_push_state( new_state ) +int new_state; +#endif + { + if ( yy_start_stack_ptr >= yy_start_stack_depth ) + { + yy_size_t new_size; + + yy_start_stack_depth += YY_START_STACK_INCR; + new_size = yy_start_stack_depth * sizeof( int ); + + if ( ! yy_start_stack ) + yy_start_stack = (int *) yy_flex_alloc( new_size ); + + else + yy_start_stack = (int *) yy_flex_realloc( + (void *) yy_start_stack, new_size ); + + if ( ! yy_start_stack ) + YY_FATAL_ERROR( + "out of memory expanding start-condition stack" ); + } + + yy_start_stack[yy_start_stack_ptr++] = YY_START; + + BEGIN(new_state); + } +#endif + + +#ifndef YY_NO_POP_STATE +static void yy_pop_state() + { + if ( --yy_start_stack_ptr < 0 ) + YY_FATAL_ERROR( "start-condition stack underflow" ); + + BEGIN(yy_start_stack[yy_start_stack_ptr]); + } +#endif + + +#ifndef YY_NO_TOP_STATE +static int yy_top_state() + { + return yy_start_stack[yy_start_stack_ptr - 1]; + } +#endif + +#ifndef YY_EXIT_FAILURE +#define YY_EXIT_FAILURE 2 +#endif + +#ifdef YY_USE_PROTOS +static void yy_fatal_error( yyconst char msg[] ) +#else +static void yy_fatal_error( msg ) +char msg[]; +#endif + { + (void) fprintf( stderr, "%s\n", msg ); + exit( YY_EXIT_FAILURE ); + } + + + +/* Redefine yyless() so it works in section 3 code. */ + +#undef yyless +#define yyless(n) \ + do \ + { \ + /* Undo effects of setting up yytext. */ \ + yytext[yyleng] = yy_hold_char; \ + yy_c_buf_p = yytext + n; \ + yy_hold_char = *yy_c_buf_p; \ + *yy_c_buf_p = '\0'; \ + yyleng = n; \ + } \ + while ( 0 ) + + +/* Internal utility routines. */ + +#ifndef yytext_ptr +#ifdef YY_USE_PROTOS +static void yy_flex_strncpy( char *s1, yyconst char *s2, int n ) +#else +static void yy_flex_strncpy( s1, s2, n ) +char *s1; +yyconst char *s2; +int n; +#endif + { + register int i; + for ( i = 0; i < n; ++i ) + s1[i] = s2[i]; + } +#endif + +#ifdef YY_NEED_STRLEN +#ifdef YY_USE_PROTOS +static int yy_flex_strlen( yyconst char *s ) +#else +static int yy_flex_strlen( s ) +yyconst char *s; +#endif + { + register int n; + for ( n = 0; s[n]; ++n ) + ; + + return n; + } +#endif + + +#ifdef YY_USE_PROTOS +static void *yy_flex_alloc( yy_size_t size ) +#else +static void *yy_flex_alloc( size ) +yy_size_t size; +#endif + { + return (void *) malloc( size ); + } + +#ifdef YY_USE_PROTOS +static void *yy_flex_realloc( void *ptr, yy_size_t size ) +#else +static void *yy_flex_realloc( ptr, size ) +void *ptr; +yy_size_t size; +#endif + { + /* The cast to (char *) in the following accommodates both + * implementations that use char* generic pointers, and those + * that use void* generic pointers. It works with the latter + * because both ANSI C and C++ allow castless assignment from + * any pointer type to void*, and deal with argument conversions + * as though doing an assignment. + */ + return (void *) realloc( (char *) ptr, size ); + } + +#ifdef YY_USE_PROTOS +static void yy_flex_free( void *ptr ) +#else +static void yy_flex_free( ptr ) +void *ptr; +#endif + { + free( ptr ); + } + +#if YY_MAIN +int main() + { + yylex(); + return 0; + } +#endif +#line 209 "scheme.flex" + + diff --git a/main.m b/main.m new file mode 100644 index 0000000..330e796 --- /dev/null +++ b/main.m @@ -0,0 +1,64 @@ +/* main.m: Main Body of GNUstep GScheme demo application + + Copyright (C) 2000 Free Software Foundation, Inc. + + Author: Fred Kiefer + Date: 2000. + + Adapted by: Marko Riedel . + Date: 2002. + + This file is part of GNUstep. + + 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., 675 Mass Ave, Cambridge, MA 02139, USA. + */ +#import +#import +#import + +#import +#import +#import + +#import "Document.h" +#import "VScheme.h" +#import "SCMTextView.h" +#import "SchemeDelegate.h" + + +BOOL yyschemeerrflag; +yyerror(char *s) /* Called by yyparse on error */ +{ + yyschemeerrflag = YES; +} + +int +main(int argc, const char **argv, char** env) +{ + NSAutoreleasePool *pool = [NSAutoreleasePool new]; + NSApplication *theApp; + + GSDebugAllocationActive(YES); + + theApp = [NSApplication sharedApplication]; + [theApp setDelegate:[SchemeDelegate new]]; + + setlocale(LC_NUMERIC, "C"); + printf("locale %s\n", setlocale(LC_NUMERIC, NULL)); + + NSApplicationMain(argc, argv); + [pool release]; +} + diff --git a/php/scheme.php b/php/scheme.php new file mode 100644 index 0000000..eee8369 --- /dev/null +++ b/php/scheme.php @@ -0,0 +1,2562 @@ + +
+ +By Marko Riedel, + +mriedel@neuearbeit.de, + +http://www.geocities.com/markoriedelde/index.html. +0){ + $ltokens[]=$parts[1]; + } + $ltokens[]=array('string', $parts[2]); + } + if(strlen($current)){ + $ltokens[]=$current; + } + + for($tok=0; $tok0){ + $tokens[]=array('text', $parts[1]); + } + if($parts[2]=='('){ + $tokens[]=array('left'); + } + else if($parts[2]==')'){ + $tokens[]=array('right'); + } + else{ + $tokens[]=array('quote'); + } + } + if(strlen($current)){ + $tokens[]=array('text', $current); + } + } + } + } + } +} + +$envindex = 0; +$environments = array(); + +function newenv($table) +{ + global $envindex, $environments; + + $environments[$envindex++] = $table; + return ($envindex-1); +} + +function writetoenv($tag, $sym, $val) +{ + global $environments; + + $environments[$tag][$sym] = $val; +} + +function readfromenv($tag, $sym) +{ + global $environments; + + $val = $environments[$tag][$sym]; + if(isset($val)){ + return $val; + } + return -1; +} + +function newval($type, $val) +{ + return array($type, $val); +} + +function valtype($v) +{ + return $v[0]; +} + +function valdata($v) +{ + return $v[1]; +} + +$thunkindex = 0; +$thunks = array(); + +function newthunk() +{ + global $thunkindex, $thunks; + + $thunks[$thunkindex++] = array(-1, -1); + return array('thunk', $thunkindex-1); +} + +function writeargptothunk($t, $argp) +{ + global $thunks; + $thunks[$t[1]][0] = $argp; +} + +function readargpfromthunk($t) +{ + global $thunks; + return $thunks[$t[1]][0]; +} + +function writeenvptothunk($t, $envp) +{ + global $thunks; + $thunks[$t[1]][1] = $envp; +} + +function readenvpfromthunk($t) +{ + global $thunks; + return $thunks[$t[1]][1]; +} + +$closureindex = 0; +$closures = array(); + +function newclosure($args, $code, $argtype, $env) +{ + global $closureindex, $closures; + + $closures[$closureindex++] = array($args, $code, $argtype, $env); + return array('closure', $closureindex-1); +} + +function closuretag($c) +{ + return $c[1]; +} + +function closureargs($c) +{ + global $closures; + return $closures[$c[1]][0]; +} + +function closurebody($c) +{ + global $closures; + return $closures[$c[1]][1]; +} + +function closureargtype($c) +{ + global $closures; + return $closures[$c[1]][2]; +} + +function closureenv($c) +{ + global $closures; + return $closures[$c[1]][3]; +} + +$pairindex = 0; +$pairs = array(); + +function cons($a, $b) +{ + global $pairindex, $pairs; + + $pairs[$pairindex++] = array($a, $b); + return array('pair', $pairindex-1); +} + +function car($p) +{ + global $pairs; + return $pairs[$p[1]][0]; +} + +function cdr($p) +{ + global $pairs; + return $pairs[$p[1]][1]; +} + +function setcar($p, $v) +{ + global $pairs; + $pairs[$p[1]][0] = $v; +} + +function setcdr($p, $v) +{ + global $pairs; + $pairs[$p[1]][1] = $v; +} + +$nullunique = array('empty'); +function null() +{ + global $nullunique; + return $nullunique; +} + +function array2list($items) +{ + $res = null(); + + for($p=count($items)-1; $p>=0; $p--){ + $res = cons($items[$p], $res); + } + + return $res; +} + +function btrue() +{ + return newval('boolean', '#t'); +} + +function bfalse() +{ + return newval('boolean', '#f'); +} + +function isfalse($val) +{ + if($val[0]=='empty' || + ($val[0]=='boolean' && $val[1]=='#f')){ + return 1; + } + + return 0; +} + +function readexp() +{ + global $tokens, $base, $errmsg; + + while(isset($tokens[$base])){ + $tok = $tokens[$base++]; + + if($tok[0]=='string'){ + return $tok; + } + + if($tok[0]=='text'){ + if(preg_match("/^[+-]?\d+(\.\d+)?([eE][+-]?\d+)?$/", $tok[1]) || + preg_match("/^[+-]?\d+$/", $tok[1])){ + return newval('number', $tok[1]); + } + + if(preg_match("/^[\+\-\*\/\=\>\<]|<=|>=$/", $tok[1]) || + preg_match("/^[a-zA-Z\?][a-zA-Z0-9\-\?\!\*]*$/", $tok[1])){ + return newval('symbol', $tok[1]); + } + + if(preg_match("/^\#[tf]$/", $tok[1])){ + return newval('boolean', $tok[1]); + } + + if(preg_match("/^\#\\\\(\w+|\.|\,|\+|\-|\*|\/)$/", + $tok[1], $parts)){ + return newval('character', $parts[1]); + } + + if($tok[1]=='.'){ + return newval('improper', $tok[1]); + } + } + else if($tok[0]=='quote'){ + $quoted = readexp(); + if(is_array($quoted)){ + return cons(newval('symbol', 'quote'), cons($quoted, null())); + } + else{ + $errmsg = 'quote missing an item'; + return -1; + } + } + else if($tok[0]=='left'){ + $items = array(); $isimproper = 0; + while(isset($tokens[$base]) && + $tokens[$base][0]!='right'){ + $item = readexp(); + if(is_array($item)){ + if($item[0]=='improper'){ + $isimproper = 1; + break; + } + else{ + $items[] = $item; + } + } + else{ + return -1; + } + } + if(!isset($tokens[$base])){ + $errmsg = 'ran out of list items'; + return -1; + } + if($isimproper){ + $item = readexp(); + if(is_array($item)){ + if(!isset($tokens[$base])){ + $errmsg = 'improper list missing closing parenthesis'; + return -1; + } + if($tokens[$base][0]!='right'){ + $errmsg = 'improper list not closed by parenthesis'; + return -1; + } + $base++; + + $result = $item; + } + else{ + $errmsg = 'improper list missing last item'; + return -1; + } + } + else{ + $base++; + $result = null(); + } + + for($ind=count($items)-1; $ind>=0; $ind--){ + $result = cons($items[$ind], $result); + } + + return $result; + } + else if($tok[0]=='right'){ + $errmsg = 'missing open parenthesis'; + return -1; + } + } + + $errmsg = 'parse error'; + return -1; +} + +$chartable = array(); +$chartable["newline"] = "\n"; +$chartable["tab"] = "\t"; +$chartable["space"] = " "; + +function tostring($exp, $expchars) +{ + global $chartable; + + if(valtype($exp)=='pair'){ + $result = '('; + $result .= tostring(car($exp), $expchars); + + for($rest=cdr($exp); valtype($rest)=='pair'; $rest=cdr($rest)){ + $result .= ' ' . tostring(car($rest), $expchars); + } + if(valtype($rest)!='empty'){ + $result .= ' . ' . tostring($rest, $expchars); + } + + $result .= ')'; + + return $result; + } + else if(valtype($exp)=='empty'){ + return '()'; + } + else if(valtype($exp)=='closure'){ + return ''; + } + else if(valtype($exp)=='bcode'){ + return ''; + } + else if(valtype($exp)=='thunk'){ + return ''; + } + else if(valtype($exp)=='primitive'){ + return ''; + } + else if(valtype($exp)=='string'){ + if($expchars=='expchars'){ + return valdata($exp); + } + return '"' . valdata($exp) . '"'; + } + else if(valtype($exp)=='character'){ + if($expchars=='expchars'){ + $expanded = $chartable[valdata($exp)]; + if(!empty($expanded)){ + return $expanded; + } + else{ + $str = valdata($exp); + return $str[0]; + } + } + else{ + return "#\\" . valdata($exp); + } + } + else{ + return valdata($exp); + } +} + +function tohtmlstring($exp, $expchars) +{ + return htmlspecialchars(tostring($exp, $expchars)); +} + +function tostring2($exp, $depth) +{ + if(valtype($exp)=='pair'){ + if(!$depth){ + return '...'; + } + + $result = '('; + $result .= tostring2(car($exp), $depth-1); + + for($rest=cdr($exp); $rest[0]=='pair'; $rest=cdr($rest)){ + $result .= ' ' . tostring2(car($rest), $depth-1); + } + if($rest[0]!='empty'){ + $result .= ' . ' . tostring($rest, 'noexpchars'); + } + + $result .= ')'; + + return $result; + } + + return tostring($exp, 'noexpchars'); +} + + +function tohtmlstring2($exp) +{ + $stringdepth = 3; + return htmlspecialchars(tostring2($exp, $stringdepth)); +} + +function lookup($symbol, $layers) +{ + if($layers[0]=='empty'){ + return -1; + } + + $layer = car($layers); + $val = readfromenv($layer, $symbol); + if(is_array($val)){ + return array($layer, $val); + } + + return lookup($symbol, cdr($layers)); +} + +function sequence($seq) +{ + global $bcode, $bc; + + $count=0; + while(valtype($seq)=='pair'){ + compile(car($seq)); + $seq=cdr($seq); + if(valtype($seq)=='pair'){ + $bcode[$bc++] = array('popargs', 1); + } + $count++; + } + + if($seq[0]!='empty'){ + $bcode[$bc++] = array('error', 'parse error in sequence term ' . $count); + return; + } +} + +$specialforms = array("define" => 1, "set!" => 1, "lambda" => 1, + "if" => 1, "and" => 1, "or" => 1, + "begin" => 1, "apply" => 1, + "quote" => 1, "case" => 1, "cond" => 1, + "let" => 1, "let*" => 1, "letrec" => 1, + "call-with-current-continuation" => 1); + +function codesegment($current) +{ + global $bcode, $bc; + + $codeseg = array(); + for($c = $current; $c<$bc; $c++){ + $codeseg[] = $bcode[$c]; + } + $bc = $current; + + return $codeseg; +} + +function handlespecial($name, $args) +{ + global $bcode, $bc; + + switch($name){ + case 'apply': + if(valtype($args)!='pair'){ + $bcode[$bc++] = array('error', "bad first arg to $name"); + return; + } + if(valtype(cdr($args))!='pair'){ + $bcode[$bc++] = array('error', "bad second arg to $name"); + return; + } + if(valtype(cdr(cdr($args)))!='empty'){ + $bcode[$bc++] = array('error', "too many args to $name"); + return; + } + compile(car($args)); + $bcode[$bc++] = array('checkptc'); + compile(car(cdr($args))); + $bcode[$bc++] = array('listapplication'); + break; + + case 'call-with-current-continuation': + if(valtype($args)!='pair'){ + $bcode[$bc++] = array('error', "bad first arg to $name"); + return; + } + + $t = newthunk(); + + $bcode[$bc++] = array('argptothunk', $t); + $bcode[$bc++] = array('envptothunk', $t); + compile(car($args)); + $bcode[$bc++] = array('checkptc'); + $bcode[$bc++] = array('toargs', $t); + $bcode[$bc++] = array('application', 1); + $bcode[$bc++] = $t; + break; + + case 'define': + case 'set!': + if(valtype($args)!='pair'){ + $bcode[$bc++] = array('error', "bad first arg to $name"); + return; + } + if(valtype(car($args))!='symbol'){ + $bcode[$bc++] = array('error', "first arg to $name not a symbol"); + return; + } + $bcode[$bc++] = array('toargs', car($args)); + if(valtype(cdr($args))!='pair'){ + $bcode[$bc++] = array('error', "bad second arg to $name"); + return; + } + if($name=='define'){ + $bcode[$bc++] = array('globalenv'); + compile(car(cdr($args))); + $bcode[$bc++] = array('popenv', 1); + } + else{ + compile(car(cdr($args))); + } + $bcode[$bc++] = array($name); + break; + + case 'lambda': + if(valtype($args)!='pair'){ + $bcode[$bc++] = array('error', 'bad first arg to lambda'); + return; + } + $argstr = car($args); + $argtype = -1; + if(valtype($argstr)=='symbol'){ + $argtype = 0; + } + else if(valtype($argstr)=='pair' || + valtype($argstr)=='empty'){ + for($tocheck = $argstr, $count=1; + valtype($tocheck)=='pair'; + $tocheck = cdr($tocheck), $count++){ + if(valtype(car($tocheck))!='symbol'){ + $msg = 'lambda arg ' . $count . ' not a symbol'; + break; + } + } + if(valtype($tocheck)=='symbol'){ + $argtype = 1; + } + else if(valtype($tocheck)=='empty'){ + $argtype = 2; + } + else{ + $msg = 'lambda arg not symbol or null terminator:'; + } + } + else{ + $msg = 'lambda single arg not a symbol'; + } + if($argtype==-1){ + $bcode[$bc++] = array('error', $msg); + return; + } + + if(valtype(cdr($args))=='empty'){ + $bcode[$bc++] = array('error', 'lambda body is empty'); + return; + } + + $current = $bc; + sequence(cdr($args)); + $lcode = codesegment($current); + + $bcode[$bc++] = array('toargs', car($args)); + $bcode[$bc++] = array('toargs', newval('bcode', $lcode)); + $bcode[$bc++] = array('toargs', newval('number', $argtype)); + $bcode[$bc++] = array('closure'); + break; + + case 'begin': + if(valtype($args)=='empty'){ + $bcode[$bc++] = array('toargs', null()); + return; + } + + sequence($args); + break; + + case 'cond': + for($clauses = array(), $elseclause = 0; + valtype($args)=='pair'; $args = cdr($args)){ + $clause = car($args); + + if(valtype($clause)!='pair'){ + $bcode[$bc++] = array('error', 'bad cond clause'); + return; + } + $test = car($clause); + $ccode = cdr($clause); + if(valtype($ccode)!='pair'){ + $bcode[$bc++] = array('error', 'empty cond clause'); + return; + } + + if(valtype($test)=='symbol' && + valdata($test)=='else'){ + if(is_array($elseclause)){ + $bcode[$bc++] = + array('error', 'cond: more than one else clause'); + return; + } + $elseclause = $clause; + } + else{ + if(is_array($elseclause)){ + $bcode[$bc++] = + array('error', 'cond: else clause must be last'); + return; + } + $type = 'seq'; + $first = car($ccode); + if(valtype($first)=='symbol' && + valdata($first)=='=>'){ + $expr = cdr($ccode); + if(valtype($expr)=='empty'){ + $bcode[$bc++] = + array('error', 'cond: empty => clause'); + return; + } + if(valtype(cdr($expr))!='empty'){ + $bcode[$bc++] = + array('error', + 'cond: more than one expr in => clause'); + return; + } + $type = 'proc'; + } + + $clauses[] = array($clause, $type); + } + } + + $count = 0; + + $current = $bc; + if(is_array($elseclause)){ + sequence(cdr($elseclause)); + $elsecode = codesegment($current); + + $bcode[$bc++] = array('toargs', newval('string', 'else')); + $bcode[$bc++] = array('toargs', newval('bcode', $elsecode)); + $count+=2; + } + + for($c=count($clauses)-1; $c>=0; $c--){ + $clause = $clauses[$c][0]; + $type = $clauses[$c][1]; + + $current = $bc; + compile(car($clause)); + $tcode = codesegment($current); + + if($type=='proc'){ + compile(car(cdr(cdr($clause)))); + $code = codesegment($current); + } + else{ + sequence(cdr($clause)); + $code = codesegment($current); + } + + $bcode[$bc++] = array('toargs', newval('bcode', $tcode)); + $bcode[$bc++] = array('toargs', newval('string', $type)); + $bcode[$bc++] = array('toargs', newval('bcode', $code)); + $count+=3; + } + + $bcode[$bc++] = array('cond', $count); + break; + + case 'case': + if(valtype($args)!='pair'){ + $bcode[$bc++] = array('error', 'case value missing'); + return; + } + $caseval = car($args); + compile($caseval); + + for($clauses = array(), $elseclause = 0, + $count=0, $cl = cdr($args); + valtype($cl)=='pair'; $cl = cdr($cl)){ + $clause = car($cl); + + if(valtype($clause)!='pair'){ + $bcode[$bc++] = array('error', 'bad case clause'); + return; + } + $data = car($clause); + if(valtype($data)!='pair' && + !(valtype($data)=='symbol' && + valdata($data)=='else')){ + $bcode[$bc++] = + array('error', 'bad case data: ' . tostring($data, 0)); + return; + } + $ccode = cdr($clause); + if(valtype($ccode)!='pair'){ + $bcode[$bc++] = array('error', 'empty case clause'); + return; + } + + if(valtype($data)=='symbol' && + valdata($data)=='else'){ + if(is_array($elseclause)){ + $bcode[$bc++] = + array('error', 'case: more than one else clause'); + return; + } + $elseclause = $clause; + } + else{ + if(is_array($elseclause)){ + $bcode[$bc++] = + array('error', 'case: else clause must be last'); + return; + } + $clauses[] = $clause; + } + + $count++; + } + + $current = $bc; + if(is_array($elseclause)){ + sequence(cdr($elseclause)); + $elsecode = codesegment($current); + + $bcode[$bc++] = array('toargs', car($elseclause)); + $bcode[$bc++] = array('toargs', newval('bcode', $elsecode)); + } + + for($c=count($clauses)-1; $c>=0; $c--){ + $clause = $clauses[$c]; + + $current = $bc; + sequence(cdr($clause)); + $ccode = codesegment($current); + + $bcode[$bc++] = array('toargs', car($clause)); + $bcode[$bc++] = array('toargs', newval('bcode', $ccode)); + } + + $bcode[$bc++] = array('case', $count); + break; + + case 'if': + if(valtype($args)!='pair'){ + $bcode[$bc++] = array('error', 'bad if condition'); + return; + } + $ifcond = car($args); + if(valtype(cdr($args))!='pair'){ + $bcode[$bc++] = array('error', 'true clause missing from if'); + return; + } + $iftrue = car(cdr($args)); + if(valtype(cdr(cdr($args)))!='pair'){ + $iffalse = cons(newval('symbol', 'quote'), cons(null(), null())); + } + else{ + $iffalse = car(cdr(cdr($args))); + } + + compile($ifcond); + + $current = $bc; + compile($iftrue); + $tcode = codesegment($current); + compile($iffalse); + $fcode = codesegment($current); + + $bcode[$bc++] = array('toargs', newval('bcode', $tcode)); + $bcode[$bc++] = array('toargs', newval('bcode', $fcode)); + $bcode[$bc++] = array('if'); + + break; + + case 'and': + case 'or': + $count = 0; + $current = $bc; + $terms = array(); + + while(valtype($args)=='pair'){ + compile(car($args)); + + $terms[] = codesegment($current); + + $count++; $args = cdr($args); + } + for($tind = $count-1; $tind>=0; $tind--){ + $tcode = $terms[$tind]; + $bcode[$bc++] = array('toargs', newval('bcode', $tcode)); + } + + $bcode[$bc++] = array('toargs', ($name=='and' ? btrue() : bfalse())); + $bcode[$bc++] = array($name, $count); + break; + + case 'quote': + if(valtype($args)!='pair'){ + $bcode[$bc++] = array('error', 'quote missing an item'); + return; + } + if(valtype(cdr($args))!='empty'){ + $bcode[$bc++] = array('error', 'quote takes a single argument'); + return; + } + $bcode[$bc++] = array('toargs', car($args)); + break; + + case 'let': + case 'let*': + case 'letrec': + if(valtype($args)!='pair'){ + $bcode[$bc++] = array('error', "bad first arg to $name"); + return; + } + if($name=='letrec'){ + $bcode[$bc++] = array('layer', 0); + } + for($bindings=car($args), $count=0; valtype($bindings)=='pair'; + $bindings=cdr($bindings)){ + $binding=car($bindings); + if(valtype($binding)!='pair'){ + $bcode[$bc++] = + array('error', '$name binding ' . ($count+1) . ' bad'); + return; + } + + if(valtype(car($binding))!='symbol'){ + $bcode[$bc++] = array('error', "first arg to $name binding " . + ($count+1) . ' not a symbol'); + return; + } + $bcode[$bc++] = array('toargs', car($binding)); + $count++; + compile(car(cdr($binding))); + if($name=='let*'){ + $bcode[$bc++] = array('layer', 1); + } + else if($name=='letrec'){ + $bcode[$bc++] = array('define', 1); + $bcode[$bc++] = array('popargs', 1); + } + } + if(valtype($bindings)!='empty'){ + $bcode[$bc++] = + array('error', "parse error at $name binding " . ($count+1)); + return; + } + if($name=='let'){ + $bcode[$bc++] = array('layer', $count); + } + + if(valtype(cdr($args))=='empty'){ + $bcode[$bc++] = array('error', "$name body is empty"); + return; + } + sequence(cdr($args)); + + if($name=='let' || $name=='letrec'){ + $bcode[$bc++] = array('popenv', 1); + } + else{ + $bcode[$bc++] = array('popenv', $count); + } + break; + } +} + +$primtable = +array("+", "*", "-", "/", "=", ">", "<", + "draw-move", "draw-line", "draw-color", + "sin", "cos", "sqrt", + "quotient", "remainder", "not", + "zero?", "pair?", "number?", "eqv?", "eq?", + "cons", "car", "cdr", "list", "null?", + "set-car!", "set-cdr!", + "display", "newline"); + +function drawcmd($name, $x, $y) +{ + global $imagedata; + + if($x<$imagedata[0]){ + $imagedata[0] = $x; + } + if($y<$imagedata[1]){ + $imagedata[1] = $y; + } + if($x>$imagedata[2]){ + $imagedata[2] = $x; + } + if($y>$imagedata[3]){ + $imagedata[3] = $y; + } + + if($name=='draw-move'){ + $imagedata[4][] = array(0, $x, $y); + } + else{ + $imagedata[4][] = array(1, $x, $y); + } +} + +function len($l) +{ + $len = 0; + while(valtype($l)=='pair'){ + $len++; + $l = cdr($l); + } + return $len; +} + +function applyprimitive($name, $argc) +{ + global $argstack, $argp, $errmsg; + global $outputstr; + global $imagedata; + + + switch($name){ + case 'sin': + case 'cos': + case 'sqrt': + if($argc!=1){ + $errmsg = "$name requires one argument"; + return -1; + } + $a = $argstack[$argp-1]; + if(valtype($a)!='number'){ + $errmsg = "first arg to $name not a number"; + return -1; + } + + $av = valdata($a); + + if($name=='sin'){ + return newval('number', sin($av)); + } + else if($name=='cos'){ + return newval('number', cos($av)); + } + + if($av<0){ + $errmsg = "arg to $name must not be negative"; + return -1; + } + return newval('number', sqrt($av)); + break; + + case 'draw-move': + case 'draw-line': + if($argc!=2){ + $errmsg = "$name requires two arguments"; + return -1; + } + $a = $argstack[$argp-2]; + if(valtype($a)!='number'){ + $errmsg = "first arg to $name not a number"; + return -1; + } + $b = $argstack[$argp-1]; + if(valtype($b)!='number'){ + $errmsg = "second arg to $name not a number"; + return -1; + } + + $av = valdata($a); + $bv = valdata($b); + + if(!count($imagedata[4])){ + if($name=='draw-line'){ + $imagedata[0] = 0; + $imagedata[1] = 0; + $imagedata[2] = 0; + $imagedata[3] = 0; + } + else{ + $imagedata[0] = $av; + $imagedata[1] = $bv; + $imagedata[2] = $av; + $imagedata[3] = $bv; + } + } + drawcmd($name, $av, $bv); + return null(); + break; + case 'draw-color': + if($argc!=1){ + $errmsg = "$name requires one argument"; + return -1; + } + $c = $argstack[$argp-1]; + if(len($c)!=3){ + $errmsg = "$name requires a list; form: (R, G, B)"; + return -1; + } + $red = car($c); + if(valtype($red)!='number'){ + $errmsg = "$name: red component not a number"; + return -1; + } + $green = car(cdr($c)); + if(valtype($green)!='number'){ + $errmsg = "$name: green component not a number"; + return -1; + } + $blue = car(cdr(cdr($c))); + if(valtype($blue)!='number'){ + $errmsg = "$name: blue component not a number"; + return -1; + } + $imagedata[4][] = + array(2, valdata($red), valdata($green), valdata($blue)); + return null(); + break; + case 'quotient': + if($argc!=2){ + $errmsg = 'quotient requires two arguments'; + return -1; + } + $a = $argstack[$argp-2]; + if(valtype($a)!='number'){ + $errmsg = 'first arg to quotient not a number'; + return -1; + } + $p = (int)valdata($a); + if($p!=valdata($a)){ + $errmsg = 'first arg to quotient not an integer'; + return -1; + } + + $b = $argstack[$argp-1]; + if(valtype($a)!='number'){ + $errmsg = 'second arg to quotient not a number'; + return -1; + } + $q = (int)valdata($b); + if($q!=valdata($b)){ + $errmsg = 'second arg to quotient not an integer'; + return -1; + } + if(!$q){ + $errmsg = 'second arg to quotient must not be zero'; + return -1; + } + + return newval('number', (int)($p / $q)); + break; + case 'remainder': + if($argc!=2){ + $errmsg = 'remainder requires two arguments'; + return -1; + } + $a = $argstack[$argp-2]; + if(valtype($a)!='number'){ + $errmsg = 'first arg to remainder not a number'; + return -1; + } + $p = (int)valdata($a); + if($p!=valdata($a)){ + $errmsg = 'first arg to remainder not an integer'; + return -1; + } + + $b = $argstack[$argp-1]; + if(valtype($a)!='number'){ + $errmsg = 'second arg to remainder not a number'; + return -1; + } + $q = (int)valdata($b); + if($q!=valdata($b)){ + $errmsg = 'second arg to remainder not an integer'; + return -1; + } + if(!$q){ + $errmsg = 'second arg to remainder must not be zero'; + return -1; + } + + return newval('number', $p % $q); + break; + case 'eqv?': + case 'eq?': + if($argc!=2){ + $errmsg = '$name requires two arguments'; + return -1; + } + $itema = $argstack[$argp-2]; + $itemb = $argstack[$argp-1]; + + if(valtype($itema)!=valtype($itemb)){ + return bfalse(); + } + + return (valdata($itema)==valdata($itemb) ? + btrue() : bfalse()); + case 'pair?': + if($argc!=1){ + $errmsg = 'pair? requires one argument'; + return -1; + } + $item = $argstack[$argp-$argc]; + return + (valtype($item)=='pair' ? btrue() : bfalse()); + case 'number?': + if($argc!=1){ + $errmsg = 'number? requires one argument'; + return -1; + } + $item = $argstack[$argp-$argc]; + return + (valtype($item)=='number' ? btrue() : bfalse()); + case 'zero?': + if($argc!=1){ + $errmsg = 'zero? requires one argument'; + return -1; + } + $item = $argstack[$argp-$argc]; + if(valtype($item)!='number'){ + $errmsg = 'zero? requires a numeric argument'; + return -1; + } + return (valdata($item) ? bfalse() : btrue()); + case 'not': + if($argc!=1){ + $errmsg = 'not requires one argument'; + return -1; + } + $item = $argstack[$argp-$argc]; + + if(valtype($item)=='boolean' && + valdata($item)=='#f'){ + return btrue(); + } + return bfalse(); + case 'list': + for($res=null(), $c=1; $c<=$argc; $c++){ + $res = cons($argstack[$argp-$c], $res); + } + return $res; + case 'cons': + if($argc!=2){ + $errmsg = 'cons requires two arguments'; + return -1; + } + $a = $argstack[$argp-2]; + $b = $argstack[$argp-1]; + return cons($a, $b); + case 'set-car!': + if($argc!=2){ + $errmsg = 'set-car! requires two arguments'; + return -1; + } + $p = $argstack[$argp-2]; + if(valtype($p)!='pair'){ + $errmsg = 'first argument to set-car! must be a pair'; + return -1; + } + $v = $argstack[$argp-1]; + setcar($p, $v); + return $v; + case 'set-cdr!': + if($argc!=2){ + $errmsg = 'set-cdr! requires two arguments'; + return -1; + } + $p = $argstack[$argp-2]; + if(valtype($p)!='pair'){ + $errmsg = 'first argument to set-cdr! must be a pair'; + return -1; + } + $v = $argstack[$argp-1]; + setcdr($p, $v); + return $v; + case 'car': + if($argc!=1){ + $errmsg = 'car takes a single argument'; + return -1; + } + $p = $argstack[$argp-1]; + if(valtype($p)!='pair'){ + $errmsg = 'argument to car must be a pair'; + return -1; + } + return car($p); + case 'cdr': + if($argc!=1){ + $errmsg = 'cdr takes a single argument'; + return -1; + } + $p = $argstack[$argp-1]; + if(valtype($p)!='pair'){ + $errmsg = 'argument to cdr must be a pair'; + return -1; + } + return cdr($p); + case 'null?': + if($argc!=1){ + $errmsg = 'null takes a single argument'; + return -1; + } + $p = $argstack[$argp-1]; + if(valtype($p)=='empty'){ + return newval('boolean', '#t'); + } + return newval('boolean', '#f'); + case 'display': + if($argc!=1){ + $errmsg = 'display requires one argument'; + return -1; + } + $item = $argstack[$argp-$argc]; + $outputstr .= tohtmlstring($item, 'expchars'); + return null(); + case 'newline': + if($argc){ + $errmsg = 'newline takes no arguments'; + return -1; + } + $outputstr .= "\n"; + return null(); + case '+': + if(!$argc){ + return newval('number', 0); + } + $item = $argstack[$argp-$argc]; + if(valtype($item)!='number'){ + $errmsg = 'first arg to + not a number'; + return -1; + } + for($res = valdata($item), $c=1; $c<$argc; $c++){ + $item = $argstack[$argp-$argc+$c]; + if(valtype($item)!='number'){ + $errmsg = 'arg ' . ($c+1) . ' to + not a number'; + return -1; + } + $res += valdata($item); + } + return newval('number', $res); + case '*': + if(!$argc){ + return newval('number', 1); + } + $item = $argstack[$argp-$argc]; + if(valtype($item)!='number'){ + $errmsg = 'first arg to * not a number'; + return -1; + } + for($res = valdata($item), $c=1; $c<$argc; $c++){ + $item = $argstack[$argp-$argc+$c]; + if(valtype($item)!='number'){ + $errmsg = 'arg ' . ($c+1) . ' to * not a number'; + return -1; + } + $res *= valdata($item); + } + return newval('number', $res); + case '-': + if(!$argc){ + $errmsg = '- requires at least one argument'; + return -1; + } + $item = $argstack[$argp-$argc]; + if(valtype($item)!='number'){ + $errmsg = 'first arg to - not a number'; + return -1; + } + for($res = valdata($item), $c=1; $c<$argc; $c++){ + $item = $argstack[$argp-$argc+$c]; + if(valtype($item)!='number'){ + $errmsg = 'arg ' . ($c+1) . ' to - not a number'; + return -1; + } + $res -= valdata($item); + } + return newval('number', ($argc==1 ? -$res : $res)); + case '/': + if(!$argc){ + $errmsg = '/ requires at least one argument'; + return -1; + } + $item = $argstack[$argp-$argc]; + if(valtype($item)!='number'){ + $errmsg = 'first arg to - not a number'; + return -1; + } + for($res = valdata($item), $c=1; $c<$argc; $c++){ + $item = $argstack[$argp-$argc+$c]; + if(valtype($item)!='number'){ + $errmsg = 'arg ' . ($c+1) . ' to - not a number'; + return -1; + } + $res /= valdata($item); + } + return newval('number', ($argc==1 ? 1/$res : $res)); + case '=': + $item = $argstack[$argp-$argc]; + if(valtype($item)!='number'){ + $errmsg = 'first arg to = not a number'; + return -1; + } + for($res = valdata($item), $c=1; $c<$argc; $c++){ + $item = $argstack[$argp-$argc+$c]; + if(valtype($item)!='number'){ + $errmsg = 'arg ' . ($c+1) . ' to = not a number'; + return -1; + } + if($res != valdata($item)){ + return newval('boolean', '#f'); + } + } + return newval('boolean', '#t'); + case '>': + if($argc<2){ + $errmsg = '> requires at least two arguments'; + return -1; + } + $current = $argstack[$argp-$argc]; + if(valtype($current)!='number'){ + $errmsg = 'first arg to - not a number'; + return -1; + } + for($c=1; $c<$argc; $c++){ + $item = $argstack[$argp-$argc+$c]; + if(valtype($item)!='number'){ + $errmsg = 'arg ' . ($c+1) . ' to > not a number'; + return -1; + } + if(valdata($current) <= valdata($item)){ + return bfalse(); + } + $current = $item; + } + return btrue(); + case '<': + if($argc<2){ + $errmsg = '< requires at least two arguments'; + return -1; + } + $current = $argstack[$argp-$argc]; + if(valtype($current)!='number'){ + $errmsg = 'first arg to - not a number'; + return -1; + } + for($c=1; $c<$argc; $c++){ + $item = $argstack[$argp-$argc+$c]; + if(valtype($item)!='number'){ + $errmsg = 'arg ' . ($c+1) . ' to < not a number'; + return -1; + } + if(valdata($current) >= valdata($item)){ + return bfalse(); + } + $current = $item; + } + return btrue(); + } +} + +function init() +{ + global $primtable, $initialenv; + + $prim = array(); + for($p=0; $p0){ + $bcode = $codestack[$codep-1][0]; + $searchpos = $codestack[$codep-1][1]; + $mx = $codestack[$codep-1][2]; + while($searchpos<$mx){ + if(valtype($bcode[$searchpos])!=$type || + valdata($bcode[$searchpos])!=$tag){ + $searchpos++; + } + else{ + return $searchpos; + } + } + $codep--; + } + + return -1; +} + +function run() +{ + global $initialenv, $bcode, $bc, $errmsg; + global $envstack, $argstack, $envp, $argp; + global $stacktrace; + + global $codestack, $codep; + + $codestack = array(array($bcode, 0, $bc, -1, 0)); + $codep = 1; + + $argstack = array(); + $argp = 0; + + $b = 0; + while(1){ + $instr = $codestack[$codep-1][0][$b]; + + // echo $b . ' ' . $instr[0] . "
\n"; + if($stacktrace && $instr[0]!='start'){ + echo "> "; + printargstack(); + } + + switch($instr[0]){ + case 'cond': + $count = $instr[1]; + + $type = valdata($argstack[$argp-2]); + $code = valdata($argstack[$argp-1]); + + if($type=='else'){ + insertcode($b, $code, -1); + $b = -1; + + unset($argstack[$argp-1]); $argp--; + unset($argstack[$argp-1]); $argp--; + } + else{ + $tcode = valdata($argstack[$argp-3]); + + insertcode($b, array(array('cond1', $count)), -1); + insertcode(-1, $tcode, -1); + $b = -1; + } + break; + + case 'cond1': + $count = $instr[1]; + + $type = valdata($argstack[$argp-3]); + $code = valdata($argstack[$argp-2]); + $tres = $argstack[$argp-1]; + + if(!isfalse($tres)){ + if($type=='proc'){ + $pcode = array(); + $pcode[] = array('checkptc', $tres); + $pcode[] = array('toargs', $tres); + $pcode[] = array('application', 1); + insertcode($b, $pcode, -1); + insertcode(-1, $code, -1); + } + else{ + insertcode($b, $code, -1); + } + $b = -1; + + $topop = $count+1; + } + else{ + if($count>=3){ + insertcode($b, array(array('cond', $count-3)), -1); + $b = -1; + } + + $topop = 4; + } + + for($c=0; $c<$topop; $c++){ + unset($argstack[$argp-1]); $argp--; + } + + break; + + case 'case': + $count = $instr[1]; + $caseval = $argstack[$argp-1-2*$count]; + $casevaltype = valtype($caseval); + $casevaldata = valdata($caseval); + + + for($c=0; $c<$count; $c++){ + $cases = $argstack[$argp-2]; + $code = $argstack[$argp-1]; + + $match = 0; + if(valtype($cases)=='symbol'){ + $match = 1; + } + else{ + while(valtype($cases)=='pair'){ + $item = car($cases); + if(valtype($item)==$casevaltype && + valdata($item)==$casevaldata){ + $match = 1; + break; + } + $cases = cdr($cases); + } + } + + if($match){ + insertcode($b, valdata($code), -1); + $b = -1; + break; + } + + unset($argstack[$argp-1]); $argp--; + unset($argstack[$argp-1]); $argp--; + } + + while($c<$count){ + unset($argstack[$argp-1]); $argp--; + unset($argstack[$argp-1]); $argp--; + $c++; + } + + unset($argstack[$argp-1]); $argp--; + break; + + case 'thunk': + writeargptothunk($instr, -1); + break; + + case 'argptothunk': + writeargptothunk($instr[1], $argp); + break; + + case 'envptothunk': + writeenvptothunk($instr[1], $envp); + break; + + case 'error': + $errmsg = $instr[1]; + return -1; + + case 'start': + $envstack = array($initialenv); + $envp = 1; + break; + + case 'if': + if(isfalse($argstack[$argp-3])){ + $icode = $argstack[$argp-1]; + } + else{ + $icode = $argstack[$argp-2]; + } + + insertcode($b, valdata($icode), -1); + $b = -1; + + unset($argstack[$argp-1]); + unset($argstack[$argp-2]); + unset($argstack[$argp-3]); + $argp -= 3; + + break; + + case 'and': + case 'or': + $op = $instr[0]; + + $count = $instr[1]; + if(valtype($argstack[$argp-1])!='boolean'){ + $errmsg = 'boolean required in ' . $op . + '; got ' . valtype($argstack[$argp-1]); + return -1; + } + + $bool = $argstack[$argp-1]; + if(($op=='and' && valdata($bool)=='#t') || + ($op=='or' && valdata($bool)=='#f')){ + if($count){ + $tcode = valdata($argstack[$argp-2]); + insertcode($b, array(array($op, $count-1)), -1); + insertcode(-1, $tcode, -1); + $b = -1; + + unset($argstack[$argp-1]); $argp--; + unset($argstack[$argp-1]); $argp--; + } + } + else{ + unset($argstack[$argp-1]); $argp--; // boolean + while($count>0){ + unset($argstack[$argp-1]); $argp--; + $count--; + } + $argstack[$argp++] = $bool; + } + break; + + case 'closure': + $cl = newclosure($argstack[$argp-3], + $argstack[$argp-2], + $argstack[$argp-1], + $envstack[$envp-1]); + + unset($argstack[$argp-1]); + unset($argstack[$argp-2]); + $argp -= 2; + $argstack[$argp-1] = $cl; + break; + + case 'layer': + $newlayer = array(); + + for($p=$argp-2; $p>=$argp-2*$instr[1]; $p-=2){ + $newlayer[$argstack[$p][1]] = $argstack[$p+1]; + unset($argstack[$p]); unset($argstack[$p+1]); + } + $argp -= 2*$instr[1]; + + $envstack[$envp] = cons(newenv($newlayer), $envstack[$envp-1]); + $envp++; + break; + + case 'listapplication': + $argl = $argstack[$argp-1]; + if(valtype($argl)!='empty' && + valtype($argl)!='pair'){ + $errmsg = 'second arg to apply not a list'; + return -1; + } + unset($argstack[--$argp]); + + $argc = 0; + while(valtype($argl)=='pair'){ + $argstack[$argp++] = car($argl); + $argc++; + $argl = cdr($argl); + } + // pass through to application + case 'application': + if($instr[0]=='application'){ + $argc = $instr[1]; + } + + $op=$argstack[$argp-1-$argc]; + if(valtype($op)=='primitive'){ + $res = applyprimitive(valdata($op), $argc); + if(!is_array($res)){ + return -1; + } + $newargp = $argp-$argc-1; + } + else if(valtype($op)=='thunk'){ + if($argc!=1){ + $errmsg = 'continuation requires a single argument'; + return -1; + } + if(readargpfromthunk($op)==-1){ + $errmsg = 'thunk #' . valdata($op) . ' has expired'; + return -1; + } + + $codestack[$codep-1][1] = $b; + $b = findmarkforward($op); + + $newenvp = readenvpfromthunk($op); + while($envp>$newenvp){ + unset($envstack[--$envp]); + } + + $res = $argstack[$argp-1]; + $newargp = readargpfromthunk($op); + } + else{ + $newlayer = array(); + $argl = closureargs($op); + if(valdata(closureargtype($op))>0){ + for($p=$argp-$argc; + valtype($argl)=='pair'; $p++, $argl=cdr($argl)){ + if($p>=$argp){ + $errmsg = 'not enough arguments'; + return -1; + } + $newlayer[valdata(car($argl))] = $argstack[$p]; + } + if(valdata(closureargtype($op))==1){ + $items = array(); + while($p<$argp){ + $items[] = $argstack[$p]; + $p++; + } + $newlayer[valdata($argl)] = array2list($items); + } + else if($p<$argp){ + $errmsg = 'too many arguments'; + return -1; + } + } + else{ + for($p=$argp-$argc, $items=array(); $p<$argp; $p++){ + $items[] = $argstack[$p]; + } + $newlayer[valdata($argl)] = array2list($items); + } + + $tag = closuretag($op); + + $tailrec = 0; $codestack[$codep-1][1] = $b; + $popcount = 0; + for($cp=$codep-1; $cp>=0; $cp--){ + $pos = $codestack[$cp][1]+1; + $mx = $codestack[$cp][2]; + while($pos<$mx){ + $instr = $codestack[$cp][0][$pos]; + if(valtype($instr)=='popenv'){ + $popcount += valdata($instr); + $pos++; + } + else{ + break; + } + } + if($pos<$mx){ + break; + } + if($codestack[$cp][3]==$tag){ + $tailrec = 1; + break; + } + } + + if($tailrec){ + $envp -= $popcount; + $envstack[$envp-1] = + cons(newenv($newlayer), closureenv($op)); + $codep = $cp+1; + } + else{ + $envstack[$envp] = + cons(newenv($newlayer), closureenv($op)); + $envp++; + + $lcode = valdata(closurebody($op)); + insertcode($b, array(array('popenv', 1)), -1); + insertcode(-1, $lcode, $tag); + } + $b = -1; + + $newargp = $argp-$argc-1; + } + + while($argp>$newargp){ + unset($argstack[--$argp]); + } + + if(valtype($op)=='primitive' || + valtype($op)=='thunk'){ + $argstack[$argp] = $res; + $argp++; + } + break; + + case 'toargs': + $argstack[$argp] = $instr[1]; + $argp++; + break; + + case 'popargs': + unset($argstack[$argp-1]); + $argp--; + break; + + case 'popenv': + $count = $instr[1]; + while($count>0){ + unset($envstack[$envp-1]); + $envp--; + $count--; + } + break; + + case 'globalenv': + $envstack[$envp] = $envstack[0]; + $envp++; + break; + + case 'checkptc': + $item = $argstack[$argp-1]; + if(valtype($item)!='primitive' && + valtype($item)!='closure' && + valtype($item)!='thunk'){ + $errmsg = 'primitive, closure or thunk required'; + return -1; + } + break; + + case 'lookup': + $item = $argstack[$argp-1]; + $res = lookup(valdata($item), $envstack[$envp-1]); + if(!is_array($res)){ + $errmsg = "symbol " . valdata($item) . " not bound"; + return -1; + } + $argstack[$argp-1] = $res[1]; + break; + + case 'define': + case 'set!': + $val = $argstack[--$argp]; unset($argstack[$argp]); + $sym = $argstack[$argp-1]; + + $env = car($envstack[$envp-1]); + if($instr[0]=='set!'){ + $res = lookup(valdata($sym), $envstack[$envp-1]); + if(is_array($res)){ + $env = $res[0]; + } + } + writetoenv($env, valdata($sym), $val); + break; + + default: + $errmsg = + "instruction $instr[0] unknown " . + "(codestack: $codep, position: $b)
\n"; + return -1; + } + + $b++; + while($b==$codestack[$codep-1][2]){ + $codep--; + if(!$codep){ + break; + } + $b = $codestack[$codep-1][1]+1; + } + + if(!$codep){ + break; + } + } + + return 0; +} + +function compile($exp) +{ + global $specialforms; + global $bcode, $bc; + + if($exp[0]=='pair'){ + $toapply = car($exp); + if($toapply[0]=='symbol'){ + if(isset($specialforms[$toapply[1]])){ + handlespecial($toapply[1], cdr($exp)); + return; + } + } + for($item=$exp, $count=0; valtype($item)=='pair'; $item=cdr($item)){ + $count++; + compile(car($item)); + if($count==1){ + $bcode[$bc++] = array('checkptc'); + } + } + if(valtype($item)!='empty'){ + $bcode[$bc++] = array('error', 'application not a proper list'); + return; + } + $bcode[$bc++] = array('application', $count-1); + } + else if($exp[0]=='symbol'){ + $bcode[$bc++] = array('toargs', $exp); + $bcode[$bc++] = array('lookup'); + } + else{ + $bcode[$bc++] = array('toargs', $exp); + } +} + +?> + + +Scheme + + + +Scheme

+Library: form $form: " . + $errmsg . + "
\n"; + } + else{ + $successes++; + } + } + else{ + echo + "Library: form $form: " . + $errmsg . + "
\n"; + break; + } + $form++; + } + } + else{ + echo + "" . + "Couldn't load library: $lname" . + "
\n"; + } + + if($successes){ + echo + "" . + "Library: $lname: loaded $successes " . + "form" . ($succeses==1 ? '' : 's') . "." . + "
\n"; + } + $stacktrace = $stflag; + } + + $program = stripslashes($program); + tokenize($program); + + $form = 1; $imageindex = 0; + while(isset($tokens[$base])){ + $exp = readexp(); + if(is_array($exp)){ + echo "

Form $form

\n"; $form++; + + $str = tohtmlstring2($exp); + echo "\n"; + echo $str; + echo "
\n"; + + $bcode = array(array('start')); $bc=1; + compile($exp); + + if($showbytecodes){ + for($b=0; $b\n"; + } + echo "
\n"; + } + + $imagedata = array(0, 0, 0, 0, array()); + + echo "
";
+      $outputstr = '';
+      if(run()){
+	echo "" . $errmsg  . "
\n";
+      }
+      printargstack();
+      echo "
\n"; + + if(strlen($outputstr)>0){ + echo "

Output\n"; + echo + "

" . 
+	  htmlspecialchars($outputstr) . 
+	  "
\n"; + } + echo "

\n"; + + if(count($imagedata[4])>0){ + $images[$imageindex] = $imagedata; + + echo "
\n"; + echo "\n"; + echo "
\n"; + $imageindex++; + } + } + else{ + echo "" . $errmsg . "
\n"; + break; + } + } +} +?> +

+ +
+ +
+ +Show byte codes +> +Show stack trace +> +Load library +> +
+ + + + + diff --git a/scheme.flex b/scheme.flex new file mode 100644 index 0000000..453ef20 --- /dev/null +++ b/scheme.flex @@ -0,0 +1,210 @@ +%{ +#import +#import + +#import "SchemeTypes.h" + +#define YYSTYPE id + +#include "scheme.tab.m.h" + +int yyinputline; +char *yyinputstr, *yyinputstart; +int yysofar; + +#define YY_INPUT(buf,result,max_size) \ + { \ + int c = *yyinputstr++; \ + result = (!c) ? YY_NULL : (buf[0] = c, 1); \ + } +%} + +SIGN "+"|"-" +DIGIT [0-9] +FRAC "."{DIGIT}+ +EXPONENT {SIGN}?[eE]{SIGN}?{DIGIT}+ +LETTER [a-zA-Z] +SYMEXTRA [-+*/><=!?] +SYMSPECIAL ">="|"<=" + +STRING "\""([^\n\"\\]|"\\\\"|"\\\"")*"\"" + +%% + +";".[^\n]*$ { /* skip comments */ + yyinputline++; + yysofar += yyleng; +} + +"'" { + yysofar += yyleng; return QUOTECHAR; +} + +"=>" { + yysofar += yyleng; return ARROW; +} + +"quote" { + yysofar += yyleng; return QUOTE; +} + +"call-with-current-continuation" { + yysofar += yyleng; return CALLCC; +} + +"apply" { + yysofar += yyleng; return APPLY; +} + +"define" { + yysofar += yyleng; return DEFINE; +} + +"set!" { + yysofar += yyleng; return SET; +} + +"lambda" { + yysofar += yyleng; return LAMBDA; +} + +"if" { + yysofar += yyleng; return IF; +} + +"begin" { + yysofar += yyleng; return BEGINTOK; +} + +"and" { + yysofar += yyleng; return AND; +} + +"or" { + yysofar += yyleng; return OR; +} + +"case" { + yysofar += yyleng; return CASE; +} + +"cond" { + yysofar += yyleng; return COND; +} + +"else" { + yysofar += yyleng; return ELSE; +} + +"let" { + yysofar += yyleng; return LET; +} + +"let*" { + yysofar += yyleng; return LETSTAR; +} + +"letrec" { + yysofar += yyleng; return LETREC; +} + +"#"[tf] { + BOOL val = (yytext[1]=='t' ? YES : NO); + yylval = [[Boolean alloc] initSCMBoolean:val]; + yysofar += yyleng; return BOOLEAN; +} + +"#\\"("newline"|"space"|"tab"|[^\n\t ]) { + char val; + if(!strcmp(yytext, "#\\newline")){ + val = '\n'; + } + else if(!strcmp(yytext, "#\\tab")){ + val = '\t'; + } + else if(!strcmp(yytext, "#\\space")){ + val = ' '; + } + else{ + val = yytext[2]; + } + + yylval = [[Char alloc] initSCMChar:val]; + yysofar += yyleng; return CHAR; +} + +{SIGN}?{DIGIT}*{FRAC} { + double val; + sscanf(yytext, "%le", &val); + yylval = [[Double alloc] initSCMDouble:val]; + yysofar += yyleng; return DOUBLE; +} + +{SIGN}?{DIGIT}+"." { + double val; + sscanf(yytext, "%le", &val); + yylval = [[Double alloc] initSCMDouble:val]; + yysofar += yyleng; return DOUBLE; +} + +{SIGN}?{DIGIT}+{EXPONENT} { + double val; + sscanf(yytext, "%le", &val); + yylval = [[Double alloc] initSCMDouble:val]; + yysofar += yyleng; return DOUBLE; +} + +{SIGN}?{DIGIT}*{FRAC}{EXPONENT} { + double val; + sscanf(yytext, "%le", &val); + yylval = [[Double alloc] initSCMDouble:val]; + yysofar += yyleng; return DOUBLE; +} + +{SIGN}?{DIGIT}+ { + long int val; + sscanf(yytext, "%ld", &val); + yylval = [[Int alloc] initSCMInt:val]; + yysofar += yyleng; return INTEGER; +} + +{SYMSPECIAL}|{SYMEXTRA} { + yylval = [[Symbol alloc] initSCMSymbol:yytext]; + yysofar += yyleng; return SYMBOL; +} + + +{LETTER}({LETTER}|{DIGIT}|{SYMEXTRA}|"?"|"*")* { + yylval = [[Symbol alloc] initSCMSymbol:yytext]; + yysofar += yyleng; return SYMBOL; +} + +{STRING} { + yylval = [[String alloc] initSCMString:yytext]; + yysofar += yyleng; return STRING; +} + +"#(" { + yysofar += yyleng; return LVECTPAREN; +} + +"(" { + yysofar += yyleng; return LPAREN; +} + +")" { + yysofar += yyleng; return RPAREN; +} + +"." { + yysofar += yyleng; return DOT; +} + +[ \t]+ yysofar += yyleng; /* eat up whitespace */ + +"\n" yysofar += yyleng; yyinputline++; + +. printf( "Unrecognized character: %s\n", yytext); yysofar += yyleng; + +%% + diff --git a/scheme.lex.m b/scheme.lex.m new file mode 100644 index 0000000..bd210a7 --- /dev/null +++ b/scheme.lex.m @@ -0,0 +1,1939 @@ +/* A lexical scanner generated by flex */ + +/* Scanner skeleton version: + * $Header: /home/daffy/u0/vern/flex/RCS/flex.skl,v 2.91 96/09/10 16:58:48 vern Exp $ + */ + +#define FLEX_SCANNER +#define YY_FLEX_MAJOR_VERSION 2 +#define YY_FLEX_MINOR_VERSION 5 + +#include + + +/* cfront 1.2 defines "c_plusplus" instead of "__cplusplus" */ +#ifdef c_plusplus +#ifndef __cplusplus +#define __cplusplus +#endif +#endif + + +#ifdef __cplusplus + +#include +#include + +/* Use prototypes in function declarations. */ +#define YY_USE_PROTOS + +/* The "const" storage-class-modifier is valid. */ +#define YY_USE_CONST + +#else /* ! __cplusplus */ + +#if __STDC__ + +#define YY_USE_PROTOS +#define YY_USE_CONST + +#endif /* __STDC__ */ +#endif /* ! __cplusplus */ + +#ifdef __TURBOC__ + #pragma warn -rch + #pragma warn -use +#include +#include +#define YY_USE_CONST +#define YY_USE_PROTOS +#endif + +#ifdef YY_USE_CONST +#define yyconst const +#else +#define yyconst +#endif + + +#ifdef YY_USE_PROTOS +#define YY_PROTO(proto) proto +#else +#define YY_PROTO(proto) () +#endif + +/* Returned upon end-of-file. */ +#define YY_NULL 0 + +/* Promotes a possibly negative, possibly signed char to an unsigned + * integer for use as an array index. If the signed char is negative, + * we want to instead treat it as an 8-bit unsigned char, hence the + * double cast. + */ +#define YY_SC_TO_UI(c) ((unsigned int) (unsigned char) c) + +/* Enter a start condition. This macro really ought to take a parameter, + * but we do it the disgusting crufty way forced on us by the ()-less + * definition of BEGIN. + */ +#define BEGIN yy_start = 1 + 2 * + +/* Translate the current start state into a value that can be later handed + * to BEGIN to return to the state. The YYSTATE alias is for lex + * compatibility. + */ +#define YY_START ((yy_start - 1) / 2) +#define YYSTATE YY_START + +/* Action number for EOF rule of a given start state. */ +#define YY_STATE_EOF(state) (YY_END_OF_BUFFER + state + 1) + +/* Special action meaning "start processing a new file". */ +#define YY_NEW_FILE yyrestart( yyin ) + +#define YY_END_OF_BUFFER_CHAR 0 + +/* Size of default input buffer. */ +#define YY_BUF_SIZE 16384 + +typedef struct yy_buffer_state *YY_BUFFER_STATE; + +extern int yyleng; +extern FILE *yyin, *yyout; + +#define EOB_ACT_CONTINUE_SCAN 0 +#define EOB_ACT_END_OF_FILE 1 +#define EOB_ACT_LAST_MATCH 2 + +/* The funky do-while in the following #define is used to turn the definition + * int a single C statement (which needs a semi-colon terminator). This + * avoids problems with code like: + * + * if ( condition_holds ) + * yyless( 5 ); + * else + * do_something_else(); + * + * Prior to using the do-while the compiler would get upset at the + * "else" because it interpreted the "if" statement as being all + * done when it reached the ';' after the yyless() call. + */ + +/* Return all but the first 'n' matched characters back to the input stream. */ + +#define yyless(n) \ + do \ + { \ + /* Undo effects of setting up yytext. */ \ + *yy_cp = yy_hold_char; \ + YY_RESTORE_YY_MORE_OFFSET \ + yy_c_buf_p = yy_cp = yy_bp + n - YY_MORE_ADJ; \ + YY_DO_BEFORE_ACTION; /* set up yytext again */ \ + } \ + while ( 0 ) + +#define unput(c) yyunput( c, yytext_ptr ) + +/* The following is because we cannot portably get our hands on size_t + * (without autoconf's help, which isn't available because we want + * flex-generated scanners to compile on their own). + */ +typedef unsigned int yy_size_t; + + +struct yy_buffer_state + { + FILE *yy_input_file; + + char *yy_ch_buf; /* input buffer */ + char *yy_buf_pos; /* current position in input buffer */ + + /* Size of input buffer in bytes, not including room for EOB + * characters. + */ + yy_size_t yy_buf_size; + + /* Number of characters read into yy_ch_buf, not including EOB + * characters. + */ + int yy_n_chars; + + /* Whether we "own" the buffer - i.e., we know we created it, + * and can realloc() it to grow it, and should free() it to + * delete it. + */ + int yy_is_our_buffer; + + /* Whether this is an "interactive" input source; if so, and + * if we're using stdio for input, then we want to use getc() + * instead of fread(), to make sure we stop fetching input after + * each newline. + */ + int yy_is_interactive; + + /* Whether we're considered to be at the beginning of a line. + * If so, '^' rules will be active on the next match, otherwise + * not. + */ + int yy_at_bol; + + /* Whether to try to fill the input buffer when we reach the + * end of it. + */ + int yy_fill_buffer; + + int yy_buffer_status; +#define YY_BUFFER_NEW 0 +#define YY_BUFFER_NORMAL 1 + /* When an EOF's been seen but there's still some text to process + * then we mark the buffer as YY_EOF_PENDING, to indicate that we + * shouldn't try reading from the input source any more. We might + * still have a bunch of tokens to match, though, because of + * possible backing-up. + * + * When we actually see the EOF, we change the status to "new" + * (via yyrestart()), so that the user can continue scanning by + * just pointing yyin at a new input file. + */ +#define YY_BUFFER_EOF_PENDING 2 + }; + +static YY_BUFFER_STATE yy_current_buffer = 0; + +/* We provide macros for accessing buffer states in case in the + * future we want to put the buffer states in a more general + * "scanner state". + */ +#define YY_CURRENT_BUFFER yy_current_buffer + + +/* yy_hold_char holds the character lost when yytext is formed. */ +static char yy_hold_char; + +static int yy_n_chars; /* number of characters read into yy_ch_buf */ + + +int yyleng; + +/* Points to current character in buffer. */ +static char *yy_c_buf_p = (char *) 0; +static int yy_init = 1; /* whether we need to initialize */ +static int yy_start = 0; /* start state number */ + +/* Flag which is used to allow yywrap()'s to do buffer switches + * instead of setting up a fresh yyin. A bit of a hack ... + */ +static int yy_did_buffer_switch_on_eof; + +void yyrestart YY_PROTO(( FILE *input_file )); + +void yy_switch_to_buffer YY_PROTO(( YY_BUFFER_STATE new_buffer )); +void yy_load_buffer_state YY_PROTO(( void )); +YY_BUFFER_STATE yy_create_buffer YY_PROTO(( FILE *file, int size )); +void yy_delete_buffer YY_PROTO(( YY_BUFFER_STATE b )); +void yy_init_buffer YY_PROTO(( YY_BUFFER_STATE b, FILE *file )); +void yy_flush_buffer YY_PROTO(( YY_BUFFER_STATE b )); +#define YY_FLUSH_BUFFER yy_flush_buffer( yy_current_buffer ) + +YY_BUFFER_STATE yy_scan_buffer YY_PROTO(( char *base, yy_size_t size )); +YY_BUFFER_STATE yy_scan_string YY_PROTO(( yyconst char *yy_str )); +YY_BUFFER_STATE yy_scan_bytes YY_PROTO(( yyconst char *bytes, int len )); + +static void *yy_flex_alloc YY_PROTO(( yy_size_t )); +static void *yy_flex_realloc YY_PROTO(( void *, yy_size_t )); +static void yy_flex_free YY_PROTO(( void * )); + +#define yy_new_buffer yy_create_buffer + +#define yy_set_interactive(is_interactive) \ + { \ + if ( ! yy_current_buffer ) \ + yy_current_buffer = yy_create_buffer( yyin, YY_BUF_SIZE ); \ + yy_current_buffer->yy_is_interactive = is_interactive; \ + } + +#define yy_set_bol(at_bol) \ + { \ + if ( ! yy_current_buffer ) \ + yy_current_buffer = yy_create_buffer( yyin, YY_BUF_SIZE ); \ + yy_current_buffer->yy_at_bol = at_bol; \ + } + +#define YY_AT_BOL() (yy_current_buffer->yy_at_bol) + +typedef unsigned char YY_CHAR; +FILE *yyin = (FILE *) 0, *yyout = (FILE *) 0; +typedef int yy_state_type; +extern char *yytext; +#define yytext_ptr yytext + +static yy_state_type yy_get_previous_state YY_PROTO(( void )); +static yy_state_type yy_try_NUL_trans YY_PROTO(( yy_state_type current_state )); +static int yy_get_next_buffer YY_PROTO(( void )); +static void yy_fatal_error YY_PROTO(( yyconst char msg[] )); + +/* Done after the current pattern has been matched and before the + * corresponding action - sets up yytext. + */ +#define YY_DO_BEFORE_ACTION \ + yytext_ptr = yy_bp; \ + yyleng = (int) (yy_cp - yy_bp); \ + yy_hold_char = *yy_cp; \ + *yy_cp = '\0'; \ + yy_c_buf_p = yy_cp; + +#define YY_NUM_RULES 37 +#define YY_END_OF_BUFFER 38 +static yyconst short int yy_accept[143] = + { 0, + 0, 0, 38, 36, 34, 35, 27, 36, 36, 2, + 31, 32, 27, 33, 26, 36, 27, 27, 27, 28, + 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, + 34, 0, 29, 0, 30, 0, 20, 0, 26, 22, + 0, 23, 0, 0, 27, 3, 28, 28, 28, 28, + 28, 28, 28, 28, 28, 10, 28, 28, 13, 28, + 28, 21, 21, 21, 21, 0, 0, 0, 24, 0, + 1, 12, 28, 28, 28, 28, 28, 28, 28, 28, + 17, 28, 28, 0, 0, 0, 0, 25, 28, 28, + 28, 14, 15, 28, 16, 28, 18, 28, 28, 8, + + 0, 0, 6, 11, 28, 28, 28, 28, 4, 0, + 0, 28, 7, 9, 19, 0, 28, 0, 28, 28, + 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, + 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, + 5, 0 + } ; + +static yyconst int yy_ec[256] = + { 0, + 1, 1, 1, 1, 1, 1, 1, 1, 2, 3, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 2, 4, 5, 6, 1, 1, 1, 7, 8, + 9, 10, 11, 1, 12, 13, 14, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 1, 16, 17, + 18, 19, 20, 1, 21, 21, 21, 21, 22, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 1, 23, 1, 1, 1, 1, 24, 25, 26, 27, + + 28, 29, 30, 31, 32, 21, 21, 33, 34, 35, + 36, 37, 38, 39, 40, 41, 42, 21, 43, 21, + 44, 21, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1 + } ; + +static yyconst int yy_meta[45] = + { 0, + 1, 2, 3, 4, 1, 1, 1, 1, 1, 4, + 4, 4, 1, 4, 4, 1, 4, 4, 4, 4, + 4, 4, 1, 4, 4, 4, 4, 4, 4, 4, + 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, + 4, 4, 4, 4 + } ; + +static yyconst short int yy_base[148] = + { 0, + 0, 0, 341, 389, 334, 389, 389, 40, 38, 389, + 389, 389, 34, 319, 40, 0, 312, 295, 282, 38, + 40, 44, 46, 61, 63, 49, 64, 66, 70, 75, + 297, 86, 389, 88, 389, 59, 389, 281, 95, 103, + 76, 279, 109, 269, 389, 389, 77, 106, 109, 112, + 117, 118, 120, 123, 124, 125, 136, 140, 143, 147, + 149, 389, 240, 222, 228, 120, 150, 225, 210, 218, + 389, 156, 158, 162, 164, 165, 169, 167, 178, 182, + 185, 190, 199, 143, 156, 148, 156, 139, 191, 194, + 203, 198, 202, 206, 207, 210, 218, 222, 223, 224, + + 108, 113, 226, 229, 235, 237, 238, 243, 244, 81, + 74, 250, 246, 251, 257, 66, 263, 37, 264, 269, + 265, 266, 270, 277, 278, 282, 283, 295, 300, 291, + 302, 303, 308, 311, 309, 315, 322, 323, 328, 337, + 339, 389, 372, 376, 53, 380, 384 + } ; + +static yyconst short int yy_def[148] = + { 0, + 142, 1, 142, 142, 142, 142, 142, 143, 142, 142, + 142, 142, 142, 142, 142, 144, 142, 142, 142, 145, + 145, 145, 145, 145, 145, 145, 145, 145, 145, 145, + 142, 143, 142, 142, 142, 146, 142, 142, 142, 142, + 142, 142, 142, 147, 142, 142, 145, 145, 145, 145, + 145, 145, 145, 145, 145, 145, 145, 145, 145, 145, + 145, 142, 142, 142, 142, 142, 142, 142, 142, 147, + 142, 145, 145, 145, 145, 145, 145, 145, 145, 145, + 145, 145, 145, 142, 142, 142, 142, 142, 145, 145, + 145, 145, 145, 145, 145, 145, 145, 145, 145, 145, + + 142, 142, 145, 145, 145, 145, 145, 145, 145, 142, + 142, 145, 145, 145, 145, 142, 145, 142, 145, 145, + 145, 145, 145, 145, 145, 145, 145, 145, 145, 145, + 145, 145, 145, 145, 145, 145, 145, 145, 145, 145, + 145, 0, 142, 142, 142, 142, 142 + } ; + +static yyconst short int yy_nxt[434] = + { 0, + 4, 5, 6, 7, 8, 9, 10, 11, 12, 7, + 13, 13, 14, 7, 15, 16, 17, 18, 19, 7, + 20, 20, 4, 21, 22, 23, 24, 25, 20, 20, + 20, 26, 27, 20, 20, 28, 20, 29, 20, 30, + 20, 20, 20, 20, 33, 35, 38, 48, 39, 48, + 41, 41, 42, 48, 39, 48, 47, 48, 48, 48, + 36, 43, 34, 48, 62, 48, 37, 43, 48, 52, + 48, 51, 48, 48, 49, 48, 50, 56, 37, 48, + 48, 53, 48, 48, 48, 48, 48, 57, 54, 48, + 33, 58, 32, 63, 48, 55, 48, 43, 64, 65, + + 118, 62, 61, 43, 59, 41, 41, 42, 34, 39, + 32, 60, 116, 66, 66, 48, 43, 40, 48, 68, + 68, 48, 43, 69, 67, 48, 48, 48, 48, 48, + 67, 48, 48, 48, 48, 72, 48, 48, 111, 48, + 110, 67, 48, 48, 48, 48, 74, 67, 73, 48, + 75, 78, 48, 88, 77, 48, 48, 76, 48, 48, + 87, 87, 48, 79, 88, 48, 48, 48, 48, 80, + 88, 48, 62, 48, 48, 48, 48, 48, 48, 102, + 81, 48, 82, 48, 48, 101, 48, 48, 48, 83, + 89, 48, 92, 90, 97, 93, 91, 48, 94, 48, + + 48, 48, 100, 48, 48, 95, 96, 48, 48, 48, + 48, 48, 48, 48, 105, 48, 48, 48, 48, 48, + 71, 48, 48, 98, 69, 48, 48, 48, 104, 48, + 99, 48, 48, 48, 103, 48, 107, 48, 48, 69, + 106, 48, 48, 48, 48, 48, 48, 48, 48, 108, + 109, 86, 48, 48, 48, 48, 48, 48, 85, 48, + 48, 114, 48, 48, 113, 48, 48, 84, 115, 48, + 48, 71, 48, 48, 48, 48, 48, 112, 48, 48, + 121, 117, 48, 48, 48, 48, 48, 48, 48, 48, + 122, 48, 48, 40, 120, 40, 48, 48, 31, 45, + + 48, 48, 48, 119, 48, 126, 129, 123, 124, 48, + 48, 48, 48, 46, 48, 125, 127, 48, 48, 48, + 48, 48, 48, 128, 48, 130, 131, 48, 48, 45, + 48, 48, 48, 40, 48, 31, 132, 48, 137, 134, + 142, 48, 48, 133, 142, 135, 48, 48, 48, 142, + 136, 142, 142, 142, 139, 142, 48, 142, 48, 142, + 142, 142, 138, 140, 142, 142, 142, 142, 142, 142, + 142, 141, 32, 32, 142, 32, 44, 44, 142, 44, + 62, 142, 142, 62, 70, 70, 70, 70, 3, 142, + 142, 142, 142, 142, 142, 142, 142, 142, 142, 142, + + 142, 142, 142, 142, 142, 142, 142, 142, 142, 142, + 142, 142, 142, 142, 142, 142, 142, 142, 142, 142, + 142, 142, 142, 142, 142, 142, 142, 142, 142, 142, + 142, 142, 142 + } ; + +static yyconst short int yy_chk[434] = + { 0, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 8, 9, 13, 20, 13, 21, + 15, 15, 15, 22, 15, 23, 145, 20, 26, 21, + 9, 15, 8, 22, 118, 23, 9, 15, 26, 23, + 24, 22, 25, 27, 21, 28, 21, 26, 9, 29, + 24, 23, 25, 27, 30, 28, 47, 27, 24, 29, + 32, 27, 34, 36, 30, 25, 47, 41, 36, 36, + + 116, 111, 30, 41, 28, 39, 39, 39, 32, 39, + 34, 29, 110, 40, 40, 48, 39, 40, 49, 43, + 43, 50, 39, 43, 40, 48, 51, 52, 49, 53, + 40, 50, 54, 55, 56, 49, 51, 52, 102, 53, + 101, 66, 54, 55, 56, 57, 51, 66, 50, 58, + 52, 54, 59, 88, 53, 57, 60, 52, 61, 58, + 67, 67, 59, 55, 67, 72, 60, 73, 61, 57, + 87, 74, 86, 75, 76, 72, 78, 73, 77, 85, + 58, 74, 60, 75, 76, 84, 78, 79, 77, 61, + 73, 80, 76, 74, 81, 77, 75, 79, 78, 82, + + 89, 80, 83, 90, 81, 79, 80, 92, 83, 82, + 89, 93, 91, 90, 91, 94, 95, 92, 83, 96, + 70, 93, 91, 81, 69, 94, 95, 97, 90, 96, + 82, 98, 99, 100, 89, 103, 96, 97, 104, 68, + 94, 98, 99, 100, 105, 103, 106, 107, 104, 98, + 99, 65, 108, 109, 105, 113, 106, 107, 64, 112, + 114, 107, 108, 109, 106, 113, 115, 63, 108, 112, + 114, 44, 117, 119, 121, 122, 115, 105, 120, 123, + 120, 112, 117, 119, 121, 122, 124, 125, 120, 123, + 121, 126, 127, 42, 119, 38, 124, 125, 31, 19, + + 130, 126, 127, 117, 128, 125, 128, 122, 123, 129, + 130, 131, 132, 18, 128, 124, 126, 133, 135, 129, + 134, 131, 132, 127, 136, 129, 130, 133, 135, 17, + 134, 137, 138, 14, 136, 5, 131, 139, 136, 133, + 3, 137, 138, 132, 0, 134, 140, 139, 141, 0, + 135, 0, 0, 0, 138, 0, 140, 0, 141, 0, + 0, 0, 137, 139, 0, 0, 0, 0, 0, 0, + 0, 140, 143, 143, 0, 143, 144, 144, 0, 144, + 146, 0, 0, 146, 147, 147, 147, 147, 142, 142, + 142, 142, 142, 142, 142, 142, 142, 142, 142, 142, + + 142, 142, 142, 142, 142, 142, 142, 142, 142, 142, + 142, 142, 142, 142, 142, 142, 142, 142, 142, 142, + 142, 142, 142, 142, 142, 142, 142, 142, 142, 142, + 142, 142, 142 + } ; + +static yy_state_type yy_last_accepting_state; +static char *yy_last_accepting_cpos; + +/* The intent behind this definition is that it'll catch + * any uses of REJECT which flex missed. + */ +#define REJECT reject_used_but_not_detected +#define yymore() yymore_used_but_not_detected +#define YY_MORE_ADJ 0 +#define YY_RESTORE_YY_MORE_OFFSET +char *yytext; +#line 1 "scheme.flex" +#define INITIAL 0 +#line 2 "scheme.flex" +#import +#import + +#import "SchemeTypes.h" + +#define YYSTYPE id + +#include "scheme.tab.m.h" + +int yyinputline; +char *yyinputstr, *yyinputstart; +int yysofar; + +#define YY_INPUT(buf,result,max_size) \ + { \ + int c = *yyinputstr++; \ + result = (!c) ? YY_NULL : (buf[0] = c, 1); \ + } +#line 525 "lex.yy.c" + +/* Macros after this point can all be overridden by user definitions in + * section 1. + */ + +#ifndef YY_SKIP_YYWRAP +#ifdef __cplusplus +extern "C" int yywrap YY_PROTO(( void )); +#else +extern int yywrap YY_PROTO(( void )); +#endif +#endif + +#ifndef YY_NO_UNPUT +static void yyunput YY_PROTO(( int c, char *buf_ptr )); +#endif + +#ifndef yytext_ptr +static void yy_flex_strncpy YY_PROTO(( char *, yyconst char *, int )); +#endif + +#ifdef YY_NEED_STRLEN +static int yy_flex_strlen YY_PROTO(( yyconst char * )); +#endif + +#ifndef YY_NO_INPUT +#ifdef __cplusplus +static int yyinput YY_PROTO(( void )); +#else +static int input YY_PROTO(( void )); +#endif +#endif + +#if YY_STACK_USED +static int yy_start_stack_ptr = 0; +static int yy_start_stack_depth = 0; +static int *yy_start_stack = 0; +#ifndef YY_NO_PUSH_STATE +static void yy_push_state YY_PROTO(( int new_state )); +#endif +#ifndef YY_NO_POP_STATE +static void yy_pop_state YY_PROTO(( void )); +#endif +#ifndef YY_NO_TOP_STATE +static int yy_top_state YY_PROTO(( void )); +#endif + +#else +#define YY_NO_PUSH_STATE 1 +#define YY_NO_POP_STATE 1 +#define YY_NO_TOP_STATE 1 +#endif + +#ifdef YY_MALLOC_DECL +YY_MALLOC_DECL +#else +#if __STDC__ +#ifndef __cplusplus +#include +#endif +#else +/* Just try to get by without declaring the routines. This will fail + * miserably on non-ANSI systems for which sizeof(size_t) != sizeof(int) + * or sizeof(void*) != sizeof(int). + */ +#endif +#endif + +/* Amount of stuff to slurp up with each read. */ +#ifndef YY_READ_BUF_SIZE +#define YY_READ_BUF_SIZE 8192 +#endif + +/* Copy whatever the last rule matched to the standard output. */ + +#ifndef ECHO +/* This used to be an fputs(), but since the string might contain NUL's, + * we now use fwrite(). + */ +#define ECHO (void) fwrite( yytext, yyleng, 1, yyout ) +#endif + +/* Gets input and stuffs it into "buf". number of characters read, or YY_NULL, + * is returned in "result". + */ +#ifndef YY_INPUT +#define YY_INPUT(buf,result,max_size) \ + if ( yy_current_buffer->yy_is_interactive ) \ + { \ + int c = '*', n; \ + for ( n = 0; n < max_size && \ + (c = getc( yyin )) != EOF && c != '\n'; ++n ) \ + buf[n] = (char) c; \ + if ( c == '\n' ) \ + buf[n++] = (char) c; \ + if ( c == EOF && ferror( yyin ) ) \ + YY_FATAL_ERROR( "input in flex scanner failed" ); \ + result = n; \ + } \ + else if ( ((result = fread( buf, 1, max_size, yyin )) == 0) \ + && ferror( yyin ) ) \ + YY_FATAL_ERROR( "input in flex scanner failed" ); +#endif + +/* No semi-colon after return; correct usage is to write "yyterminate();" - + * we don't want an extra ';' after the "return" because that will cause + * some compilers to complain about unreachable statements. + */ +#ifndef yyterminate +#define yyterminate() return YY_NULL +#endif + +/* Number of entries by which start-condition stack grows. */ +#ifndef YY_START_STACK_INCR +#define YY_START_STACK_INCR 25 +#endif + +/* Report a fatal error. */ +#ifndef YY_FATAL_ERROR +#define YY_FATAL_ERROR(msg) yy_fatal_error( msg ) +#endif + +/* Default declaration of generated scanner - a define so the user can + * easily add parameters. + */ +#ifndef YY_DECL +#define YY_DECL int yylex YY_PROTO(( void )) +#endif + +/* Code executed at the beginning of each rule, after yytext and yyleng + * have been set up. + */ +#ifndef YY_USER_ACTION +#define YY_USER_ACTION +#endif + +/* Code executed at the end of each rule. */ +#ifndef YY_BREAK +#define YY_BREAK break; +#endif + +#define YY_RULE_SETUP \ + YY_USER_ACTION + +YY_DECL + { + register yy_state_type yy_current_state; + register char *yy_cp, *yy_bp; + register int yy_act; + +#line 32 "scheme.flex" + + +#line 679 "lex.yy.c" + + if ( yy_init ) + { + yy_init = 0; + +#ifdef YY_USER_INIT + YY_USER_INIT; +#endif + + if ( ! yy_start ) + yy_start = 1; /* first start state */ + + if ( ! yyin ) + yyin = stdin; + + if ( ! yyout ) + yyout = stdout; + + if ( ! yy_current_buffer ) + yy_current_buffer = + yy_create_buffer( yyin, YY_BUF_SIZE ); + + yy_load_buffer_state(); + } + + while ( 1 ) /* loops until end-of-file is reached */ + { + yy_cp = yy_c_buf_p; + + /* Support of yytext. */ + *yy_cp = yy_hold_char; + + /* yy_bp points to the position in yy_ch_buf of the start of + * the current run. + */ + yy_bp = yy_cp; + + yy_current_state = yy_start; +yy_match: + do + { + register YY_CHAR yy_c = yy_ec[YY_SC_TO_UI(*yy_cp)]; + if ( yy_accept[yy_current_state] ) + { + yy_last_accepting_state = yy_current_state; + yy_last_accepting_cpos = yy_cp; + } + while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) + { + yy_current_state = (int) yy_def[yy_current_state]; + if ( yy_current_state >= 143 ) + yy_c = yy_meta[(unsigned int) yy_c]; + } + yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; + ++yy_cp; + } + while ( yy_base[yy_current_state] != 389 ); + +yy_find_action: + yy_act = yy_accept[yy_current_state]; + if ( yy_act == 0 ) + { /* have to back up */ + yy_cp = yy_last_accepting_cpos; + yy_current_state = yy_last_accepting_state; + yy_act = yy_accept[yy_current_state]; + } + + YY_DO_BEFORE_ACTION; + + +do_action: /* This label is used only to access EOF actions. */ + + + switch ( yy_act ) + { /* beginning of action switch */ + case 0: /* must back up */ + /* undo the effects of YY_DO_BEFORE_ACTION */ + *yy_cp = yy_hold_char; + yy_cp = yy_last_accepting_cpos; + yy_current_state = yy_last_accepting_state; + goto yy_find_action; + +case 1: +*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ +yy_c_buf_p = yy_cp -= 1; +YY_DO_BEFORE_ACTION; /* set up yytext again */ +YY_RULE_SETUP +#line 34 "scheme.flex" +{ /* skip comments */ + yyinputline++; + yysofar += yyleng; +} + YY_BREAK +case 2: +YY_RULE_SETUP +#line 39 "scheme.flex" +{ + yysofar += yyleng; return QUOTECHAR; +} + YY_BREAK +case 3: +YY_RULE_SETUP +#line 43 "scheme.flex" +{ + yysofar += yyleng; return ARROW; +} + YY_BREAK +case 4: +YY_RULE_SETUP +#line 47 "scheme.flex" +{ + yysofar += yyleng; return QUOTE; +} + YY_BREAK +case 5: +YY_RULE_SETUP +#line 51 "scheme.flex" +{ + yysofar += yyleng; return CALLCC; +} + YY_BREAK +case 6: +YY_RULE_SETUP +#line 55 "scheme.flex" +{ + yysofar += yyleng; return APPLY; +} + YY_BREAK +case 7: +YY_RULE_SETUP +#line 59 "scheme.flex" +{ + yysofar += yyleng; return DEFINE; +} + YY_BREAK +case 8: +YY_RULE_SETUP +#line 63 "scheme.flex" +{ + yysofar += yyleng; return SET; +} + YY_BREAK +case 9: +YY_RULE_SETUP +#line 67 "scheme.flex" +{ + yysofar += yyleng; return LAMBDA; +} + YY_BREAK +case 10: +YY_RULE_SETUP +#line 71 "scheme.flex" +{ + yysofar += yyleng; return IF; +} + YY_BREAK +case 11: +YY_RULE_SETUP +#line 75 "scheme.flex" +{ + yysofar += yyleng; return BEGINTOK; +} + YY_BREAK +case 12: +YY_RULE_SETUP +#line 79 "scheme.flex" +{ + yysofar += yyleng; return AND; +} + YY_BREAK +case 13: +YY_RULE_SETUP +#line 83 "scheme.flex" +{ + yysofar += yyleng; return OR; +} + YY_BREAK +case 14: +YY_RULE_SETUP +#line 87 "scheme.flex" +{ + yysofar += yyleng; return CASE; +} + YY_BREAK +case 15: +YY_RULE_SETUP +#line 91 "scheme.flex" +{ + yysofar += yyleng; return COND; +} + YY_BREAK +case 16: +YY_RULE_SETUP +#line 95 "scheme.flex" +{ + yysofar += yyleng; return ELSE; +} + YY_BREAK +case 17: +YY_RULE_SETUP +#line 99 "scheme.flex" +{ + yysofar += yyleng; return LET; +} + YY_BREAK +case 18: +YY_RULE_SETUP +#line 103 "scheme.flex" +{ + yysofar += yyleng; return LETSTAR; +} + YY_BREAK +case 19: +YY_RULE_SETUP +#line 107 "scheme.flex" +{ + yysofar += yyleng; return LETREC; +} + YY_BREAK +case 20: +YY_RULE_SETUP +#line 111 "scheme.flex" +{ + BOOL val = (yytext[1]=='t' ? YES : NO); + yylval = [[Boolean alloc] initSCMBoolean:val]; + yysofar += yyleng; return BOOLEAN; +} + YY_BREAK +case 21: +YY_RULE_SETUP +#line 117 "scheme.flex" +{ + char val; + if(!strcmp(yytext, "#\\newline")){ + val = '\n'; + } + else if(!strcmp(yytext, "#\\tab")){ + val = '\t'; + } + else if(!strcmp(yytext, "#\\space")){ + val = ' '; + } + else{ + val = yytext[2]; + } + + yylval = [[Char alloc] initSCMChar:val]; + yysofar += yyleng; return CHAR; +} + YY_BREAK +case 22: +YY_RULE_SETUP +#line 136 "scheme.flex" +{ + double val; + sscanf(yytext, "%le", &val); + yylval = [[Double alloc] initSCMDouble:val]; + yysofar += yyleng; return DOUBLE; +} + YY_BREAK +case 23: +YY_RULE_SETUP +#line 143 "scheme.flex" +{ + double val; + sscanf(yytext, "%le", &val); + yylval = [[Double alloc] initSCMDouble:val]; + yysofar += yyleng; return DOUBLE; +} + YY_BREAK +case 24: +YY_RULE_SETUP +#line 150 "scheme.flex" +{ + double val; + sscanf(yytext, "%le", &val); + yylval = [[Double alloc] initSCMDouble:val]; + yysofar += yyleng; return DOUBLE; +} + YY_BREAK +case 25: +YY_RULE_SETUP +#line 157 "scheme.flex" +{ + double val; + sscanf(yytext, "%le", &val); + yylval = [[Double alloc] initSCMDouble:val]; + yysofar += yyleng; return DOUBLE; +} + YY_BREAK +case 26: +YY_RULE_SETUP +#line 164 "scheme.flex" +{ + long int val; + sscanf(yytext, "%ld", &val); + yylval = [[Int alloc] initSCMInt:val]; + yysofar += yyleng; return INTEGER; +} + YY_BREAK +case 27: +YY_RULE_SETUP +#line 171 "scheme.flex" +{ + yylval = [[Symbol alloc] initSCMSymbol:yytext]; + yysofar += yyleng; return SYMBOL; +} + YY_BREAK +case 28: +YY_RULE_SETUP +#line 177 "scheme.flex" +{ + yylval = [[Symbol alloc] initSCMSymbol:yytext]; + yysofar += yyleng; return SYMBOL; +} + YY_BREAK +case 29: +YY_RULE_SETUP +#line 182 "scheme.flex" +{ + yylval = [[String alloc] initSCMString:yytext]; + yysofar += yyleng; return STRING; +} + YY_BREAK +case 30: +YY_RULE_SETUP +#line 187 "scheme.flex" +{ + yysofar += yyleng; return LVECTPAREN; +} + YY_BREAK +case 31: +YY_RULE_SETUP +#line 191 "scheme.flex" +{ + yysofar += yyleng; return LPAREN; +} + YY_BREAK +case 32: +YY_RULE_SETUP +#line 195 "scheme.flex" +{ + yysofar += yyleng; return RPAREN; +} + YY_BREAK +case 33: +YY_RULE_SETUP +#line 199 "scheme.flex" +{ + yysofar += yyleng; return DOT; +} + YY_BREAK +case 34: +YY_RULE_SETUP +#line 203 "scheme.flex" +yysofar += yyleng; /* eat up whitespace */ + YY_BREAK +case 35: +YY_RULE_SETUP +#line 205 "scheme.flex" +yysofar += yyleng; yyinputline++; + YY_BREAK +case 36: +YY_RULE_SETUP +#line 207 "scheme.flex" +printf( "Unrecognized character: %s\n", yytext); yysofar += yyleng; + YY_BREAK +case 37: +YY_RULE_SETUP +#line 209 "scheme.flex" +ECHO; + YY_BREAK +#line 1052 "lex.yy.c" +case YY_STATE_EOF(INITIAL): + yyterminate(); + + case YY_END_OF_BUFFER: + { + /* Amount of text matched not including the EOB char. */ + int yy_amount_of_matched_text = (int) (yy_cp - yytext_ptr) - 1; + + /* Undo the effects of YY_DO_BEFORE_ACTION. */ + *yy_cp = yy_hold_char; + YY_RESTORE_YY_MORE_OFFSET + + if ( yy_current_buffer->yy_buffer_status == YY_BUFFER_NEW ) + { + /* We're scanning a new file or input source. It's + * possible that this happened because the user + * just pointed yyin at a new source and called + * yylex(). If so, then we have to assure + * consistency between yy_current_buffer and our + * globals. Here is the right place to do so, because + * this is the first action (other than possibly a + * back-up) that will match for the new input source. + */ + yy_n_chars = yy_current_buffer->yy_n_chars; + yy_current_buffer->yy_input_file = yyin; + yy_current_buffer->yy_buffer_status = YY_BUFFER_NORMAL; + } + + /* Note that here we test for yy_c_buf_p "<=" to the position + * of the first EOB in the buffer, since yy_c_buf_p will + * already have been incremented past the NUL character + * (since all states make transitions on EOB to the + * end-of-buffer state). Contrast this with the test + * in input(). + */ + if ( yy_c_buf_p <= &yy_current_buffer->yy_ch_buf[yy_n_chars] ) + { /* This was really a NUL. */ + yy_state_type yy_next_state; + + yy_c_buf_p = yytext_ptr + yy_amount_of_matched_text; + + yy_current_state = yy_get_previous_state(); + + /* Okay, we're now positioned to make the NUL + * transition. We couldn't have + * yy_get_previous_state() go ahead and do it + * for us because it doesn't know how to deal + * with the possibility of jamming (and we don't + * want to build jamming into it because then it + * will run more slowly). + */ + + yy_next_state = yy_try_NUL_trans( yy_current_state ); + + yy_bp = yytext_ptr + YY_MORE_ADJ; + + if ( yy_next_state ) + { + /* Consume the NUL. */ + yy_cp = ++yy_c_buf_p; + yy_current_state = yy_next_state; + goto yy_match; + } + + else + { + yy_cp = yy_c_buf_p; + goto yy_find_action; + } + } + + else switch ( yy_get_next_buffer() ) + { + case EOB_ACT_END_OF_FILE: + { + yy_did_buffer_switch_on_eof = 0; + + if ( yywrap() ) + { + /* Note: because we've taken care in + * yy_get_next_buffer() to have set up + * yytext, we can now set up + * yy_c_buf_p so that if some total + * hoser (like flex itself) wants to + * call the scanner after we return the + * YY_NULL, it'll still work - another + * YY_NULL will get returned. + */ + yy_c_buf_p = yytext_ptr + YY_MORE_ADJ; + + yy_act = YY_STATE_EOF(YY_START); + goto do_action; + } + + else + { + if ( ! yy_did_buffer_switch_on_eof ) + YY_NEW_FILE; + } + break; + } + + case EOB_ACT_CONTINUE_SCAN: + yy_c_buf_p = + yytext_ptr + yy_amount_of_matched_text; + + yy_current_state = yy_get_previous_state(); + + yy_cp = yy_c_buf_p; + yy_bp = yytext_ptr + YY_MORE_ADJ; + goto yy_match; + + case EOB_ACT_LAST_MATCH: + yy_c_buf_p = + &yy_current_buffer->yy_ch_buf[yy_n_chars]; + + yy_current_state = yy_get_previous_state(); + + yy_cp = yy_c_buf_p; + yy_bp = yytext_ptr + YY_MORE_ADJ; + goto yy_find_action; + } + break; + } + + default: + YY_FATAL_ERROR( + "fatal flex scanner internal error--no action found" ); + } /* end of action switch */ + } /* end of scanning one token */ + } /* end of yylex */ + + +/* yy_get_next_buffer - try to read in a new buffer + * + * Returns a code representing an action: + * EOB_ACT_LAST_MATCH - + * EOB_ACT_CONTINUE_SCAN - continue scanning from current position + * EOB_ACT_END_OF_FILE - end of file + */ + +static int yy_get_next_buffer() + { + register char *dest = yy_current_buffer->yy_ch_buf; + register char *source = yytext_ptr; + register int number_to_move, i; + int ret_val; + + if ( yy_c_buf_p > &yy_current_buffer->yy_ch_buf[yy_n_chars + 1] ) + YY_FATAL_ERROR( + "fatal flex scanner internal error--end of buffer missed" ); + + if ( yy_current_buffer->yy_fill_buffer == 0 ) + { /* Don't try to fill the buffer, so this is an EOF. */ + if ( yy_c_buf_p - yytext_ptr - YY_MORE_ADJ == 1 ) + { + /* We matched a single character, the EOB, so + * treat this as a final EOF. + */ + return EOB_ACT_END_OF_FILE; + } + + else + { + /* We matched some text prior to the EOB, first + * process it. + */ + return EOB_ACT_LAST_MATCH; + } + } + + /* Try to read more data. */ + + /* First move last chars to start of buffer. */ + number_to_move = (int) (yy_c_buf_p - yytext_ptr) - 1; + + for ( i = 0; i < number_to_move; ++i ) + *(dest++) = *(source++); + + if ( yy_current_buffer->yy_buffer_status == YY_BUFFER_EOF_PENDING ) + /* don't do the read, it's not guaranteed to return an EOF, + * just force an EOF + */ + yy_current_buffer->yy_n_chars = yy_n_chars = 0; + + else + { + int num_to_read = + yy_current_buffer->yy_buf_size - number_to_move - 1; + + while ( num_to_read <= 0 ) + { /* Not enough room in the buffer - grow it. */ +#ifdef YY_USES_REJECT + YY_FATAL_ERROR( +"input buffer overflow, can't enlarge buffer because scanner uses REJECT" ); +#else + + /* just a shorter name for the current buffer */ + YY_BUFFER_STATE b = yy_current_buffer; + + int yy_c_buf_p_offset = + (int) (yy_c_buf_p - b->yy_ch_buf); + + if ( b->yy_is_our_buffer ) + { + int new_size = b->yy_buf_size * 2; + + if ( new_size <= 0 ) + b->yy_buf_size += b->yy_buf_size / 8; + else + b->yy_buf_size *= 2; + + b->yy_ch_buf = (char *) + /* Include room in for 2 EOB chars. */ + yy_flex_realloc( (void *) b->yy_ch_buf, + b->yy_buf_size + 2 ); + } + else + /* Can't grow it, we don't own it. */ + b->yy_ch_buf = 0; + + if ( ! b->yy_ch_buf ) + YY_FATAL_ERROR( + "fatal error - scanner input buffer overflow" ); + + yy_c_buf_p = &b->yy_ch_buf[yy_c_buf_p_offset]; + + num_to_read = yy_current_buffer->yy_buf_size - + number_to_move - 1; +#endif + } + + if ( num_to_read > YY_READ_BUF_SIZE ) + num_to_read = YY_READ_BUF_SIZE; + + /* Read in more data. */ + YY_INPUT( (&yy_current_buffer->yy_ch_buf[number_to_move]), + yy_n_chars, num_to_read ); + + yy_current_buffer->yy_n_chars = yy_n_chars; + } + + if ( yy_n_chars == 0 ) + { + if ( number_to_move == YY_MORE_ADJ ) + { + ret_val = EOB_ACT_END_OF_FILE; + yyrestart( yyin ); + } + + else + { + ret_val = EOB_ACT_LAST_MATCH; + yy_current_buffer->yy_buffer_status = + YY_BUFFER_EOF_PENDING; + } + } + + else + ret_val = EOB_ACT_CONTINUE_SCAN; + + yy_n_chars += number_to_move; + yy_current_buffer->yy_ch_buf[yy_n_chars] = YY_END_OF_BUFFER_CHAR; + yy_current_buffer->yy_ch_buf[yy_n_chars + 1] = YY_END_OF_BUFFER_CHAR; + + yytext_ptr = &yy_current_buffer->yy_ch_buf[0]; + + return ret_val; + } + + +/* yy_get_previous_state - get the state just before the EOB char was reached */ + +static yy_state_type yy_get_previous_state() + { + register yy_state_type yy_current_state; + register char *yy_cp; + + yy_current_state = yy_start; + + for ( yy_cp = yytext_ptr + YY_MORE_ADJ; yy_cp < yy_c_buf_p; ++yy_cp ) + { + register YY_CHAR yy_c = (*yy_cp ? yy_ec[YY_SC_TO_UI(*yy_cp)] : 1); + if ( yy_accept[yy_current_state] ) + { + yy_last_accepting_state = yy_current_state; + yy_last_accepting_cpos = yy_cp; + } + while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) + { + yy_current_state = (int) yy_def[yy_current_state]; + if ( yy_current_state >= 143 ) + yy_c = yy_meta[(unsigned int) yy_c]; + } + yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; + } + + return yy_current_state; + } + + +/* yy_try_NUL_trans - try to make a transition on the NUL character + * + * synopsis + * next_state = yy_try_NUL_trans( current_state ); + */ + +#ifdef YY_USE_PROTOS +static yy_state_type yy_try_NUL_trans( yy_state_type yy_current_state ) +#else +static yy_state_type yy_try_NUL_trans( yy_current_state ) +yy_state_type yy_current_state; +#endif + { + register int yy_is_jam; + register char *yy_cp = yy_c_buf_p; + + register YY_CHAR yy_c = 1; + if ( yy_accept[yy_current_state] ) + { + yy_last_accepting_state = yy_current_state; + yy_last_accepting_cpos = yy_cp; + } + while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) + { + yy_current_state = (int) yy_def[yy_current_state]; + if ( yy_current_state >= 143 ) + yy_c = yy_meta[(unsigned int) yy_c]; + } + yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; + yy_is_jam = (yy_current_state == 142); + + return yy_is_jam ? 0 : yy_current_state; + } + + +#ifndef YY_NO_UNPUT +#ifdef YY_USE_PROTOS +static void yyunput( int c, register char *yy_bp ) +#else +static void yyunput( c, yy_bp ) +int c; +register char *yy_bp; +#endif + { + register char *yy_cp = yy_c_buf_p; + + /* undo effects of setting up yytext */ + *yy_cp = yy_hold_char; + + if ( yy_cp < yy_current_buffer->yy_ch_buf + 2 ) + { /* need to shift things up to make room */ + /* +2 for EOB chars. */ + register int number_to_move = yy_n_chars + 2; + register char *dest = &yy_current_buffer->yy_ch_buf[ + yy_current_buffer->yy_buf_size + 2]; + register char *source = + &yy_current_buffer->yy_ch_buf[number_to_move]; + + while ( source > yy_current_buffer->yy_ch_buf ) + *--dest = *--source; + + yy_cp += (int) (dest - source); + yy_bp += (int) (dest - source); + yy_current_buffer->yy_n_chars = + yy_n_chars = yy_current_buffer->yy_buf_size; + + if ( yy_cp < yy_current_buffer->yy_ch_buf + 2 ) + YY_FATAL_ERROR( "flex scanner push-back overflow" ); + } + + *--yy_cp = (char) c; + + + yytext_ptr = yy_bp; + yy_hold_char = *yy_cp; + yy_c_buf_p = yy_cp; + } +#endif /* ifndef YY_NO_UNPUT */ + + +#ifdef __cplusplus +static int yyinput() +#else +static int input() +#endif + { + int c; + + *yy_c_buf_p = yy_hold_char; + + if ( *yy_c_buf_p == YY_END_OF_BUFFER_CHAR ) + { + /* yy_c_buf_p now points to the character we want to return. + * If this occurs *before* the EOB characters, then it's a + * valid NUL; if not, then we've hit the end of the buffer. + */ + if ( yy_c_buf_p < &yy_current_buffer->yy_ch_buf[yy_n_chars] ) + /* This was really a NUL. */ + *yy_c_buf_p = '\0'; + + else + { /* need more input */ + int offset = yy_c_buf_p - yytext_ptr; + ++yy_c_buf_p; + + switch ( yy_get_next_buffer() ) + { + case EOB_ACT_LAST_MATCH: + /* This happens because yy_g_n_b() + * sees that we've accumulated a + * token and flags that we need to + * try matching the token before + * proceeding. But for input(), + * there's no matching to consider. + * So convert the EOB_ACT_LAST_MATCH + * to EOB_ACT_END_OF_FILE. + */ + + /* Reset buffer status. */ + yyrestart( yyin ); + + /* fall through */ + + case EOB_ACT_END_OF_FILE: + { + if ( yywrap() ) + return EOF; + + if ( ! yy_did_buffer_switch_on_eof ) + YY_NEW_FILE; +#ifdef __cplusplus + return yyinput(); +#else + return input(); +#endif + } + + case EOB_ACT_CONTINUE_SCAN: + yy_c_buf_p = yytext_ptr + offset; + break; + } + } + } + + c = *(unsigned char *) yy_c_buf_p; /* cast for 8-bit char's */ + *yy_c_buf_p = '\0'; /* preserve yytext */ + yy_hold_char = *++yy_c_buf_p; + + + return c; + } + + +#ifdef YY_USE_PROTOS +void yyrestart( FILE *input_file ) +#else +void yyrestart( input_file ) +FILE *input_file; +#endif + { + if ( ! yy_current_buffer ) + yy_current_buffer = yy_create_buffer( yyin, YY_BUF_SIZE ); + + yy_init_buffer( yy_current_buffer, input_file ); + yy_load_buffer_state(); + } + + +#ifdef YY_USE_PROTOS +void yy_switch_to_buffer( YY_BUFFER_STATE new_buffer ) +#else +void yy_switch_to_buffer( new_buffer ) +YY_BUFFER_STATE new_buffer; +#endif + { + if ( yy_current_buffer == new_buffer ) + return; + + if ( yy_current_buffer ) + { + /* Flush out information for old buffer. */ + *yy_c_buf_p = yy_hold_char; + yy_current_buffer->yy_buf_pos = yy_c_buf_p; + yy_current_buffer->yy_n_chars = yy_n_chars; + } + + yy_current_buffer = new_buffer; + yy_load_buffer_state(); + + /* We don't actually know whether we did this switch during + * EOF (yywrap()) processing, but the only time this flag + * is looked at is after yywrap() is called, so it's safe + * to go ahead and always set it. + */ + yy_did_buffer_switch_on_eof = 1; + } + + +#ifdef YY_USE_PROTOS +void yy_load_buffer_state( void ) +#else +void yy_load_buffer_state() +#endif + { + yy_n_chars = yy_current_buffer->yy_n_chars; + yytext_ptr = yy_c_buf_p = yy_current_buffer->yy_buf_pos; + yyin = yy_current_buffer->yy_input_file; + yy_hold_char = *yy_c_buf_p; + } + + +#ifdef YY_USE_PROTOS +YY_BUFFER_STATE yy_create_buffer( FILE *file, int size ) +#else +YY_BUFFER_STATE yy_create_buffer( file, size ) +FILE *file; +int size; +#endif + { + YY_BUFFER_STATE b; + + b = (YY_BUFFER_STATE) yy_flex_alloc( sizeof( struct yy_buffer_state ) ); + if ( ! b ) + YY_FATAL_ERROR( "out of dynamic memory in yy_create_buffer()" ); + + b->yy_buf_size = size; + + /* yy_ch_buf has to be 2 characters longer than the size given because + * we need to put in 2 end-of-buffer characters. + */ + b->yy_ch_buf = (char *) yy_flex_alloc( b->yy_buf_size + 2 ); + if ( ! b->yy_ch_buf ) + YY_FATAL_ERROR( "out of dynamic memory in yy_create_buffer()" ); + + b->yy_is_our_buffer = 1; + + yy_init_buffer( b, file ); + + return b; + } + + +#ifdef YY_USE_PROTOS +void yy_delete_buffer( YY_BUFFER_STATE b ) +#else +void yy_delete_buffer( b ) +YY_BUFFER_STATE b; +#endif + { + if ( ! b ) + return; + + if ( b == yy_current_buffer ) + yy_current_buffer = (YY_BUFFER_STATE) 0; + + if ( b->yy_is_our_buffer ) + yy_flex_free( (void *) b->yy_ch_buf ); + + yy_flex_free( (void *) b ); + } + + +#ifndef YY_ALWAYS_INTERACTIVE +#ifndef YY_NEVER_INTERACTIVE +#include +#endif +#endif + +#ifdef YY_USE_PROTOS +void yy_init_buffer( YY_BUFFER_STATE b, FILE *file ) +#else +void yy_init_buffer( b, file ) +YY_BUFFER_STATE b; +FILE *file; +#endif + + + { + yy_flush_buffer( b ); + + b->yy_input_file = file; + b->yy_fill_buffer = 1; + +#if YY_ALWAYS_INTERACTIVE + b->yy_is_interactive = 1; +#else +#if YY_NEVER_INTERACTIVE + b->yy_is_interactive = 0; +#else + b->yy_is_interactive = file ? (isatty( fileno(file) ) > 0) : 0; +#endif +#endif + } + + +#ifdef YY_USE_PROTOS +void yy_flush_buffer( YY_BUFFER_STATE b ) +#else +void yy_flush_buffer( b ) +YY_BUFFER_STATE b; +#endif + + { + if ( ! b ) + return; + + b->yy_n_chars = 0; + + /* We always need two end-of-buffer characters. The first causes + * a transition to the end-of-buffer state. The second causes + * a jam in that state. + */ + b->yy_ch_buf[0] = YY_END_OF_BUFFER_CHAR; + b->yy_ch_buf[1] = YY_END_OF_BUFFER_CHAR; + + b->yy_buf_pos = &b->yy_ch_buf[0]; + + b->yy_at_bol = 1; + b->yy_buffer_status = YY_BUFFER_NEW; + + if ( b == yy_current_buffer ) + yy_load_buffer_state(); + } + + +#ifndef YY_NO_SCAN_BUFFER +#ifdef YY_USE_PROTOS +YY_BUFFER_STATE yy_scan_buffer( char *base, yy_size_t size ) +#else +YY_BUFFER_STATE yy_scan_buffer( base, size ) +char *base; +yy_size_t size; +#endif + { + YY_BUFFER_STATE b; + + if ( size < 2 || + base[size-2] != YY_END_OF_BUFFER_CHAR || + base[size-1] != YY_END_OF_BUFFER_CHAR ) + /* They forgot to leave room for the EOB's. */ + return 0; + + b = (YY_BUFFER_STATE) yy_flex_alloc( sizeof( struct yy_buffer_state ) ); + if ( ! b ) + YY_FATAL_ERROR( "out of dynamic memory in yy_scan_buffer()" ); + + b->yy_buf_size = size - 2; /* "- 2" to take care of EOB's */ + b->yy_buf_pos = b->yy_ch_buf = base; + b->yy_is_our_buffer = 0; + b->yy_input_file = 0; + b->yy_n_chars = b->yy_buf_size; + b->yy_is_interactive = 0; + b->yy_at_bol = 1; + b->yy_fill_buffer = 0; + b->yy_buffer_status = YY_BUFFER_NEW; + + yy_switch_to_buffer( b ); + + return b; + } +#endif + + +#ifndef YY_NO_SCAN_STRING +#ifdef YY_USE_PROTOS +YY_BUFFER_STATE yy_scan_string( yyconst char *yy_str ) +#else +YY_BUFFER_STATE yy_scan_string( yy_str ) +yyconst char *yy_str; +#endif + { + int len; + for ( len = 0; yy_str[len]; ++len ) + ; + + return yy_scan_bytes( yy_str, len ); + } +#endif + + +#ifndef YY_NO_SCAN_BYTES +#ifdef YY_USE_PROTOS +YY_BUFFER_STATE yy_scan_bytes( yyconst char *bytes, int len ) +#else +YY_BUFFER_STATE yy_scan_bytes( bytes, len ) +yyconst char *bytes; +int len; +#endif + { + YY_BUFFER_STATE b; + char *buf; + yy_size_t n; + int i; + + /* Get memory for full buffer, including space for trailing EOB's. */ + n = len + 2; + buf = (char *) yy_flex_alloc( n ); + if ( ! buf ) + YY_FATAL_ERROR( "out of dynamic memory in yy_scan_bytes()" ); + + for ( i = 0; i < len; ++i ) + buf[i] = bytes[i]; + + buf[len] = buf[len+1] = YY_END_OF_BUFFER_CHAR; + + b = yy_scan_buffer( buf, n ); + if ( ! b ) + YY_FATAL_ERROR( "bad buffer in yy_scan_bytes()" ); + + /* It's okay to grow etc. this buffer, and we should throw it + * away when we're done. + */ + b->yy_is_our_buffer = 1; + + return b; + } +#endif + + +#ifndef YY_NO_PUSH_STATE +#ifdef YY_USE_PROTOS +static void yy_push_state( int new_state ) +#else +static void yy_push_state( new_state ) +int new_state; +#endif + { + if ( yy_start_stack_ptr >= yy_start_stack_depth ) + { + yy_size_t new_size; + + yy_start_stack_depth += YY_START_STACK_INCR; + new_size = yy_start_stack_depth * sizeof( int ); + + if ( ! yy_start_stack ) + yy_start_stack = (int *) yy_flex_alloc( new_size ); + + else + yy_start_stack = (int *) yy_flex_realloc( + (void *) yy_start_stack, new_size ); + + if ( ! yy_start_stack ) + YY_FATAL_ERROR( + "out of memory expanding start-condition stack" ); + } + + yy_start_stack[yy_start_stack_ptr++] = YY_START; + + BEGIN(new_state); + } +#endif + + +#ifndef YY_NO_POP_STATE +static void yy_pop_state() + { + if ( --yy_start_stack_ptr < 0 ) + YY_FATAL_ERROR( "start-condition stack underflow" ); + + BEGIN(yy_start_stack[yy_start_stack_ptr]); + } +#endif + + +#ifndef YY_NO_TOP_STATE +static int yy_top_state() + { + return yy_start_stack[yy_start_stack_ptr - 1]; + } +#endif + +#ifndef YY_EXIT_FAILURE +#define YY_EXIT_FAILURE 2 +#endif + +#ifdef YY_USE_PROTOS +static void yy_fatal_error( yyconst char msg[] ) +#else +static void yy_fatal_error( msg ) +char msg[]; +#endif + { + (void) fprintf( stderr, "%s\n", msg ); + exit( YY_EXIT_FAILURE ); + } + + + +/* Redefine yyless() so it works in section 3 code. */ + +#undef yyless +#define yyless(n) \ + do \ + { \ + /* Undo effects of setting up yytext. */ \ + yytext[yyleng] = yy_hold_char; \ + yy_c_buf_p = yytext + n; \ + yy_hold_char = *yy_c_buf_p; \ + *yy_c_buf_p = '\0'; \ + yyleng = n; \ + } \ + while ( 0 ) + + +/* Internal utility routines. */ + +#ifndef yytext_ptr +#ifdef YY_USE_PROTOS +static void yy_flex_strncpy( char *s1, yyconst char *s2, int n ) +#else +static void yy_flex_strncpy( s1, s2, n ) +char *s1; +yyconst char *s2; +int n; +#endif + { + register int i; + for ( i = 0; i < n; ++i ) + s1[i] = s2[i]; + } +#endif + +#ifdef YY_NEED_STRLEN +#ifdef YY_USE_PROTOS +static int yy_flex_strlen( yyconst char *s ) +#else +static int yy_flex_strlen( s ) +yyconst char *s; +#endif + { + register int n; + for ( n = 0; s[n]; ++n ) + ; + + return n; + } +#endif + + +#ifdef YY_USE_PROTOS +static void *yy_flex_alloc( yy_size_t size ) +#else +static void *yy_flex_alloc( size ) +yy_size_t size; +#endif + { + return (void *) malloc( size ); + } + +#ifdef YY_USE_PROTOS +static void *yy_flex_realloc( void *ptr, yy_size_t size ) +#else +static void *yy_flex_realloc( ptr, size ) +void *ptr; +yy_size_t size; +#endif + { + /* The cast to (char *) in the following accommodates both + * implementations that use char* generic pointers, and those + * that use void* generic pointers. It works with the latter + * because both ANSI C and C++ allow castless assignment from + * any pointer type to void*, and deal with argument conversions + * as though doing an assignment. + */ + return (void *) realloc( (char *) ptr, size ); + } + +#ifdef YY_USE_PROTOS +static void yy_flex_free( void *ptr ) +#else +static void yy_flex_free( ptr ) +void *ptr; +#endif + { + free( ptr ); + } + +#if YY_MAIN +int main() + { + yylex(); + return 0; + } +#endif +#line 209 "scheme.flex" + + diff --git a/scheme.tab.m b/scheme.tab.m new file mode 100644 index 0000000..45b7e4f --- /dev/null +++ b/scheme.tab.m @@ -0,0 +1,1614 @@ + +/* A Bison parser, made from scheme.y + by GNU Bison version 1.28 */ + +#define YYBISON 1 /* Identify Bison output. */ + +#define LPAREN 257 +#define LVECTPAREN 258 +#define RPAREN 259 +#define DEFINE 260 +#define SET 261 +#define LAMBDA 262 +#define BEGINTOK 263 +#define AND 264 +#define OR 265 +#define CASE 266 +#define COND 267 +#define ELSE 268 +#define ARROW 269 +#define CALLCC 270 +#define APPLY 271 +#define IF 272 +#define LET 273 +#define LETSTAR 274 +#define LETREC 275 +#define DOT 276 +#define INTEGER 277 +#define CHAR 278 +#define BOOLEAN 279 +#define DOUBLE 280 +#define SYMBOL 281 +#define STRING 282 +#define QUOTECHAR 283 +#define QUOTE 284 + +#line 1 "scheme.y" + +#import "SchemeTypes.h" + +#define YYSTYPE id + +YYSTYPE yyresult; +int yyinputitem; + +extern int yysofar; +extern NSMutableArray *positions; +#ifndef YYSTYPE +#define YYSTYPE int +#endif +#include + +#ifndef __cplusplus +#ifndef __STDC__ +#define const +#endif +#endif + + + +#define YYFINAL 164 +#define YYFLAG -32768 +#define YYNTBASE 31 + +#define YYTRANSLATE(x) ((unsigned)(x) <= 284 ? yytranslate[x] : 66) + +static const char yytranslate[] = { 0, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 1, 3, 4, 5, 6, + 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, + 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, + 27, 28, 29, 30 +}; + +#if YYDEBUG != 0 +static const short yyprhs[] = { 0, + 0, 1, 4, 10, 16, 18, 20, 23, 25, 28, + 30, 32, 34, 36, 38, 40, 42, 44, 46, 48, + 50, 52, 54, 56, 58, 60, 62, 64, 66, 68, + 70, 72, 77, 84, 88, 93, 99, 104, 106, 109, + 111, 114, 120, 127, 132, 138, 143, 147, 152, 156, + 161, 167, 173, 179, 186, 192, 198, 201, 206, 211, + 213, 216, 224, 232, 240, 243, 245, 249, 252, 254, + 257, 261, 263, 265, 269, 272, 274, 278, 281, 285, + 287 +}; + +static const short yyrhs[] = { -1, + 32, 31, 0, 3, 6, 27, 35, 5, 0, 3, + 6, 64, 33, 5, 0, 35, 0, 35, 0, 35, + 33, 0, 35, 0, 34, 35, 0, 23, 0, 24, + 0, 25, 0, 26, 0, 27, 0, 28, 0, 61, + 0, 62, 0, 50, 0, 49, 0, 54, 0, 55, + 0, 56, 0, 51, 0, 48, 0, 47, 0, 46, + 0, 44, 0, 45, 0, 42, 0, 43, 0, 36, + 0, 3, 16, 35, 5, 0, 3, 3, 33, 5, + 33, 5, 0, 3, 35, 5, 0, 3, 35, 33, + 5, 0, 3, 35, 15, 35, 5, 0, 3, 14, + 33, 5, 0, 37, 0, 40, 37, 0, 38, 0, + 41, 38, 0, 3, 12, 35, 40, 5, 0, 3, + 12, 35, 40, 39, 5, 0, 3, 13, 41, 5, + 0, 3, 13, 41, 39, 5, 0, 3, 10, 34, + 5, 0, 3, 10, 5, 0, 3, 11, 34, 5, + 0, 3, 11, 5, 0, 3, 9, 33, 5, 0, + 3, 7, 27, 35, 5, 0, 3, 17, 35, 35, + 5, 0, 3, 18, 35, 35, 5, 0, 3, 18, + 35, 35, 35, 5, 0, 3, 8, 27, 33, 5, + 0, 3, 8, 65, 33, 5, 0, 29, 35, 0, + 3, 30, 35, 5, 0, 3, 27, 35, 5, 0, + 52, 0, 52, 53, 0, 3, 19, 3, 53, 5, + 33, 5, 0, 3, 20, 3, 53, 5, 33, 5, + 0, 3, 21, 3, 53, 5, 33, 5, 0, 3, + 5, 0, 35, 0, 35, 22, 35, 0, 35, 58, + 0, 35, 0, 35, 59, 0, 3, 58, 5, 0, + 60, 0, 57, 0, 4, 59, 5, 0, 4, 5, + 0, 27, 0, 27, 22, 27, 0, 27, 63, 0, + 3, 63, 5, 0, 64, 0, 57, 0 +}; + +#endif + +#if YYDEBUG != 0 +static const short yyrline[] = { 0, + 55, 59, 66, 74, 82, 92, 95, 100, 103, 108, + 111, 114, 117, 120, 123, 126, 129, 132, 135, 138, + 141, 144, 147, 150, 153, 156, 159, 162, 165, 168, + 171, 175, 179, 183, 186, 189, 193, 197, 200, 205, + 208, 213, 216, 221, 224, 228, 231, 235, 238, 242, + 246, 250, 254, 257, 261, 264, 268, 271, 276, 280, + 283, 287, 291, 295, 299, 304, 307, 310, 315, 318, + 323, 328, 331, 336, 339, 344, 347, 350, 355, 360, + 363 +}; +#endif + + +#if YYDEBUG != 0 || defined (YYERROR_VERBOSE) + +static const char * const yytname[] = { "$","error","$undefined.","LPAREN", +"LVECTPAREN","RPAREN","DEFINE","SET","LAMBDA","BEGINTOK","AND","OR","CASE","COND", +"ELSE","ARROW","CALLCC","APPLY","IF","LET","LETSTAR","LETREC","DOT","INTEGER", +"CHAR","BOOLEAN","DOUBLE","SYMBOL","STRING","QUOTECHAR","QUOTE","top","topitem", +"sequence","revsequence","form","callcc","singlecase","singlecond","elsecasecond", +"cases","conditions","case","cond","and","or","begin","set","apply","if","lambda", +"quote","singlebinding","listofbindings","let","letstar","letrec","emptylist", +"nonemptylistdata","nonemptyvectdata","nonemptylist","list","vector","nonemptysymlistdata", +"nonemptysymlist","symlist", NULL +}; +#endif + +static const short yyr1[] = { 0, + 31, 31, 32, 32, 32, 33, 33, 34, 34, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 36, 37, 38, 38, 38, 39, 40, 40, 41, + 41, 42, 42, 43, 43, 44, 44, 45, 45, 46, + 47, 48, 49, 49, 50, 50, 51, 51, 52, 53, + 53, 54, 55, 56, 57, 58, 58, 58, 59, 59, + 60, 61, 61, 62, 62, 63, 63, 63, 64, 65, + 65 +}; + +static const short yyr2[] = { 0, + 0, 2, 5, 5, 1, 1, 2, 1, 2, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 4, 6, 3, 4, 5, 4, 1, 2, 1, + 2, 5, 6, 4, 5, 4, 3, 4, 3, 4, + 5, 5, 5, 6, 5, 5, 2, 4, 4, 1, + 2, 7, 7, 7, 2, 1, 3, 2, 1, 2, + 3, 1, 1, 3, 2, 1, 3, 2, 3, 1, + 1 +}; + +static const short yydefact[] = { 1, + 0, 0, 10, 11, 12, 13, 14, 15, 0, 1, + 5, 31, 29, 30, 27, 28, 26, 25, 24, 19, + 18, 23, 20, 21, 22, 73, 72, 16, 17, 0, + 65, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 66, 0, 75, 69, + 0, 57, 2, 0, 0, 0, 0, 0, 0, 81, + 80, 0, 0, 6, 47, 0, 8, 49, 0, 0, + 0, 40, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 68, 71, 70, 74, 76, 0, 0, 0, 0, + 0, 0, 50, 7, 46, 9, 48, 0, 38, 0, + 0, 0, 44, 41, 0, 32, 0, 0, 0, 60, + 0, 0, 0, 58, 67, 0, 78, 79, 3, 4, + 51, 55, 56, 0, 0, 42, 39, 0, 34, 0, + 0, 0, 45, 52, 53, 0, 0, 61, 0, 0, + 0, 77, 0, 43, 0, 35, 0, 54, 0, 0, + 0, 0, 0, 36, 37, 59, 62, 63, 64, 0, + 33, 0, 0, 0 +}; + +static const short yydefgoto[] = { 53, + 10, 63, 66, 64, 12, 99, 72, 105, 100, 73, + 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, + 110, 111, 23, 24, 25, 26, 48, 51, 27, 28, + 29, 87, 56, 62 +}; + +static const short yypact[] = { 267, + 115, 60,-32768,-32768,-32768,-32768,-32768,-32768, 294, 267, +-32768,-32768,-32768,-32768,-32768,-32768,-32768,-32768,-32768,-32768, +-32768,-32768,-32768,-32768,-32768,-32768,-32768,-32768,-32768, 143, +-32768, 2, -15, 4, 294, 178, 185, 294, 15, 294, + 294, 294, 21, 22, 23, 294, 212, 27,-32768, 294, + 28,-32768,-32768, 7, 294, 294, 294, 1, 294,-32768, +-32768, 294, 34, 294,-32768, 219,-32768,-32768, 226, 24, + 294,-32768, 10, 38, 294, 294, 41, 41, 41, 40, + 294,-32768,-32768,-32768,-32768, -11, 43, 44, 46, 47, + 48, 49,-32768,-32768,-32768,-32768,-32768, 53,-32768, 18, + 171, 253,-32768,-32768, 55,-32768, 56, 260, 31, 41, + 57, 62, 63,-32768,-32768, 45,-32768,-32768,-32768,-32768, +-32768,-32768,-32768, 294, 5,-32768,-32768, 65,-32768, 294, + 68, 294,-32768,-32768,-32768, 69, 294,-32768, 294, 294, + 294,-32768, 72,-32768, 73,-32768, 74,-32768, 75, 86, + 87, 88, 294,-32768,-32768,-32768,-32768,-32768,-32768, 89, +-32768, 95, 96,-32768 +}; + +static const short yypgoto[] = { 100, +-32768, -42, 64, 0,-32768, 3, 32, 6,-32768,-32768, +-32768,-32768,-32768,-32768,-32768,-32768,-32768,-32768,-32768,-32768, +-32768, -75,-32768,-32768,-32768, 70, 66, 59,-32768,-32768, +-32768, 26, 76,-32768 +}; + + +#define YYLAST 323 + + +static const short yytable[] = { 11, + 47, 50, 112, 113, 54, 31, 58, 124, 52, 11, + 116, 57, 102, 89, 103, 86, 91, 71, 132, 92, + 125, 94, 126, 77, 78, 79, 98, 86, 55, 47, + 59, 83, 85, 86, 138, 67, 67, 70, 93, 74, + 75, 76, 106, 109, 114, 80, 47, 118, 119, 50, + 120, 121, 122, 123, 88, 124, 90, 137, 131, 133, + 134, 139, 30, 2, 49, 96, 140, 141, 96, 144, + 101, 142, 146, 148, 107, 108, 153, 154, 155, 156, + 115, 143, 3, 4, 5, 6, 7, 8, 9, 147, + 157, 158, 159, 161, 163, 164, 150, 151, 152, 162, + 69, 101, 127, 60, 104, 128, 0, 136, 84, 61, + 160, 117, 82, 0, 0, 0, 0, 30, 2, 31, + 32, 33, 34, 35, 36, 37, 38, 39, 0, 145, + 40, 41, 42, 43, 44, 45, 149, 3, 4, 5, + 6, 7, 8, 9, 46, 30, 2, 31, 0, 33, + 34, 35, 36, 37, 38, 39, 0, 0, 40, 41, + 42, 43, 44, 45, 0, 3, 4, 5, 6, 7, + 8, 9, 46, 30, 2, 129, 0, 0, 0, 0, + 30, 2, 65, 0, 0, 130, 0, 30, 2, 68, + 0, 0, 0, 3, 4, 5, 6, 7, 8, 9, + 3, 4, 5, 6, 7, 8, 9, 3, 4, 5, + 6, 7, 8, 9, 30, 2, 0, 0, 0, 0, + 0, 30, 2, 95, 0, 0, 0, 0, 30, 2, + 97, 0, 0, 81, 3, 4, 5, 6, 7, 8, + 9, 3, 4, 5, 6, 7, 8, 9, 3, 4, + 5, 6, 7, 8, 9, 30, 2, 0, 0, 0, + 0, 0, 30, 2, 135, 0, 132, 0, 0, 1, + 2, 0, 0, 0, 0, 3, 4, 5, 6, 7, + 8, 9, 3, 4, 5, 6, 7, 8, 9, 3, + 4, 5, 6, 7, 8, 9, 30, 2, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 3, 4, 5, 6, + 7, 8, 9 +}; + +static const short yycheck[] = { 0, + 1, 2, 78, 79, 3, 5, 3, 3, 9, 10, + 22, 27, 3, 56, 5, 27, 59, 3, 14, 62, + 3, 64, 5, 3, 3, 3, 3, 27, 27, 30, + 27, 5, 5, 27, 110, 36, 37, 38, 5, 40, + 41, 42, 5, 3, 5, 46, 47, 5, 5, 50, + 5, 5, 5, 5, 55, 3, 57, 27, 101, 5, + 5, 5, 3, 4, 5, 66, 5, 5, 69, 5, + 71, 27, 5, 5, 75, 76, 5, 5, 5, 5, + 81, 124, 23, 24, 25, 26, 27, 28, 29, 132, + 5, 5, 5, 5, 0, 0, 139, 140, 141, 0, + 37, 102, 100, 34, 73, 100, -1, 108, 50, 34, + 153, 86, 47, -1, -1, -1, -1, 3, 4, 5, + 6, 7, 8, 9, 10, 11, 12, 13, -1, 130, + 16, 17, 18, 19, 20, 21, 137, 23, 24, 25, + 26, 27, 28, 29, 30, 3, 4, 5, -1, 7, + 8, 9, 10, 11, 12, 13, -1, -1, 16, 17, + 18, 19, 20, 21, -1, 23, 24, 25, 26, 27, + 28, 29, 30, 3, 4, 5, -1, -1, -1, -1, + 3, 4, 5, -1, -1, 15, -1, 3, 4, 5, + -1, -1, -1, 23, 24, 25, 26, 27, 28, 29, + 23, 24, 25, 26, 27, 28, 29, 23, 24, 25, + 26, 27, 28, 29, 3, 4, -1, -1, -1, -1, + -1, 3, 4, 5, -1, -1, -1, -1, 3, 4, + 5, -1, -1, 22, 23, 24, 25, 26, 27, 28, + 29, 23, 24, 25, 26, 27, 28, 29, 23, 24, + 25, 26, 27, 28, 29, 3, 4, -1, -1, -1, + -1, -1, 3, 4, 5, -1, 14, -1, -1, 3, + 4, -1, -1, -1, -1, 23, 24, 25, 26, 27, + 28, 29, 23, 24, 25, 26, 27, 28, 29, 23, + 24, 25, 26, 27, 28, 29, 3, 4, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 23, 24, 25, 26, + 27, 28, 29 +}; +/* -*-C-*- Note some compilers choke on comments on `#line' lines. */ +#line 3 "/usr/share/bison.simple" +/* This file comes from bison-1.28. */ + +/* Skeleton output parser for bison, + Copyright (C) 1984, 1989, 1990 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. */ + +/* As a special exception, when this file is copied by Bison into a + Bison output file, you may use that output file without restriction. + This special exception was added by the Free Software Foundation + in version 1.24 of Bison. */ + +/* This is the parser code that is written into each bison parser + when the %semantic_parser declaration is not specified in the grammar. + It was written by Richard Stallman by simplifying the hairy parser + used when %semantic_parser is specified. */ + +#ifndef YYPARSE_RETURN_TYPE +#define YYPARSE_RETURN_TYPE int +#endif + + +#ifndef YYSTACK_USE_ALLOCA +#ifdef alloca +#define YYSTACK_USE_ALLOCA +#else /* alloca not defined */ +#ifdef __GNUC__ +#define YYSTACK_USE_ALLOCA +#define alloca __builtin_alloca +#else /* not GNU C. */ +#if (!defined (__STDC__) && defined (sparc)) || defined (__sparc__) || defined (__sparc) || defined (__sgi) || (defined (__sun) && defined (__i386)) +#define YYSTACK_USE_ALLOCA +#include +#else /* not sparc */ +/* We think this test detects Watcom and Microsoft C. */ +/* This used to test MSDOS, but that is a bad idea + since that symbol is in the user namespace. */ +#if (defined (_MSDOS) || defined (_MSDOS_)) && !defined (__TURBOC__) +#if 0 /* No need for malloc.h, which pollutes the namespace; + instead, just don't use alloca. */ +#include +#endif +#else /* not MSDOS, or __TURBOC__ */ +#if defined(_AIX) +/* I don't know what this was needed for, but it pollutes the namespace. + So I turned it off. rms, 2 May 1997. */ +/* #include */ + #pragma alloca +#define YYSTACK_USE_ALLOCA +#else /* not MSDOS, or __TURBOC__, or _AIX */ +#if 0 +#ifdef __hpux /* haible@ilog.fr says this works for HPUX 9.05 and up, + and on HPUX 10. Eventually we can turn this on. */ +#define YYSTACK_USE_ALLOCA +#define alloca __builtin_alloca +#endif /* __hpux */ +#endif +#endif /* not _AIX */ +#endif /* not MSDOS, or __TURBOC__ */ +#endif /* not sparc */ +#endif /* not GNU C */ +#endif /* alloca not defined */ +#endif /* YYSTACK_USE_ALLOCA not defined */ + +#ifdef YYSTACK_USE_ALLOCA +#define YYSTACK_ALLOC alloca +#else +#define YYSTACK_ALLOC malloc +#endif + +/* Note: there must be only one dollar sign in this file. + It is replaced by the list of actions, each action + as one case of the switch. */ + +#define yyerrok (yyerrstatus = 0) +#define yyclearin (yychar = YYEMPTY) +#define YYEMPTY -2 +#define YYEOF 0 +#define YYACCEPT goto yyacceptlab +#define YYABORT goto yyabortlab +#define YYERROR goto yyerrlab1 +/* Like YYERROR except do call yyerror. + This remains here temporarily to ease the + transition to the new meaning of YYERROR, for GCC. + Once GCC version 2 has supplanted version 1, this can go. */ +#define YYFAIL goto yyerrlab +#define YYRECOVERING() (!!yyerrstatus) +#define YYBACKUP(token, value) \ +do \ + if (yychar == YYEMPTY && yylen == 1) \ + { yychar = (token), yylval = (value); \ + yychar1 = YYTRANSLATE (yychar); \ + YYPOPSTACK; \ + goto yybackup; \ + } \ + else \ + { yyerror ("syntax error: cannot back up"); YYERROR; } \ +while (0) + +#define YYTERROR 1 +#define YYERRCODE 256 + +#ifndef YYPURE +#define YYLEX yylex() +#endif + +#ifdef YYPURE +#ifdef YYLSP_NEEDED +#ifdef YYLEX_PARAM +#define YYLEX yylex(&yylval, &yylloc, YYLEX_PARAM) +#else +#define YYLEX yylex(&yylval, &yylloc) +#endif +#else /* not YYLSP_NEEDED */ +#ifdef YYLEX_PARAM +#define YYLEX yylex(&yylval, YYLEX_PARAM) +#else +#define YYLEX yylex(&yylval) +#endif +#endif /* not YYLSP_NEEDED */ +#endif + +/* If nonreentrant, generate the variables here */ + +#ifndef YYPURE + +int yychar; /* the lookahead symbol */ +YYSTYPE yylval; /* the semantic value of the */ + /* lookahead symbol */ + +#ifdef YYLSP_NEEDED +YYLTYPE yylloc; /* location data for the lookahead */ + /* symbol */ +#endif + +int yynerrs; /* number of parse errors so far */ +#endif /* not YYPURE */ + +#if YYDEBUG != 0 +int yydebug; /* nonzero means print parse trace */ +/* Since this is uninitialized, it does not stop multiple parsers + from coexisting. */ +#endif + +/* YYINITDEPTH indicates the initial size of the parser's stacks */ + +#ifndef YYINITDEPTH +#define YYINITDEPTH 200 +#endif + +/* YYMAXDEPTH is the maximum size the stacks can grow to + (effective only if the built-in stack extension method is used). */ + +#if YYMAXDEPTH == 0 +#undef YYMAXDEPTH +#endif + +#ifndef YYMAXDEPTH +#define YYMAXDEPTH 10000 +#endif + +/* Define __yy_memcpy. Note that the size argument + should be passed with type unsigned int, because that is what the non-GCC + definitions require. With GCC, __builtin_memcpy takes an arg + of type size_t, but it can handle unsigned int. */ + +#if __GNUC__ > 1 /* GNU C and GNU C++ define this. */ +#define __yy_memcpy(TO,FROM,COUNT) __builtin_memcpy(TO,FROM,COUNT) +#else /* not GNU C or C++ */ +#ifndef __cplusplus + +/* This is the most reliable way to avoid incompatibilities + in available built-in functions on various systems. */ +static void +__yy_memcpy (to, from, count) + char *to; + char *from; + unsigned int count; +{ + register char *f = from; + register char *t = to; + register int i = count; + + while (i-- > 0) + *t++ = *f++; +} + +#else /* __cplusplus */ + +/* This is the most reliable way to avoid incompatibilities + in available built-in functions on various systems. */ +static void +__yy_memcpy (char *to, char *from, unsigned int count) +{ + register char *t = to; + register char *f = from; + register int i = count; + + while (i-- > 0) + *t++ = *f++; +} + +#endif +#endif + +#line 222 "/usr/share/bison.simple" + +/* The user can define YYPARSE_PARAM as the name of an argument to be passed + into yyparse. The argument should have type void *. + It should actually point to an object. + Grammar actions can access the variable by casting it + to the proper pointer type. */ + +#ifdef YYPARSE_PARAM +#ifdef __cplusplus +#define YYPARSE_PARAM_ARG void *YYPARSE_PARAM +#define YYPARSE_PARAM_DECL +#else /* not __cplusplus */ +#define YYPARSE_PARAM_ARG YYPARSE_PARAM +#define YYPARSE_PARAM_DECL void *YYPARSE_PARAM; +#endif /* not __cplusplus */ +#else /* not YYPARSE_PARAM */ +#define YYPARSE_PARAM_ARG +#define YYPARSE_PARAM_DECL +#endif /* not YYPARSE_PARAM */ + +/* Prevent warning if -Wstrict-prototypes. */ +#ifdef __GNUC__ +#ifdef YYPARSE_PARAM +YYPARSE_RETURN_TYPE +yyparse (void *); +#else +YYPARSE_RETURN_TYPE +yyparse (void); +#endif +#endif + +YYPARSE_RETURN_TYPE +yyparse(YYPARSE_PARAM_ARG) + YYPARSE_PARAM_DECL +{ + register int yystate; + register int yyn; + register short *yyssp; + register YYSTYPE *yyvsp; + int yyerrstatus; /* number of tokens to shift before error messages enabled */ + int yychar1 = 0; /* lookahead token as an internal (translated) token number */ + + short yyssa[YYINITDEPTH]; /* the state stack */ + YYSTYPE yyvsa[YYINITDEPTH]; /* the semantic value stack */ + + short *yyss = yyssa; /* refer to the stacks thru separate pointers */ + YYSTYPE *yyvs = yyvsa; /* to allow yyoverflow to reallocate them elsewhere */ + +#ifdef YYLSP_NEEDED + YYLTYPE yylsa[YYINITDEPTH]; /* the location stack */ + YYLTYPE *yyls = yylsa; + YYLTYPE *yylsp; + +#define YYPOPSTACK (yyvsp--, yyssp--, yylsp--) +#else +#define YYPOPSTACK (yyvsp--, yyssp--) +#endif + + int yystacksize = YYINITDEPTH; +#ifndef YYSTACK_USE_ALLOCA + int yyfree_stacks = 0; +#endif + +#ifdef YYPURE + int yychar; + YYSTYPE yylval; + int yynerrs; +#ifdef YYLSP_NEEDED + YYLTYPE yylloc; +#endif +#endif + + YYSTYPE yyval; /* the variable used to return */ + /* semantic values from the action */ + /* routines */ + + int yylen; + +#if YYDEBUG != 0 + if (yydebug) + fprintf(stderr, "Starting parse\n"); +#endif + + yystate = 0; + yyerrstatus = 0; + yynerrs = 0; + yychar = YYEMPTY; /* Cause a token to be read. */ + + /* Initialize stack pointers. + Waste one element of value and location stack + so that they stay on the same level as the state stack. + The wasted elements are never initialized. */ + + yyssp = yyss - 1; + yyvsp = yyvs; +#ifdef YYLSP_NEEDED + yylsp = yyls; +#endif + +/* Push a new state, which is found in yystate . */ +/* In all cases, when you get here, the value and location stacks + have just been pushed. so pushing a state here evens the stacks. */ +yynewstate: + + *++yyssp = yystate; + + if (yyssp >= yyss + yystacksize - 1) + { + /* Give user a chance to reallocate the stack */ + /* Use copies of these so that the &'s don't force the real ones into memory. */ + YYSTYPE *yyvs1 = yyvs; + short *yyss1 = yyss; +#ifdef YYLSP_NEEDED + YYLTYPE *yyls1 = yyls; +#endif + + /* Get the current used size of the three stacks, in elements. */ + int size = yyssp - yyss + 1; + +#ifdef yyoverflow + /* Each stack pointer address is followed by the size of + the data in use in that stack, in bytes. */ +#ifdef YYLSP_NEEDED + /* This used to be a conditional around just the two extra args, + but that might be undefined if yyoverflow is a macro. */ + yyoverflow("parser stack overflow", + &yyss1, size * sizeof (*yyssp), + &yyvs1, size * sizeof (*yyvsp), + &yyls1, size * sizeof (*yylsp), + &yystacksize); +#else + yyoverflow("parser stack overflow", + &yyss1, size * sizeof (*yyssp), + &yyvs1, size * sizeof (*yyvsp), + &yystacksize); +#endif + + yyss = yyss1; yyvs = yyvs1; +#ifdef YYLSP_NEEDED + yyls = yyls1; +#endif +#else /* no yyoverflow */ + /* Extend the stack our own way. */ + if (yystacksize >= YYMAXDEPTH) + { + yyerror("parser stack overflow"); +#ifndef YYSTACK_USE_ALLOCA + if (yyfree_stacks) + { + free (yyss); + free (yyvs); +#ifdef YYLSP_NEEDED + free (yyls); +#endif + } +#endif + return 2; + } + yystacksize *= 2; + if (yystacksize > YYMAXDEPTH) + yystacksize = YYMAXDEPTH; +#ifndef YYSTACK_USE_ALLOCA + yyfree_stacks = 1; +#endif + yyss = (short *) YYSTACK_ALLOC (yystacksize * sizeof (*yyssp)); + __yy_memcpy ((char *)yyss, (char *)yyss1, + size * (unsigned int) sizeof (*yyssp)); + yyvs = (YYSTYPE *) YYSTACK_ALLOC (yystacksize * sizeof (*yyvsp)); + __yy_memcpy ((char *)yyvs, (char *)yyvs1, + size * (unsigned int) sizeof (*yyvsp)); +#ifdef YYLSP_NEEDED + yyls = (YYLTYPE *) YYSTACK_ALLOC (yystacksize * sizeof (*yylsp)); + __yy_memcpy ((char *)yyls, (char *)yyls1, + size * (unsigned int) sizeof (*yylsp)); +#endif +#endif /* no yyoverflow */ + + yyssp = yyss + size - 1; + yyvsp = yyvs + size - 1; +#ifdef YYLSP_NEEDED + yylsp = yyls + size - 1; +#endif + +#if YYDEBUG != 0 + if (yydebug) + fprintf(stderr, "Stack size increased to %d\n", yystacksize); +#endif + + if (yyssp >= yyss + yystacksize - 1) + YYABORT; + } + +#if YYDEBUG != 0 + if (yydebug) + fprintf(stderr, "Entering state %d\n", yystate); +#endif + + goto yybackup; + yybackup: + +/* Do appropriate processing given the current state. */ +/* Read a lookahead token if we need one and don't already have one. */ +/* yyresume: */ + + /* First try to decide what to do without reference to lookahead token. */ + + yyn = yypact[yystate]; + if (yyn == YYFLAG) + goto yydefault; + + /* Not known => get a lookahead token if don't already have one. */ + + /* yychar is either YYEMPTY or YYEOF + or a valid token in external form. */ + + if (yychar == YYEMPTY) + { +#if YYDEBUG != 0 + if (yydebug) + fprintf(stderr, "Reading a token: "); +#endif + yychar = YYLEX; + } + + /* Convert token to internal form (in yychar1) for indexing tables with */ + + if (yychar <= 0) /* This means end of input. */ + { + yychar1 = 0; + yychar = YYEOF; /* Don't call YYLEX any more */ + +#if YYDEBUG != 0 + if (yydebug) + fprintf(stderr, "Now at end of input.\n"); +#endif + } + else + { + yychar1 = YYTRANSLATE(yychar); + +#if YYDEBUG != 0 + if (yydebug) + { + fprintf (stderr, "Next token is %d (%s", yychar, yytname[yychar1]); + /* Give the individual parser a way to print the precise meaning + of a token, for further debugging info. */ +#ifdef YYPRINT + YYPRINT (stderr, yychar, yylval); +#endif + fprintf (stderr, ")\n"); + } +#endif + } + + yyn += yychar1; + if (yyn < 0 || yyn > YYLAST || yycheck[yyn] != yychar1) + goto yydefault; + + yyn = yytable[yyn]; + + /* yyn is what to do for this token type in this state. + Negative => reduce, -yyn is rule number. + Positive => shift, yyn is new state. + New state is final state => don't bother to shift, + just return success. + 0, or most negative number => error. */ + + if (yyn < 0) + { + if (yyn == YYFLAG) + goto yyerrlab; + yyn = -yyn; + goto yyreduce; + } + else if (yyn == 0) + goto yyerrlab; + + if (yyn == YYFINAL) + YYACCEPT; + + /* Shift the lookahead token. */ + +#if YYDEBUG != 0 + if (yydebug) + fprintf(stderr, "Shifting token %d (%s), ", yychar, yytname[yychar1]); +#endif + + /* Discard the token being shifted unless it is eof. */ + if (yychar != YYEOF) + yychar = YYEMPTY; + + *++yyvsp = yylval; +#ifdef YYLSP_NEEDED + *++yylsp = yylloc; +#endif + + /* count tokens shifted since error; after three, turn off error status. */ + if (yyerrstatus) yyerrstatus--; + + yystate = yyn; + goto yynewstate; + +/* Do the default action for the current state. */ +yydefault: + + yyn = yydefact[yystate]; + if (yyn == 0) + goto yyerrlab; + +/* Do a reduction. yyn is the number of a rule to reduce with. */ +yyreduce: + yylen = yyr2[yyn]; + if (yylen > 0) + yyval = yyvsp[1-yylen]; /* implement default value of the action */ + +#if YYDEBUG != 0 + if (yydebug) + { + int i; + + fprintf (stderr, "Reducing via rule %d (line %d), ", + yyn, yyrline[yyn]); + + /* Print the symbols being reduced, and their result. */ + for (i = yyprhs[yyn]; yyrhs[i] > 0; i++) + fprintf (stderr, "%s ", yytname[yyrhs[i]]); + fprintf (stderr, " -> %s\n", yytname[yyr1[yyn]]); + } +#endif + + + switch (yyn) { + +case 1: +#line 55 "scheme.y" +{ + yyresult = + yyval = [NSNull null]; +; + break;} +case 2: +#line 59 "scheme.y" +{ + yyresult = + yyval = [Triple newTag:FORM_TOP Arg1:yyvsp[-1] Arg2:yyvsp[0]]; + yyinputitem++; +; + break;} +case 3: +#line 66 "scheme.y" +{ + NSValue *entry = + [NSValue valueWithRange:NSMakeRange(yysofar, 0)]; + + yyval = [Triple newTag:FORM_DEFINE1 Arg1:yyvsp[-2] Arg2:yyvsp[-1]]; + + [positions addObject:entry]; +; + break;} +case 4: +#line 74 "scheme.y" +{ + NSValue *entry = + [NSValue valueWithRange:NSMakeRange(yysofar, 0)]; + + yyval = [Triple newTag:FORM_DEFINE2 Arg1:yyvsp[-2] Arg2:yyvsp[-1]]; + + [positions addObject:entry]; +; + break;} +case 5: +#line 82 "scheme.y" +{ + NSValue *entry = + [NSValue valueWithRange:NSMakeRange(yysofar, 0)]; + + yyval = yyvsp[0]; + + [positions addObject:entry]; +; + break;} +case 6: +#line 92 "scheme.y" +{ + yyval = [Pair newCar:yyvsp[0] Cdr:[NSNull null]]; +; + break;} +case 7: +#line 95 "scheme.y" +{ + yyval = [Pair newCar:yyvsp[-1] Cdr:yyvsp[0]]; +; + break;} +case 8: +#line 100 "scheme.y" +{ + yyval = [Pair newCar:yyvsp[0] Cdr:[NSNull null]]; +; + break;} +case 9: +#line 103 "scheme.y" +{ + yyval = [Pair newCar:yyvsp[0] Cdr:yyvsp[-1]]; +; + break;} +case 10: +#line 108 "scheme.y" +{ + yyval = yyvsp[0]; +; + break;} +case 11: +#line 111 "scheme.y" +{ + yyval = yyvsp[0]; +; + break;} +case 12: +#line 114 "scheme.y" +{ + yyval = yyvsp[0]; +; + break;} +case 13: +#line 117 "scheme.y" +{ + yyval = yyvsp[0]; +; + break;} +case 14: +#line 120 "scheme.y" +{ + yyval = yyvsp[0]; +; + break;} +case 15: +#line 123 "scheme.y" +{ + yyval = yyvsp[0]; +; + break;} +case 16: +#line 126 "scheme.y" +{ + yyval = yyvsp[0]; +; + break;} +case 17: +#line 129 "scheme.y" +{ + yyval = yyvsp[0]; +; + break;} +case 18: +#line 132 "scheme.y" +{ + yyval = yyvsp[0]; +; + break;} +case 19: +#line 135 "scheme.y" +{ + yyval = yyvsp[0]; +; + break;} +case 20: +#line 138 "scheme.y" +{ + yyval = yyvsp[0]; +; + break;} +case 21: +#line 141 "scheme.y" +{ + yyval = yyvsp[0]; +; + break;} +case 22: +#line 144 "scheme.y" +{ + yyval = yyvsp[0]; +; + break;} +case 23: +#line 147 "scheme.y" +{ + yyval = yyvsp[0]; +; + break;} +case 24: +#line 150 "scheme.y" +{ + yyval = yyvsp[0]; +; + break;} +case 25: +#line 153 "scheme.y" +{ + yyval = yyvsp[0]; +; + break;} +case 26: +#line 156 "scheme.y" +{ + yyval = yyvsp[0]; +; + break;} +case 27: +#line 159 "scheme.y" +{ + yyval = yyvsp[0]; +; + break;} +case 28: +#line 162 "scheme.y" +{ + yyval = yyvsp[0]; +; + break;} +case 29: +#line 165 "scheme.y" +{ + yyval = yyvsp[0]; +; + break;} +case 30: +#line 168 "scheme.y" +{ + yyval = yyvsp[0]; +; + break;} +case 31: +#line 171 "scheme.y" +{ + yyval = yyvsp[0]; +; + break;} +case 32: +#line 175 "scheme.y" +{ + yyval = [Triple newTag:FORM_CALLCC Arg1:yyvsp[-1]]; +; + break;} +case 33: +#line 179 "scheme.y" +{ + yyval = [Pair newCar:yyvsp[-3] Cdr:yyvsp[-1]]; +; + break;} +case 34: +#line 183 "scheme.y" +{ + yyval = [Triple newTag:FORM_SCOND1 Arg1:yyvsp[-1]]; +; + break;} +case 35: +#line 186 "scheme.y" +{ + yyval = [Triple newTag:FORM_SCOND2 Arg1:yyvsp[-2] Arg2:yyvsp[-1]]; +; + break;} +case 36: +#line 189 "scheme.y" +{ + yyval = [Triple newTag:FORM_SCOND3 Arg1:yyvsp[-3] Arg2:yyvsp[-1]]; +; + break;} +case 37: +#line 193 "scheme.y" +{ + yyval = [Pair newCar:[NSNull null] Cdr:yyvsp[-1]]; +; + break;} +case 38: +#line 197 "scheme.y" +{ + yyval = [Pair newCar:yyvsp[0] Cdr:[NSNull null]]; +; + break;} +case 39: +#line 200 "scheme.y" +{ + yyval = [Pair newCar:yyvsp[0] Cdr:yyvsp[-1]]; +; + break;} +case 40: +#line 205 "scheme.y" +{ + yyval = [Pair newCar:yyvsp[0] Cdr:[NSNull null]]; +; + break;} +case 41: +#line 208 "scheme.y" +{ + yyval = [Pair newCar:yyvsp[0] Cdr:yyvsp[-1]]; +; + break;} +case 42: +#line 213 "scheme.y" +{ + yyval = [Triple newTag:FORM_CASE Arg1:yyvsp[-2] Arg2:yyvsp[-1]]; +; + break;} +case 43: +#line 216 "scheme.y" +{ + yyval = [Triple newTag:FORM_CASE Arg1:yyvsp[-3] + Arg2:[Pair newCar:yyvsp[-1] Cdr:yyvsp[-2]]]; +; + break;} +case 44: +#line 221 "scheme.y" +{ + yyval = [Triple newTag:FORM_COND Arg1:yyvsp[-1]]; +; + break;} +case 45: +#line 224 "scheme.y" +{ + yyval = [Triple newTag:FORM_COND Arg1:[Pair newCar:yyvsp[-1] Cdr:yyvsp[-2]]]; +; + break;} +case 46: +#line 228 "scheme.y" +{ + yyval = [Triple newTag:FORM_AND Arg1:yyvsp[-1]]; +; + break;} +case 47: +#line 231 "scheme.y" +{ + yyval = [Triple newTag:FORM_AND Arg1:[NSNull null]]; +; + break;} +case 48: +#line 235 "scheme.y" +{ + yyval = [Triple newTag:FORM_OR Arg1:yyvsp[-1]]; +; + break;} +case 49: +#line 238 "scheme.y" +{ + yyval = [Triple newTag:FORM_OR Arg1:[NSNull null]]; +; + break;} +case 50: +#line 242 "scheme.y" +{ + yyval = [Triple newTag:FORM_BEGIN Arg1:yyvsp[-1]]; +; + break;} +case 51: +#line 246 "scheme.y" +{ + yyval = [Triple newTag:FORM_SET Arg1:yyvsp[-2] Arg2:yyvsp[-1]]; +; + break;} +case 52: +#line 250 "scheme.y" +{ + yyval = [Triple newTag:FORM_APPLY Arg1:yyvsp[-2] Arg2:yyvsp[-1]]; +; + break;} +case 53: +#line 254 "scheme.y" +{ + yyval = [Triple newTag:FORM_IF1 Arg1:yyvsp[-2] Arg2:yyvsp[-1]]; +; + break;} +case 54: +#line 257 "scheme.y" +{ + yyval = [Triple newTag:FORM_IF2 Arg1:yyvsp[-3] Arg2:yyvsp[-2] Arg3:yyvsp[-1]]; +; + break;} +case 55: +#line 261 "scheme.y" +{ + yyval = [Triple newTag:FORM_LAMBDA1 Arg1:yyvsp[-2] Arg2:yyvsp[-1]]; +; + break;} +case 56: +#line 264 "scheme.y" +{ + yyval = [Triple newTag:FORM_LAMBDA2 Arg1:yyvsp[-2] Arg2:yyvsp[-1]]; +; + break;} +case 57: +#line 268 "scheme.y" +{ + yyval = [Triple newTag:FORM_QUOTE Arg1:yyvsp[0]]; +; + break;} +case 58: +#line 271 "scheme.y" +{ + yyval = [Triple newTag:FORM_QUOTE Arg1:yyvsp[-1]]; +; + break;} +case 59: +#line 276 "scheme.y" +{ + yyval = [Triple newTag:FORM_BINDING Arg1:yyvsp[-2] Arg2:yyvsp[-1]]; +; + break;} +case 60: +#line 280 "scheme.y" +{ + yyval = [Pair newCar:yyvsp[0] Cdr:[NSNull null]]; +; + break;} +case 61: +#line 283 "scheme.y" +{ + yyval = [Pair newCar:yyvsp[-1] Cdr:yyvsp[0]]; +; + break;} +case 62: +#line 287 "scheme.y" +{ + yyval = [Triple newTag:FORM_LET Arg1:yyvsp[-3] Arg2:yyvsp[-1]]; +; + break;} +case 63: +#line 291 "scheme.y" +{ + yyval = [Triple newTag:FORM_LETSTAR Arg1:yyvsp[-3] Arg2:yyvsp[-1]]; +; + break;} +case 64: +#line 295 "scheme.y" +{ + yyval = [Triple newTag:FORM_LETREC Arg1:yyvsp[-3] Arg2:yyvsp[-1]]; +; + break;} +case 65: +#line 299 "scheme.y" +{ + yyval = [NSNull null]; +; + break;} +case 66: +#line 304 "scheme.y" +{ + yyval = [Pair newCar:yyvsp[0] Cdr:[NSNull null]]; +; + break;} +case 67: +#line 307 "scheme.y" +{ + yyval = [Pair newCar:yyvsp[-2] Cdr:yyvsp[0]]; +; + break;} +case 68: +#line 310 "scheme.y" +{ + yyval = [Pair newCar:yyvsp[-1] Cdr:yyvsp[0]]; +; + break;} +case 69: +#line 315 "scheme.y" +{ + yyval = [Pair newCar:yyvsp[0] Cdr:[NSNull null]]; +; + break;} +case 70: +#line 318 "scheme.y" +{ + yyval = [Pair newCar:yyvsp[-1] Cdr:yyvsp[0]]; +; + break;} +case 71: +#line 323 "scheme.y" +{ + yyval = yyvsp[-1]; +; + break;} +case 72: +#line 328 "scheme.y" +{ + yyval = yyvsp[0]; +; + break;} +case 73: +#line 331 "scheme.y" +{ + yyval = yyvsp[0]; +; + break;} +case 74: +#line 336 "scheme.y" +{ + yyval = [Vector newFromList:yyvsp[-1]]; +; + break;} +case 75: +#line 339 "scheme.y" +{ + yyval = [Vector newFromList:(Pair *)[NSNull null]]; +; + break;} +case 76: +#line 344 "scheme.y" +{ + yyval = [Pair newCar:yyvsp[0] Cdr:[NSNull null]]; +; + break;} +case 77: +#line 347 "scheme.y" +{ + yyval = [Pair newCar:yyvsp[-2] Cdr:yyvsp[0]]; +; + break;} +case 78: +#line 350 "scheme.y" +{ + yyval = [Pair newCar:yyvsp[-1] Cdr:yyvsp[0]]; +; + break;} +case 79: +#line 355 "scheme.y" +{ + yyval = yyvsp[-1]; +; + break;} +case 80: +#line 360 "scheme.y" +{ + yyval = yyvsp[0]; +; + break;} +case 81: +#line 363 "scheme.y" +{ + yyval = yyvsp[0]; +; + break;} +} + /* the action file gets copied in in place of this dollarsign */ +#line 554 "/usr/share/bison.simple" + + yyvsp -= yylen; + yyssp -= yylen; +#ifdef YYLSP_NEEDED + yylsp -= yylen; +#endif + +#if YYDEBUG != 0 + if (yydebug) + { + short *ssp1 = yyss - 1; + fprintf (stderr, "state stack now"); + while (ssp1 != yyssp) + fprintf (stderr, " %d", *++ssp1); + fprintf (stderr, "\n"); + } +#endif + + *++yyvsp = yyval; + +#ifdef YYLSP_NEEDED + yylsp++; + if (yylen == 0) + { + yylsp->first_line = yylloc.first_line; + yylsp->first_column = yylloc.first_column; + yylsp->last_line = (yylsp-1)->last_line; + yylsp->last_column = (yylsp-1)->last_column; + yylsp->text = 0; + } + else + { + yylsp->last_line = (yylsp+yylen-1)->last_line; + yylsp->last_column = (yylsp+yylen-1)->last_column; + } +#endif + + /* Now "shift" the result of the reduction. + Determine what state that goes to, + based on the state we popped back to + and the rule number reduced by. */ + + yyn = yyr1[yyn]; + + yystate = yypgoto[yyn - YYNTBASE] + *yyssp; + if (yystate >= 0 && yystate <= YYLAST && yycheck[yystate] == *yyssp) + yystate = yytable[yystate]; + else + yystate = yydefgoto[yyn - YYNTBASE]; + + goto yynewstate; + +yyerrlab: /* here on detecting error */ + + if (! yyerrstatus) + /* If not already recovering from an error, report this error. */ + { + ++yynerrs; + +#ifdef YYERROR_VERBOSE + yyn = yypact[yystate]; + + if (yyn > YYFLAG && yyn < YYLAST) + { + int size = 0; + char *msg; + int x, count; + + count = 0; + /* Start X at -yyn if nec to avoid negative indexes in yycheck. */ + for (x = (yyn < 0 ? -yyn : 0); + x < (sizeof(yytname) / sizeof(char *)); x++) + if (yycheck[x + yyn] == x) + size += strlen(yytname[x]) + 15, count++; + msg = (char *) malloc(size + 15); + if (msg != 0) + { + strcpy(msg, "parse error"); + + if (count < 5) + { + count = 0; + for (x = (yyn < 0 ? -yyn : 0); + x < (sizeof(yytname) / sizeof(char *)); x++) + if (yycheck[x + yyn] == x) + { + strcat(msg, count == 0 ? ", expecting `" : " or `"); + strcat(msg, yytname[x]); + strcat(msg, "'"); + count++; + } + } + yyerror(msg); + free(msg); + } + else + yyerror ("parse error; also virtual memory exceeded"); + } + else +#endif /* YYERROR_VERBOSE */ + yyerror("parse error"); + } + + goto yyerrlab1; +yyerrlab1: /* here on error raised explicitly by an action */ + + if (yyerrstatus == 3) + { + /* if just tried and failed to reuse lookahead token after an error, discard it. */ + + /* return failure if at end of input */ + if (yychar == YYEOF) + YYABORT; + +#if YYDEBUG != 0 + if (yydebug) + fprintf(stderr, "Discarding token %d (%s).\n", yychar, yytname[yychar1]); +#endif + + yychar = YYEMPTY; + } + + /* Else will try to reuse lookahead token + after shifting the error token. */ + + yyerrstatus = 3; /* Each real token shifted decrements this */ + + goto yyerrhandle; + +yyerrdefault: /* current state does not do anything special for the error token. */ + +#if 0 + /* This is wrong; only states that explicitly want error tokens + should shift them. */ + yyn = yydefact[yystate]; /* If its default is to accept any token, ok. Otherwise pop it.*/ + if (yyn) goto yydefault; +#endif + +yyerrpop: /* pop the current state because it cannot handle the error token */ + + if (yyssp == yyss) YYABORT; + yyvsp--; + yystate = *--yyssp; +#ifdef YYLSP_NEEDED + yylsp--; +#endif + +#if YYDEBUG != 0 + if (yydebug) + { + short *ssp1 = yyss - 1; + fprintf (stderr, "Error: state stack now"); + while (ssp1 != yyssp) + fprintf (stderr, " %d", *++ssp1); + fprintf (stderr, "\n"); + } +#endif + +yyerrhandle: + + yyn = yypact[yystate]; + if (yyn == YYFLAG) + goto yyerrdefault; + + yyn += YYTERROR; + if (yyn < 0 || yyn > YYLAST || yycheck[yyn] != YYTERROR) + goto yyerrdefault; + + yyn = yytable[yyn]; + if (yyn < 0) + { + if (yyn == YYFLAG) + goto yyerrpop; + yyn = -yyn; + goto yyreduce; + } + else if (yyn == 0) + goto yyerrpop; + + if (yyn == YYFINAL) + YYACCEPT; + +#if YYDEBUG != 0 + if (yydebug) + fprintf(stderr, "Shifting error token, "); +#endif + + *++yyvsp = yylval; +#ifdef YYLSP_NEEDED + *++yylsp = yylloc; +#endif + + yystate = yyn; + goto yynewstate; + + yyacceptlab: + /* YYACCEPT comes here. */ +#ifndef YYSTACK_USE_ALLOCA + if (yyfree_stacks) + { + free (yyss); + free (yyvs); +#ifdef YYLSP_NEEDED + free (yyls); +#endif + } +#endif + return 0; + + yyabortlab: + /* YYABORT comes here. */ +#ifndef YYSTACK_USE_ALLOCA + if (yyfree_stacks) + { + free (yyss); + free (yyvs); +#ifdef YYLSP_NEEDED + free (yyls); +#endif + } +#endif + return 1; +} +#line 368 "scheme.y" + + diff --git a/scheme.tab.m.h b/scheme.tab.m.h new file mode 100644 index 0000000..4deecf9 --- /dev/null +++ b/scheme.tab.m.h @@ -0,0 +1,34 @@ +#ifndef YYSTYPE +#define YYSTYPE int +#endif +#define LPAREN 257 +#define LVECTPAREN 258 +#define RPAREN 259 +#define DEFINE 260 +#define SET 261 +#define LAMBDA 262 +#define BEGINTOK 263 +#define AND 264 +#define OR 265 +#define CASE 266 +#define COND 267 +#define ELSE 268 +#define ARROW 269 +#define CALLCC 270 +#define APPLY 271 +#define IF 272 +#define LET 273 +#define LETSTAR 274 +#define LETREC 275 +#define DOT 276 +#define INTEGER 277 +#define CHAR 278 +#define BOOLEAN 279 +#define DOUBLE 280 +#define SYMBOL 281 +#define STRING 282 +#define QUOTECHAR 283 +#define QUOTE 284 + + +extern YYSTYPE yylval; diff --git a/scheme.y b/scheme.y new file mode 100644 index 0000000..27a5f9b --- /dev/null +++ b/scheme.y @@ -0,0 +1,369 @@ +%{ +#import "SchemeTypes.h" + +#define YYSTYPE id + +YYSTYPE yyresult; +int yyinputitem; + +extern int yysofar; +extern NSMutableArray *positions; +%} + +%token LPAREN +%token LVECTPAREN +%token RPAREN + +%token DEFINE +%token SET +%token LAMBDA + +%token BEGINTOK + +%token AND +%token OR + +%token CASE +%token COND +%token ELSE +%token ARROW + +%token CALLCC + +%token APPLY + +%token IF + +%token LET +%token LETSTAR +%token LETREC + +%token DOT + +%token INTEGER +%token CHAR +%token BOOLEAN +%token DOUBLE +%token SYMBOL +%token STRING + +%token QUOTECHAR +%token QUOTE + +%% + +top: /* empty */ { + yyresult = + $$ = [NSNull null]; +} +| topitem top { + yyresult = + $$ = [Triple newTag:FORM_TOP Arg1:$1 Arg2:$2]; + yyinputitem++; +} +; + +topitem: LPAREN DEFINE SYMBOL form RPAREN { + NSValue *entry = + [NSValue valueWithRange:NSMakeRange(yysofar, 0)]; + + $$ = [Triple newTag:FORM_DEFINE1 Arg1:$3 Arg2:$4]; + + [positions addObject:entry]; +} +| LPAREN DEFINE nonemptysymlist sequence RPAREN { + NSValue *entry = + [NSValue valueWithRange:NSMakeRange(yysofar, 0)]; + + $$ = [Triple newTag:FORM_DEFINE2 Arg1:$3 Arg2:$4]; + + [positions addObject:entry]; +} +| form { + NSValue *entry = + [NSValue valueWithRange:NSMakeRange(yysofar, 0)]; + + $$ = $1; + + [positions addObject:entry]; +} +; + +sequence: form { + $$ = [Pair newCar:$1 Cdr:[NSNull null]]; +} +| form sequence { + $$ = [Pair newCar:$1 Cdr:$2]; +} +; + +revsequence: form { + $$ = [Pair newCar:$1 Cdr:[NSNull null]]; +} +| revsequence form { + $$ = [Pair newCar:$2 Cdr:$1]; +} +; + +form: INTEGER { + $$ = $1; +} +| CHAR { + $$ = $1; +} +| BOOLEAN { + $$ = $1; +} +| DOUBLE { + $$ = $1; +} +| SYMBOL { + $$ = $1; +} +| STRING { + $$ = $1; +} +| list { + $$ = $1; +} +| vector { + $$ = $1; +} +| lambda { + $$ = $1; +} +| if { + $$ = $1; +} +| let { + $$ = $1; +} +| letstar { + $$ = $1; +} +| letrec { + $$ = $1; +} +| quote { + $$ = $1; +} +| apply { + $$ = $1; +} +| set { + $$ = $1; +} +| begin { + $$ = $1; +} +| and { + $$ = $1; +} +| or { + $$ = $1; +} +| case { + $$ = $1; +} +| cond { + $$ = $1; +} +| callcc { + $$ = $1; +} + +callcc: LPAREN CALLCC form RPAREN { + $$ = [Triple newTag:FORM_CALLCC Arg1:$3]; +} + +singlecase: LPAREN LPAREN sequence RPAREN sequence RPAREN { + $$ = [Pair newCar:$3 Cdr:$5]; +} + +singlecond: LPAREN form RPAREN { + $$ = [Triple newTag:FORM_SCOND1 Arg1:$2]; +} +| LPAREN form sequence RPAREN { + $$ = [Triple newTag:FORM_SCOND2 Arg1:$2 Arg2:$3]; +} +| LPAREN form ARROW form RPAREN { + $$ = [Triple newTag:FORM_SCOND3 Arg1:$2 Arg2:$4]; +} + +elsecasecond: LPAREN ELSE sequence RPAREN { + $$ = [Pair newCar:[NSNull null] Cdr:$3]; +} + +cases: singlecase { + $$ = [Pair newCar:$1 Cdr:[NSNull null]]; +} +| cases singlecase { + $$ = [Pair newCar:$2 Cdr:$1]; +} +; + +conditions: singlecond { + $$ = [Pair newCar:$1 Cdr:[NSNull null]]; +} +| conditions singlecond { + $$ = [Pair newCar:$2 Cdr:$1]; +} +; + +case: LPAREN CASE form cases RPAREN { + $$ = [Triple newTag:FORM_CASE Arg1:$3 Arg2:$4]; +} +| LPAREN CASE form cases elsecasecond RPAREN { + $$ = [Triple newTag:FORM_CASE Arg1:$3 + Arg2:[Pair newCar:$5 Cdr:$4]]; +} + +cond: LPAREN COND conditions RPAREN { + $$ = [Triple newTag:FORM_COND Arg1:$3]; +} +| LPAREN COND conditions elsecasecond RPAREN { + $$ = [Triple newTag:FORM_COND Arg1:[Pair newCar:$4 Cdr:$3]]; +} + +and: LPAREN AND revsequence RPAREN { + $$ = [Triple newTag:FORM_AND Arg1:$3]; +} +| LPAREN AND RPAREN { + $$ = [Triple newTag:FORM_AND Arg1:[NSNull null]]; +} + +or: LPAREN OR revsequence RPAREN { + $$ = [Triple newTag:FORM_OR Arg1:$3]; +} +| LPAREN OR RPAREN { + $$ = [Triple newTag:FORM_OR Arg1:[NSNull null]]; +} + +begin: LPAREN BEGINTOK sequence RPAREN { + $$ = [Triple newTag:FORM_BEGIN Arg1:$3]; +} + +set: LPAREN SET SYMBOL form RPAREN { + $$ = [Triple newTag:FORM_SET Arg1:$3 Arg2:$4]; +} + +apply: LPAREN APPLY form form RPAREN { + $$ = [Triple newTag:FORM_APPLY Arg1:$3 Arg2:$4]; +} + +if: LPAREN IF form form RPAREN { + $$ = [Triple newTag:FORM_IF1 Arg1:$3 Arg2:$4]; +} +| LPAREN IF form form form RPAREN { + $$ = [Triple newTag:FORM_IF2 Arg1:$3 Arg2:$4 Arg3:$5]; +} + +lambda: LPAREN LAMBDA SYMBOL sequence RPAREN { + $$ = [Triple newTag:FORM_LAMBDA1 Arg1:$3 Arg2:$4]; +} +| LPAREN LAMBDA symlist sequence RPAREN { + $$ = [Triple newTag:FORM_LAMBDA2 Arg1:$3 Arg2:$4]; +} + +quote: QUOTECHAR form { + $$ = [Triple newTag:FORM_QUOTE Arg1:$2]; +} +| LPAREN QUOTE form RPAREN { + $$ = [Triple newTag:FORM_QUOTE Arg1:$3]; +} + + +singlebinding: LPAREN SYMBOL form RPAREN { + $$ = [Triple newTag:FORM_BINDING Arg1:$2 Arg2:$3]; +} + +listofbindings: singlebinding { + $$ = [Pair newCar:$1 Cdr:[NSNull null]]; +} +| singlebinding listofbindings { + $$ = [Pair newCar:$1 Cdr:$2]; +} + +let: LPAREN LET LPAREN listofbindings RPAREN sequence RPAREN { + $$ = [Triple newTag:FORM_LET Arg1:$4 Arg2:$6]; +} + +letstar: LPAREN LETSTAR LPAREN listofbindings RPAREN sequence RPAREN { + $$ = [Triple newTag:FORM_LETSTAR Arg1:$4 Arg2:$6]; +} + +letrec: LPAREN LETREC LPAREN listofbindings RPAREN sequence RPAREN { + $$ = [Triple newTag:FORM_LETREC Arg1:$4 Arg2:$6]; +} + +emptylist: LPAREN RPAREN { + $$ = [NSNull null]; +} +; + +nonemptylistdata: form { + $$ = [Pair newCar:$1 Cdr:[NSNull null]]; +} +| form DOT form { + $$ = [Pair newCar:$1 Cdr:$3]; +} +| form nonemptylistdata { + $$ = [Pair newCar:$1 Cdr:$2]; +} +; + +nonemptyvectdata: form { + $$ = [Pair newCar:$1 Cdr:[NSNull null]]; +} +| form nonemptyvectdata { + $$ = [Pair newCar:$1 Cdr:$2]; +} +; + +nonemptylist: LPAREN nonemptylistdata RPAREN { + $$ = $2; +} +; + +list: nonemptylist { + $$ = $1; +} +| emptylist { + $$ = $1; +} +; + +vector: LVECTPAREN nonemptyvectdata RPAREN { + $$ = [Vector newFromList:$2]; +} +| LVECTPAREN RPAREN { + $$ = [Vector newFromList:(Pair *)[NSNull null]]; +} +; + +nonemptysymlistdata: SYMBOL { + $$ = [Pair newCar:$1 Cdr:[NSNull null]]; +} +| SYMBOL DOT SYMBOL { + $$ = [Pair newCar:$1 Cdr:$3]; +} +| SYMBOL nonemptysymlistdata { + $$ = [Pair newCar:$1 Cdr:$2]; +} +; + +nonemptysymlist: LPAREN nonemptysymlistdata RPAREN { + $$ = $2; +} +; + +symlist: nonemptysymlist { + $$ = $1; +} +| emptylist { + $$ = $1; +} +; + +%% + diff --git a/scratch/allocate.scm b/scratch/allocate.scm new file mode 100644 index 0000000..c63d57c --- /dev/null +++ b/scratch/allocate.scm @@ -0,0 +1,18 @@ + +(define l1 (list-n 500)) + +(define access-list + (lambda (l n) + (if (zero? n) l + (access-list (cdr l) (- n 1))))) +;; (set-cdr! (access-list l1 250) '()) + +(define l2 (list-n 500)) + +;; (list-n 100) + +(list-n 1000) + +;; (list-n 200) + + diff --git a/scratch/allocate.scm~ b/scratch/allocate.scm~ new file mode 100644 index 0000000..af6d87f --- /dev/null +++ b/scratch/allocate.scm~ @@ -0,0 +1,18 @@ + +(define l1 (list-n 500)) + +(define access-list + (lambda (l n) + (if (zero? n) l + (access-list (cdr l) (- n 1))))) +(set-cdr! (access-list l1 250) '()) + +(define l2 (list-n 500)) + +;; (list-n 100) + +(list-n 1000) + +;; (list-n 200) + + diff --git a/test/classes.m b/test/classes.m new file mode 100644 index 0000000..992b1b1 --- /dev/null +++ b/test/classes.m @@ -0,0 +1,12 @@ +#import +#import + +int main(int argc, char **argv) +{ + void *state; + Class cl; + + while((cl = objc_next_class(&state))){ + NSLog(@"%@\n", NSStringFromClass(cl)); + } +} diff --git a/test/classes.m~ b/test/classes.m~ new file mode 100644 index 0000000..4888364 --- /dev/null +++ b/test/classes.m~ @@ -0,0 +1,15 @@ +#import +#import + +int main(int argc, char **argv) +{ + NSMutableSet *strset = [NSMutableSet setWithCapacity:1]; + NSString + *str1 = [NSString stringWithCString:"abcd"], + *str2 = [NSString stringWithCString:"abcd"]; + + [strset addObject:str1]; + + NSLog(@"%@ %@ %@\n", str1, str2, + [strset member:@"abcd"]); +} diff --git a/test/commands.txt b/test/commands.txt new file mode 100644 index 0000000..2af0f27 --- /dev/null +++ b/test/commands.txt @@ -0,0 +1 @@ +flex scheme.flex diff --git a/test/compileit b/test/compileit new file mode 100755 index 0000000..3cbd9c4 --- /dev/null +++ b/test/compileit @@ -0,0 +1,26 @@ +gcc classes.m \ +-DGNUSTEP -DGNUSTEP_BASE_LIBRARY=1 -DGNU_GUI_LIBRARY=1 \ +-DGNU_RUNTIME=1 -DGNUSTEP_BASE_LIBRARY=1 -fPIC -g -DGSWARN \ +-DGSDIAGNOSE -O2 -fgnu-runtime -I. -fgnu-runtime \ +-I/usr/GNUstep/System/Headers \ +-I/home/gnustep/GNUstep/Headers/gnustep \ +-I/usr/GNUstep/Local/Headers/gnustep \ +-I/usr/GNUstep/Network/Headers/gnustep \ +-I/usr/GNUstep/System/Headers/gnustep \ +-I/home/gnustep/GNUstep/Headers/ix86/linux-gnu \ +-I/home/gnustep/GNUstep/Headers \ +-I/usr/GNUstep/Local/Headers/ix86/linux-gnu \ +-I/usr/GNUstep/Local/Headers \ +-I/usr/GNUstep/Network/Headers/ix86/linux-gnu \ +-I/usr/GNUstep/Network/Headers \ +-I/usr/GNUstep/System/Headers/ix86/linux-gnu \ +-I/usr/GNUstep/System/Headers \ +-L/home/gnustep/GNUstep/Libraries/ix86/linux-gnu/gnu-gnu-gnu \ +-L/home/gnustep/GNUstep/Libraries/ix86/linux-gnu \ +-L/usr/GNUstep/Local/Libraries/ix86/linux-gnu/gnu-gnu-gnu \ +-L/usr/GNUstep/Local/Libraries/ix86/linux-gnu \ +-L/usr/GNUstep/Network/Libraries/ix86/linux-gnu/gnu-gnu-gnu \ +-L/usr/GNUstep/Network/Libraries/ix86/linux-gnu \ +-L/usr/GNUstep/System/Libraries/ix86/linux-gnu/gnu-gnu-gnu \ +-L/usr/GNUstep/System/Libraries/ix86/linux-gnu -lgnustep-gui \ +-lgnustep-base -lobjc -lpthread -lz -lgmp -ldl -lm -lfl diff --git a/test/compileit~ b/test/compileit~ new file mode 100755 index 0000000..daff9d1 --- /dev/null +++ b/test/compileit~ @@ -0,0 +1,26 @@ +gcc testscheme.m SchemeTypes.m scheme.tab.m scheme.lex.m \ +-DGNUSTEP -DGNUSTEP_BASE_LIBRARY=1 -DGNU_GUI_LIBRARY=1 \ +-DGNU_RUNTIME=1 -DGNUSTEP_BASE_LIBRARY=1 -fPIC -g -DGSWARN \ +-DGSDIAGNOSE -O2 -fgnu-runtime -I. -fgnu-runtime \ +-I/usr/GNUstep/System/Headers \ +-I/home/gnustep/GNUstep/Headers/gnustep \ +-I/usr/GNUstep/Local/Headers/gnustep \ +-I/usr/GNUstep/Network/Headers/gnustep \ +-I/usr/GNUstep/System/Headers/gnustep \ +-I/home/gnustep/GNUstep/Headers/ix86/linux-gnu \ +-I/home/gnustep/GNUstep/Headers \ +-I/usr/GNUstep/Local/Headers/ix86/linux-gnu \ +-I/usr/GNUstep/Local/Headers \ +-I/usr/GNUstep/Network/Headers/ix86/linux-gnu \ +-I/usr/GNUstep/Network/Headers \ +-I/usr/GNUstep/System/Headers/ix86/linux-gnu \ +-I/usr/GNUstep/System/Headers \ +-L/home/gnustep/GNUstep/Libraries/ix86/linux-gnu/gnu-gnu-gnu \ +-L/home/gnustep/GNUstep/Libraries/ix86/linux-gnu \ +-L/usr/GNUstep/Local/Libraries/ix86/linux-gnu/gnu-gnu-gnu \ +-L/usr/GNUstep/Local/Libraries/ix86/linux-gnu \ +-L/usr/GNUstep/Network/Libraries/ix86/linux-gnu/gnu-gnu-gnu \ +-L/usr/GNUstep/Network/Libraries/ix86/linux-gnu \ +-L/usr/GNUstep/System/Libraries/ix86/linux-gnu/gnu-gnu-gnu \ +-L/usr/GNUstep/System/Libraries/ix86/linux-gnu -lgnustep-gui \ +-lgnustep-base -lobjc -lpthread -lz -lgmp -ldl -lm -lfl diff --git a/test/sscanf b/test/sscanf new file mode 100755 index 0000000000000000000000000000000000000000..880cc03d9323af0863bab6273e2d3e9cc18a500c GIT binary patch literal 13739 zcmdU0eT-ejb)WSviAxQ!9g~EQBwN7Xb=PnAee8NaYJxx3%ffnX>@_W=1ERJDU6QOQC1 z1I7LQ&dl69Z@pCHpGuw8?EL1;nVECWocXx-&UQu~~neSSfLwc-7 zm*iBp`iNSiKBI0#suas|E$|?o0cN}ku?w*i@e(7-7(Wio$TGGa_l7cscmfp}Szj&J z%`zaVhwhKHjyIu^V|tTh>WfHi=q7+Y3bezZsyBjaR8q5k6e`av?9Y3ppqj4)kNC(I{f0jq zgpuFyN{#%S?*-LTO@(10Uo9zbV!Ibc#h~gnL%#@aHVR6<5qWd@pbE-jwLNcku2waC zo*JK=*tFTpq|&KujQc6#lK8I^h}Pys+nPnHwNuE8IDe8qYlBWda zPceT=@|2|9&HQo6Q=;-3=8qzeRHc9Z`GfyH|Mt5(rgxU>7~}G-82EedE1!9?Yw7t{ zz;x;0dkf@04xczQe=90KbtYPJ`5c5l_})xuhEteVs(HsdD^HvRI>FY>y+v}y$;KmR54hEd=eL!Vw< z@zrcC>PE^XCk}_vo6XR?jLQ%?^^@%ScOc<6WdLBMo4+(xt@UY+?3mz5xzTgdlS7L&-WXHw46Z|=$-y!%;!P9~_ z3f?1lli+#5n+5-g;4Okr2_6&tUBO!g|5Wg};9m&7OYpVWqgrZ0@GXL;1Q!I~EBH~t zI|cu#;9Y`W70eTcQvV=WpM5R}hGQUfV8*r7?+LzM@B@OgfKogyx_9nM+H{| zKP&iQ!QT?x5d3|?O~G#q-Yd8Rdv!}45PXy1M+6TG{zJj{3T_Ghg5Y_|vDEEeaM zS%DrDtjGE}!Fo(z6|Bc%42yV6{l4@zFIe05xL_?r^IGy$B=fA`Nbm*0+E!P8j69DE z{Tabe3qB|KuweePdb!xn*%i>~yztBNtbQf*U%u+T>XWq)- z(!V0@vs9@DHoul2rM@9}Tyj4Ye7E2w*ch$+S;2Zvl?2}}JSPM{DELQ$9}>KB73<~& z-z`|6de6as_K8G>W7wQqnnhiW(_%}VG`U0<60BY+;n8c|3Bl`y|J#Cx1ph#=UhCcw zJR)@dv+Z1Uy;9u@|4b+%<({j8Y7nIgs;?O~`ocz`ubwaL$-=^IYlUw>``6#e1 zlggxWeTA^ur)CR z&7bKR?H^5N){m-6tvcInTg!g9)|%BYn63K7xL(ew7t7G!4=J*-5Vo%?Di8b`mD{8p zOe&_GUK2RlpY-k^qqMYjg*5AvMw5o9iet~Vw!(6)5yh4m($$B0M%QIC>j#HM`5&rl zt}A*Q*6hO^j=_O}>;O2mY2y(~_Zx}&(Pla`q=zkTDdDrOkY;0<0W?*r)bhqn%($a0 zhf-CnHD@Zm_Ml|Yhgc+Lam$mzO=rkJC#?AUW0lhwz;LMH=PM)PiM{>3+01A#m!CEH zY=(rSq9c|a!a*aKZQJeNj>!6+Q4!GcTp_5jeHzBslJ2bqMXe+3OxcEeR4UaMR11}6 z(dR3T!n*Ll+)S+!rpg~~Di-<*wQ4Dt1wUE}4}?X(9`?;vn|4(h;WQ=c8t0Ar%$-3PrzUnCF79z{X;lEFaLL56c7I&CK)#xuL;z zAzmlwH#L2k)bKzm8>@`B4QLHLhj=~V(Km*;guphr9=vU6dd8h{hMG=mvbZm}bG>jR zaKn(~*6T*D7cP`E!Eq5*I1Z=-n)Tskz9=2$Kp}lS=?)dH0O}yAXm-f(V(>x59AJMA z9b-+phzD|d(D3Vl9(^HOuMoo2wP| zsA8O`m|?EM_4ZhH>SgG)Qpr-aR?=a`AyX$Kb3K+LqX$rIAI6S^F7*%!y-^9~Y};Bz zu_Vc{#WGq;(LHJ0QL+@q}?3KW))_5F|sWqbg>xMM*t9x-#UYuoP61-Ub{$wncHh0qxD& zRjRdwuDx04aNC4VJHR7Fipaz3)=J)5Za`Z?^o{W5wXICs!t@i>qqvge+aboS;#ZB8 z24XkBYA$PhRK{jl4CCFQt_gbSHyLLKu$#!DJ4IM18or*8;z zF})Gg8bNfx-GVU%OmAK(A4YUH)Et(Im_vBa95q8$$a2nLiw3P8RE1B^B)fCR?G*j6 zz=Pzl>;uDG_}3x>i|!BGnb3TrS%^j;xfLQG!JMIp05gZ#LB1Z3@`W-b@m@%h6(H0e zStCL}GA*TtJ&i=(7YSB!nm znj8h~bH-RZF^-YL)n2<3k2iFuc0Ct3lb&fA?MIl``*@%hozrP9yt3M=eKu^fU2 z_HRO2G=*%MtBYX)WkxtKG|Aa3%d?kd8pZm`B^DddxL2yz^odD#uY2c;20G7h7-`$I z*$2=&CJ&m>$2i@D+1f?0HCgUBArAMpkpXE0{IWiCGtrH}AEXh-wzF6j_nK!fLOeQY zLN~Y7^|X=idE=Y6Pu=Hjzh|Vs*Jh@+lQxoe2wOIdWSs1_v27#SI6t;+$MpT)#MF-6 z(<8Z z-oA5WC@Gwp9@{yE2FG^pM8R|^yNc6pNpB z687?l_Tj`tf&o~|6mz2_%X-YoH(Loi&rM*%gb;QtpbOZ2Y$eB0jE#y&E$u? z(kBFM73^FZl3CyK>;cw~E^p zx}q3YRwH|6l$DO#uRI^xO`_DO&3U>Sj&4xfY7y1i$nl0uHx<#KlHG*k0cHU#5pTn; z)!gIZ9Iks*eVk7wltT9(fq%^bGqg0VB4&m2VYhIA&t`}q-Ulw1WC z=Sn2h!eoYqMn|dLfZ4fWc=P@&D-R?6_%EWw@6WP)JTa^PxV)c>D>yIQbcuPhhVjwI zAU>M6-G3Sx*Da~>&6`KM*WgB3Pq%)3*^Mt7>HchbpnJ`(=B}|Ge2)5m#e(m%68I&s zKb`7NBmKXisTAIBNBJ3~QA4MA*49X7Rb8d3wa8Cx+%&N+%Fn7)IUnM!bn!qH6?Gal zR0^-RQ+x4PgE`uk@le+AE9BRpUWrtSE22sX-%uhNq#OU zs8k`UHA3Wdg3CM*dnN=${$VDI9(kN-(Jfqj4ySu9zqam&`hO$1I1Eb=<*p@Cd{&GD z%NY2T6rb~jPwqsbpc{D`x(wh@;%bBN@ea`%@bUhPEoaKeuZO%x#D00Vs0hB}z^n@> zJoxmgcoU)%k$k+1)CF(?*aq@4@M|jX5s{B~h+YQ3r_Z=w(ix`_dGCmrcaPo#=m&QD zMOGCM@o8V`@b1z@@Xj_^ zkAh(NCh=W#5`1;bgp_=YEkw)5d$wo5cgh+AWwadwzuH?q-tDSG(VL`1|Fiw_i$3{i zm&4#Y48H3$i~P5I$B-i*y3==S!Dss-qviV=u;t@Dyw|{I%Ur&fkfBZ3p4`O+-}iu# zNMIe>@0*CWJ>HmWp%Upf*tTB-!Sa0>d|&Az3?kcOmIm{=)ATz*9)E3-em6#r-|ueTu23)zo>;bz1w$kYEhGnd2v??JwTa{GIQ2avzj%%7F`l|&wS z-VA@;)PE9rJHJ*!oZVZ^iSk%=qBK)kq1TGiCS>g3E$@`&MzK>6I_$NoGuHED2$q=5-4^20K)UO z;7yn}Ik9Wn^UPJ12w%{0C@I#w*-C8&Pm*%R^zzO9ppM<;ZQZ$X+nBd$YtqhH}wt5@D9KSXIGQ(n|w^rt9oj5uRA$cY2D{&k5m zze3?n8S{G+Qrt>B&KqX^Lm0P^zk~_Up!=hkq?|uk(P}0%XyMBff;T?7eG^__Zr{3f e*Vwc-y>Zjz7z~ED3JV?^saYZe-dwo9jrkuyWt_zT literal 0 HcmV?d00001 diff --git a/test/sscanf.c b/test/sscanf.c new file mode 100644 index 0000000..8e2bda3 --- /dev/null +++ b/test/sscanf.c @@ -0,0 +1,13 @@ +#include +#include + +int main(int argc, char **argv) +{ + char buf[128]; + + while(gets(buf)!=NULL){ + double val; + sscanf(buf, "%le", &val); + printf("got %le\n", val); + } +} diff --git a/test/test.m b/test/test.m new file mode 100644 index 0000000..4888364 --- /dev/null +++ b/test/test.m @@ -0,0 +1,15 @@ +#import +#import + +int main(int argc, char **argv) +{ + NSMutableSet *strset = [NSMutableSet setWithCapacity:1]; + NSString + *str1 = [NSString stringWithCString:"abcd"], + *str2 = [NSString stringWithCString:"abcd"]; + + [strset addObject:str1]; + + NSLog(@"%@ %@ %@\n", str1, str2, + [strset member:@"abcd"]); +} diff --git a/test/test.m~ b/test/test.m~ new file mode 100644 index 0000000..d9fa4e2 --- /dev/null +++ b/test/test.m~ @@ -0,0 +1,15 @@ +#import +#import + +int main(int argc, char **argv) +{ + NSMutableSet *strset = [NSMutableSet setWithCapacity:1]; + NSString + *str1 = [NSString stringWithCString:"abcd"], + *str2 = [NSString stringWithCString:"abcd"]; + + [strset addObject:str1]; + + NSLog(@"%@ %@ %@\n", str1, str2, + [strset member:str2]); +} diff --git a/test/testschemeparser.c~ b/test/testschemeparser.c~ new file mode 100644 index 0000000..f757dbf --- /dev/null +++ b/test/testschemeparser.c~ @@ -0,0 +1,18 @@ + +/* + test scheme parser + by marko riedel, mriedel@neuearbeit.de +*/ + +#include +#include + +#include "schemenode.h" + +extern scmnodeptr yylval; + +int main(int argc, char **argv) +{ + yyparse(); + print(yylval); +} diff --git a/testscheme.m b/testscheme.m new file mode 100644 index 0000000..39ff25f --- /dev/null +++ b/testscheme.m @@ -0,0 +1,186 @@ + +/* + test scheme parser + by marko riedel, mriedel@neuearbeit.de +*/ + +#include +#include +#include + +#import "SchemeTypes.h" +#import "VScheme.h" + +id yyresult; + + +static char *forms[] = { + "top", + "define1", "define2", "set", + "lambda1", "lambda2", + "quote", "binding", + "let", "let*", "letrec", + "if1", "if2", + "and", "or", + "begin", "apply", + "case", "scond1", "scond2", "scond3", "cond", + "callcc" +}; + +void print_tree(id item, int indent) +{ + int pos; + + for(pos=0; pos\n"); + } + else if(c=='\t'){ + printf("CHAR: <\\tab>\n"); + } + else if(c==' '){ + printf("CHAR: <\\space>\n"); + } + else{ + printf("CHAR: <%c>\n", c); + } + } + else if([item isKindOfClass:[Int class]]){ + printf("INT: %ld\n", [item intVal]); + } + else if([item isKindOfClass:[Double class]]){ + printf("DOUBLE: %le\n", [item doubleVal]); + } + else if([item isKindOfClass:[Symbol class]]){ + printf("SYMBOL: <%s>\n", [[item symVal] cString]); + } + else if([item isKindOfClass:[String class]]){ + printf("STRING: <%s>\n", [[item strVal] cString]); + } + else if([item isKindOfClass:[Closure class]]){ + printf("CLOSURE %s\n", + [[VScheme valToString:[item args]] cString]); + } + else if([item isKindOfClass:[Primitive class]]){ + printf("PRIMITIVE\n"); + } + else if([item isKindOfClass:[Thunk class]]){ + printf("THUNK %d %d %d\n", [item argp], [item envp], [item codep]); + } + else if([item isKindOfClass:[Pair class]]){ + printf("PAIR %s\n", [[VScheme valToString:item] cString]); + } + else if([item isKindOfClass:[NSMutableArray class]]){ + printf("CODES: %u\n", [item count]); + } + else{ + printf("FORM %s\n", forms[[item tag]]); + if([item arg1]!=nil){ + print_tree([item arg1], indent+1); + } + if([item arg2]!=nil){ + print_tree([item arg2], indent+1); + } + if([item arg3]!=nil){ + print_tree([item arg3], indent+1); + } + } +} + +void print_scheme_item(id item) +{ + print_tree(item, 0); +} + + + +yyerror(char *s) /* Called by yyparse on error */ +{ + printf ("%s\n", s); +} + +int main(int argc, char **argv) +{ + NSAutoreleasePool *pool = [NSAutoreleasePool new]; + NSApplication *theApp; + VScheme *vm; + id forms, item; + + GSDebugAllocationActive(YES); + + vm = [[VScheme alloc] init]; + + theApp = [NSApplication sharedApplication]; + // [theApp run]; + + setlocale(LC_NUMERIC, "C"); + printf("locale %s\n", setlocale(LC_NUMERIC, NULL)); + + yyparse(); + // print_scheme_item(yyresult); + [vm setSource:yyresult]; + + forms = yyresult; + while(forms!=[NSNull null]){ + NSMutableArray *codes = [NSMutableArray arrayWithCapacity:1]; + BOOL err = [vm compile:[forms arg1] output:codes]; + print_scheme_item([forms arg1]); + if(err==NO){ + [VScheme printCodes:codes]; + [vm clearOutput]; + if([vm run:codes]==YES){ + id stack = [vm argStack], envs = [vm envStack], + code = [vm codeStack]; + int count = 0; + while(count<[stack count]){ + printf("stack %d: ", count); + print_scheme_item([stack objectAtIndex:count++]); + } + + printf("code: %d (%d) pc: %d args: %d (%d) envs: %d (%d):", + [code count], [vm maxcode], + [vm maxpc], + [stack count], [vm maxarg], + [envs count], [vm maxenv]); + + count=0; + while(count<[envs count]){ + id env = [envs objectAtIndex:count++]; + printf("(%d)", [env chainLength]); + } + putchar('\n'); + + printf("OUTPUT\n%s\n", [[vm output] cString]); + + [vm resetStacks]; + } + else{ + printf("run time error: %s\n", [[vm errmsg] cString]); + } + } + else{ + printf("compilation failed: %s\n", [[vm errmsg] cString]); + } + + + [codes removeAllObjects]; + + forms = [forms arg2]; + } + + // [pool release]; + + return 0; +}