conservatory
/
gscheme
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

GScheme-20050303.tar

This commit is contained in:
Lassi Kortela 2022-08-05 12:28:41 +03:00
parent 81e8afedce
commit b87ebad788
57 changed files with 4430 additions and 3751 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

171
#EnvWindow.m# Normal file
View File

@ -0,0 +1,171 @@
#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 contentRect = {{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];
names = NSZoneMalloc([self zone], length*sizeof(id));
values = NSZoneMalloc([self zone], length*sizeof(id));
NSAutoreleasePool *pool = [NSAutoreleasePool new];
for(lind=length-1, layer = env; lind>=0; lind--){
NSMapTable *data = [layer data];
names[lind] = [NSMutableArray arrayWithArray:[data allKeys]];
[names[lind] sortUsingSelector:@selector(compare:)];
[names[lind] retain];
values[lind] = [NSMutableArray arrayWithCapacity:[names[lind] count]];
[values[lind] retain];
NSMapEnumerator en = [names[lind] objectEnumerator];
id key, val;
while(NSNextMapEnumeratorPair(&enumerator, (void**)&key, (void**)&val)){
id obj = NSMapGet(data, key);
[values[lind] addObject:[VScheme valToString:obj]];
}
layer = [layer parent];
}
[pool release];
[self initWithContentRect:winRect
styleMask:style
backing:NSBackingStoreRetained
defer:NO];
[self setMinSize:NSMakeSize(WIDTH, HEIGHT)];
[self setReleasedWhenClosed:YES];
NSTableColumn *nameColumn, *valueColumn;
nameColumn =
[(NSTableColumn *)[NSTableColumn alloc]
initWithIdentifier: @"Name"];
[nameColumn setEditable: NO];
[[nameColumn headerCell] setStringValue: @"Name"];
[nameColumn setMinWidth:WIDTH/2];
valueColumn =
[(NSTableColumn *)[NSTableColumn alloc]
initWithIdentifier: @"Value"];
[valueColumn setEditable: NO];
[[valueColumn headerCell] setStringValue: @"Value"];
[valueColumn setMinWidth:WIDTH/2];
table =
[[NSTableView alloc] initWithFrame:contentRect];
[table addTableColumn:nameColumn]; RELEASE(nameColumn);
[table addTableColumn:valueColumn]; RELEASE(valueColumn);
current=length-1;
[table setDataSource:self];
scrollView = [[NSScrollView alloc] initWithFrame:contentRect];
[scrollView setHasHorizontalScroller:YES];
[scrollView setHasVerticalScroller:YES];
[scrollView setAutoresizingMask: NSViewHeightSizable | NSViewWidthSizable];
[[scrollView contentView]
setAutoresizingMask: NSViewHeightSizable | NSViewWidthSizable];
[[scrollView contentView] setAutoresizesSubviews:YES];
[table setFrameSize:[scrollView contentSize]];
[scrollView setDocumentView:table];
[self setContentView:scrollView];
// RELEASE(scrollView);
[self setTitle:title];
[self display];
[self makeKeyAndOrderFront:nil];
return self;
}
- up:(id)sender
{
if(!current){
NSBeep();
}
else{
current--;
[table reloadData];
}
return self;
}
- down:(id)sender
{
if(current==length-1){
NSBeep();
}
else{
current++;
[table reloadData];
}
return self;
}
- (int)numberOfRowsInTableView:(NSTableView *)aTableView
{
return [names[current] count];
}
- (id)tableView:(NSTableView *)aTableView
objectValueForTableColumn:(NSTableColumn *)aTableColumn
row:(int)rowIndex
{
if(rowIndex>=[names[current] count]){
return nil;
}
if([[aTableColumn identifier] isEqualToString:@"Name"]){
return [names[current] objectAtIndex:rowIndex];
}
else{
return [values[current] objectAtIndex:rowIndex];
}
}
- (void)dealloc
{
int ind;
[table release];
[scrollView release];
for(ind=0; ind<length; ind++){
// NSLog(@"%@ %d %d\n", self, ind, [tables[ind] retainCount]);
[names[ind] release];
[values[ind] release];
}
NSZoneFree([self zone], names);
NSZoneFree([self zone], values);
[super dealloc];
}
@end

14
Document.h
View File

@ -27,19 +27,21 @@
#import <Foundation/NSData.h>
#import <Foundation/NSAttributedString.h>
#import <AppKit/NSDocument.h>
#import <AppKit/NSTextView.h>
#import "SCMTextView.h"
@interface Document : NSDocument
{
NSTextView *tview;
NSScrollView *sview;
SCMTextView *tview;
NSString *progstr;
BOOL readOnly;
}
- init;
- (void)dealloc;
- (void)textDidChange:(NSNotification *)textObject;
- (void)makeWindowControllers;
- evaluate:(id)sender;
@ -48,6 +50,8 @@
- (BOOL)loadDataRepresentation:(NSData *)data ofType:(NSString *)aType;
- (BOOL)readFromFile:(NSString *)fileName ofType:(NSString *)docType;
- (BOOL)writeToFile:(NSString *)fileName ofType:(NSString *)docType;
- (BOOL)writeToFile:(NSString *)fullDocumentPath ofType:(NSString *)docType
originalFile:(NSString *)fullOriginalDocumentPath
saveOperation:(NSSaveOperationType)saveOperationType;
@end

54
Document.m
View File

@ -26,6 +26,7 @@
*/
#include <AppKit/AppKit.h>
#include <AppKit/NSWindowController.h>
#include "Document.h"
#include "SCMTextView.h"
@ -43,10 +44,9 @@
return [super init];
}
- (void)dealloc
- (void)textDidChange:(NSNotification *)textObject
{
// RELEASE (tview);
[super dealloc];
[self updateChangeCount: NSChangeDone];
}
- (NSData *)dataRepresentationOfType:(NSString *)aType
@ -58,7 +58,6 @@
NSString *msg = [NSString stringWithFormat: @"Unknown type: %@",
[aType uppercaseString]];
NSRunAlertPanel(@"Alert", msg, @"Ok", nil, nil);
// [msg autorelease];
return nil;
}
}
@ -73,7 +72,6 @@
NSString *msg = [NSString stringWithFormat: @"Unknown type: %@",
[aType uppercaseString]];
NSRunAlertPanel(@"Alert", msg, @"Ok", nil, nil);
// [msg autorelease];
return NO;
}
@ -90,29 +88,31 @@
readOnly = YES;
NSRunAlertPanel(@"Alert", msg, @"Ok", nil, nil);
// [msg autorelease];
}
return [super readFromFile:fileName ofType:docType];
}
- (BOOL)writeToFile:(NSString *)fileName ofType:(NSString *)docType
- (BOOL)writeToFile:(NSString *)fullDocumentPath ofType:(NSString *)docType
originalFile:(NSString *)fullOriginalDocumentPath
saveOperation:(NSSaveOperationType)saveOperationType;
{
BOOL result = [super writeToFile:fileName ofType:docType];
if(result==YES && readOnly==YES){
BOOL result =
[super writeToFile:fullDocumentPath ofType:docType
originalFile:fullOriginalDocumentPath
saveOperation:saveOperationType];
if(result==YES && readOnly==YES && saveOperationType==NSSaveAsOperation){
NSString *msg = [NSString stringWithFormat: @"File now writable: %@",
fileName];
fullDocumentPath];
NSRunAlertPanel(@"Alert", msg, @"Ok", nil, nil);
// [msg autorelease];
readOnly = NO;
[tview setEditable:YES];
}
else if(result==NO){
NSString *msg = [NSString stringWithFormat: @"Write failed: %@",
fileName];
fullDocumentPath];
NSRunAlertPanel(@"Alert", msg, @"Ok", nil, nil);
// [msg autorelease];
}
return result;
@ -136,12 +136,19 @@ extern NSWindow *interpreterWindow;
res = [vm processString:progstr mode:MODE_EVALUATE];
if(res==NO){
int errpos = [vm errpos];
if(errpos!=-1){
[tview selectLineAtPos:errpos];
}
NSRunAlertPanel(@"Error", [vm errmsg],
@"Ok", nil, nil);
}
else{
[interpreterWindow makeKeyAndOrderFront:self];
}
return self;
}
- (void) makeWindowControllers
@ -150,27 +157,26 @@ extern NSWindow *interpreterWindow;
NSWindow *win = [self makeWindow];
controller = [[NSWindowController alloc] initWithWindow: win];
// RELEASE (win);
RELEASE (win);
[self addWindowController:controller];
// RELEASE(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;
int shiftPos = 0;
#define WREP 7
@implementation Document (Private)
- (NSWindow*)makeWindow
{
NSWindow *window;
NSScrollView *scrollView;
NSTextView *textView;
SCMTextView *textView;
NSRect scrollViewRect = {{0, 0}, {470, 400}};
NSRect winRect = {{100+25*(shiftPos%WREP), 100+25*(shiftPos%WREP)},
{470, 400}};
@ -186,6 +192,7 @@ static int shiftPos = 0;
backing: NSBackingStoreRetained
defer: NO];
[window setMinSize:NSMakeSize(300, 300)];
[window setReleasedWhenClosed:YES];
scrollView = [[NSScrollView alloc] initWithFrame: scrollViewRect];
[scrollView setHasHorizontalScroller: NO];
@ -194,6 +201,7 @@ static int shiftPos = 0;
[[scrollView contentView] setAutoresizingMask: NSViewHeightSizable
| NSViewWidthSizable];
[[scrollView contentView] setAutoresizesSubviews:YES];
sview = scrollView;
// Build up the text network
textRect = [[scrollView contentView] frame];
@ -218,12 +226,13 @@ static int shiftPos = 0;
tview = textView;
[scrollView setDocumentView: textView];
// RELEASE(textView);
RELEASE(textView);
[window setContentView: scrollView];
// RELEASE(scrollView);
RELEASE(scrollView);
// Make the Document the delegate of the window
[window setDelegate: self];
[window setTitle:[self displayName]];
// Make the text view the first responder
[window makeFirstResponder:textView];
@ -233,5 +242,4 @@ static int shiftPos = 0;
return window;
}
@end

12
EnvWindow.h
View File

@ -8,9 +8,11 @@
int current;
int length;
id *forms;
id *names;
id *values;
NSScrollView *scrollView;
NSTableView *table;
}
- initWithEnv:(Environment *)env;
@ -18,7 +20,13 @@
- up:(id)sender;
- down:(id)sender;
- releaseForms;
- (int)numberOfRowsInTableView:(NSTableView *)aTableView;
- (id)tableView:(NSTableView *)aTableView
objectValueForTableColumn:(NSTableColumn *)aTableColumn
row:(int)rowIndex;
- (void)dealloc;
@end

123
EnvWindow.m
View File

@ -12,7 +12,7 @@ static int count = 0;
{
NSWindow *window;
Environment *layer; int lind;
NSRect scrollViewRect = {{0, 0}, {WIDTH, HEIGHT}};
NSRect contentRect = {{0, 0}, {WIDTH, HEIGHT}};
NSRect winRect =
{{250+(count%12)*24, 100+(count%12)*24}, {WIDTH, HEIGHT}};
NSRect textRect;
@ -21,43 +21,34 @@ static int count = 0;
NSString *title =
[NSString stringWithFormat:@"Scheme Env. # %d", ++count];
length = [env chainLength]; current=length-1;
forms = NSZoneMalloc([self zone], length*sizeof(id));
length = [env chainLength];
names = NSZoneMalloc([self zone], length*sizeof(id));
values = NSZoneMalloc([self zone], length*sizeof(id));
NSAutoreleasePool *pool = [NSAutoreleasePool new];
for(lind=length-1, layer = env; lind>=0; lind--){
NSMutableDictionary *data = [layer data];
NSMutableArray *keys;
NSEnumerator *en;
id key, form;
NSMapTable *data = [layer data];
keys = [NSMutableArray arrayWithCapacity:1];
[keys setArray:[data allKeys]];
[keys sortUsingSelector:@selector(compare:)];
names[lind] = [NSMutableArray arrayWithArray:NSAllMapTableKeys(data)];
[names[lind] sortUsingSelector:@selector(compare:)];
[names[lind] retain];
en = [keys objectEnumerator];
values[lind] = [NSMutableArray arrayWithCapacity:[names[lind] count]];
[values[lind] retain];
forms[lind] = form =
[[NSForm alloc] initWithFrame:scrollViewRect];
NSEnumerator *en = [names[lind] objectEnumerator];
id key;
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]];
id obj = NSMapGet(data, key);
[values[lind] addObject:[VScheme valToString:obj]];
}
[form setEntryWidth:WIDTH];
[form setAutosizesCells:YES];
[form setAutoresizingMask:NSViewWidthSizable];
// [form retain];
layer = [layer parent];
}
[pool release];
[self initWithContentRect:winRect
styleMask:style
backing:NSBackingStoreRetained
@ -65,15 +56,41 @@ static int count = 0;
[self setMinSize:NSMakeSize(WIDTH, HEIGHT)];
[self setReleasedWhenClosed:YES];
scrollView = [[NSScrollView alloc] initWithFrame: scrollViewRect];
NSTableColumn *nameColumn, *valueColumn;
nameColumn =
[(NSTableColumn *)[NSTableColumn alloc]
initWithIdentifier: @"Name"];
[nameColumn setEditable: NO];
[[nameColumn headerCell] setStringValue: @"Name"];
[nameColumn setMinWidth:WIDTH/2];
valueColumn =
[(NSTableColumn *)[NSTableColumn alloc]
initWithIdentifier: @"Value"];
[valueColumn setEditable: NO];
[[valueColumn headerCell] setStringValue: @"Value"];
[valueColumn setMinWidth:WIDTH/2];
table =
[[NSTableView alloc] initWithFrame:contentRect];
[table addTableColumn:nameColumn]; RELEASE(nameColumn);
[table addTableColumn:valueColumn]; RELEASE(valueColumn);
current=length-1;
[table setDataSource:self];
scrollView = [[NSScrollView alloc] initWithFrame:contentRect];
[scrollView setHasHorizontalScroller:YES];
[scrollView setHasVerticalScroller:YES];
[scrollView setAutoresizingMask: NSViewHeightSizable | NSViewWidthSizable];
[[scrollView contentView] setAutoresizingMask: NSViewHeightSizable
| NSViewWidthSizable];
[[scrollView contentView]
setAutoresizingMask: NSViewHeightSizable | NSViewWidthSizable];
[[scrollView contentView] setAutoresizesSubviews:YES];
[scrollView setDocumentView:forms[current]];
[table setFrameSize:[scrollView contentSize]];
[scrollView setDocumentView:table];
[self setContentView:scrollView];
// RELEASE(scrollView);
@ -91,10 +108,8 @@ static int count = 0;
NSBeep();
}
else{
NSRect bounds = [forms[current] bounds];
current--;
[forms[current] setEntryWidth:bounds.size.width];
[scrollView setDocumentView:forms[current]];
[table reloadData];
}
return self;
@ -106,29 +121,51 @@ static int count = 0;
NSBeep();
}
else{
NSRect bounds = [forms[current] bounds];
current++;
[forms[current] setEntryWidth:bounds.size.width];
[scrollView setDocumentView:forms[current]];
[table reloadData];
}
return self;
}
- releaseForms
- (int)numberOfRowsInTableView:(NSTableView *)aTableView
{
return [names[current] count];
}
- (id)tableView:(NSTableView *)aTableView
objectValueForTableColumn:(NSTableColumn *)aTableColumn
row:(int)rowIndex
{
if(rowIndex>=[names[current] count]){
return nil;
}
if([[aTableColumn identifier] isEqualToString:@"Name"]){
return [names[current] objectAtIndex:rowIndex];
}
else{
return [values[current] objectAtIndex:rowIndex];
}
}
- (void)dealloc
{
int ind;
[scrollView setDocumentView:nil];
[table release];
[scrollView release];
for(ind=0; ind<length; ind++){
// NSLog(@"%@ %d %d\n", self, ind, [forms[ind] retainCount]);
[forms[ind] release];
// NSLog(@"%@ %d %d\n", self, ind, [tables[ind] retainCount]);
[names[ind] release];
[values[ind] release];
}
NSZoneFree([self zone], forms);
return self;
NSZoneFree([self zone], names);
NSZoneFree([self zone], values);
[super dealloc];
}
@end

2
GNUmakefile
View File

@ -25,7 +25,7 @@ SHARED_CFLAGS += -g
AUXILIARY_TOOL_LIBS += -lfl
# The Resource files to be copied into the app's resources directory
GScheme_RESOURCE_FILES = Scheme/*
GScheme_RESOURCE_FILES = Scheme/* Icons/*
-include GNUmakefile.preamble

218
GScheme.app/GScheme
View File

@ -1,218 +0,0 @@
#!/bin/sh
#
# Copyright (C) 1999 Free Software Foundation, Inc.
#
# Author: Adam Fedor <fedor@gnu.org>
# 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 "$@"

8
GScheme.app/Resources/GScheme.desktop
View File

@ -1,8 +0,0 @@
[Desktop Entry]
Encoding=UTF-8
Type=Application
Version=GScheme 0.1
Name=GScheme
Exec=openapp GScheme.app
#TryExec=GScheme.app
MimeType=

29
GScheme.app/Resources/Info-gnustep.plist
View File

@ -1,29 +0,0 @@
{
ApplicationDescription = "A scheme interpreter";
ApplicationName = GScheme;
ApplicationRelease = "GScheme 0.1";
Authors = (
"Marko Riedel <mriedel@neuearbeit.de>"
);
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
);
}
);
}

109
GScheme.app/Resources/library.scm
View File

@ -1,109 +0,0 @@
(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)))))))

103
GScheme.app/Resources/library.scm~
View File

@ -1,103 +0,0 @@
(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)))))))

7
GSchemeInfo.plist
View File

@ -1,11 +1,12 @@
{
ApplicationName = "GScheme";
ApplicationDescription = "A scheme interpreter";
ApplicationRelease = "GScheme 0.1";
FullVersionID = "0.1, June 2002";
ApplicationRelease = "GScheme 0.5";
FullVersionID = "0.5, January 2005";
Authors = ("Marko Riedel <mriedel@neuearbeit.de>");
Copyright = "Copyright (C) 2002 Free Software Foundation, Inc.";
Copyright = "Copyright (C) 2005 Free Software Foundation, Inc.";
CopyrightDescription = "This program is released under the GNU General Public License";
NSIcon = "GScheme.tiff";
NSTypes = (
{
NSName = "scm";

BIN
Icons/GScheme.tiff Normal file
View File

Binary file not shown.

BIN
Icons/lambda1.tiff Normal file
View File

Binary file not shown.

6
NOTES Normal file
View File

@ -0,0 +1,6 @@
wrp
retaincount loop
external
paste
stop button
env browser

130
Primitive.h
View File

@ -18,6 +18,7 @@ BOOL isPair(id item);
BOOL isVector(id item);
BOOL isTriple(id item);
BOOL isPrimitive(id item);
BOOL isEval(id item);
BOOL isClosure(id item);
BOOL isThunk(id item);
BOOL isFalse(id item);
@ -118,6 +119,11 @@ typedef enum {
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs;
@end
@interface PRMRandom : 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;
@ -183,6 +189,41 @@ typedef enum {
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs;
@end
@interface PRMDrawCircle : Primitive
- (NSString *)primName;
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs;
@end
@interface PRMFillCircle : Primitive
- (NSString *)primName;
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs;
@end
@interface PRMDrawRect : Primitive
- (NSString *)primName;
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs;
@end
@interface PRMFillRect : Primitive
- (NSString *)primName;
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs;
@end
@interface PRMDrawFont : Primitive
- (NSString *)primName;
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs;
@end
@interface PRMDrawString : Primitive
- (NSString *)primName;
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs;
@end
@interface PRMDrawShow : 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;
@ -193,6 +234,26 @@ typedef enum {
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs;
@end
@interface PRMTan : Primitive
- (NSString *)primName;
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs;
@end
@interface PRMExp : Primitive
- (NSString *)primName;
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs;
@end
@interface PRMLog : Primitive
- (NSString *)primName;
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs;
@end
@interface PRMATan : 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;
@ -243,7 +304,76 @@ typedef enum {
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs;
@end
@interface PRMSymToStr : Primitive
- (NSString *)primName;
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs;
@end
@interface PRMStrToSym : Primitive
- (NSString *)primName;
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs;
@end
@interface PRMStringSize : Primitive
- (NSString *)primName;
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs;
@end
@interface PRMStringLength : Primitive
- (NSString *)primName;
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs;
@end
@interface PRMCharToInt : Primitive
- (NSString *)primName;
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs;
@end
@interface PRMIntToChar : Primitive
- (NSString *)primName;
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs;
@end
@interface PRMStringRef : Primitive
- (NSString *)primName;
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs;
@end
@interface PRMListToStr : Primitive
- (NSString *)primName;
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs;
@end
@interface PRMStrToList : Primitive
- (NSString *)primName;
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs;
@end
@interface PRMStringAppend : Primitive
- (NSString *)primName;
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs;
@end
@interface PRMMakeString : Primitive
- (NSString *)primName;
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs;
@end
@interface PRMNumberToStr : Primitive
- (NSString *)primName;
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs;
@end
@interface PRMFormat : 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
@interface PRMEval : Primitive
- (NSString *)primName;
@end

1023
Primitive.m
View File

File diff suppressed because it is too large Load Diff

9
SCMTextView.h
View File

@ -4,6 +4,13 @@
#import "VScheme.h"
@interface NSTextView (Misc)
- placeCursorAtEnd;
- selectLineAtPos:(int)pos;
@end
@interface SCMTextView : NSTextView
- (void)insertText:(id)aString;
@ -18,8 +25,8 @@
- (id)initWithFrame:(NSRect)frameRect;
- (void)insertText:(id)aString;
- (void)paste:(id)sender;
- placeCursorAtEnd;
- (NSString *)getSuffix;
- (void)setString:(NSString *)aString;

44
SCMTextView.m
View File

@ -2,6 +2,28 @@
#import "SCMTextView.h"
#import "SchemeDelegate.h"
@implementation NSTextView (Misc)
- placeCursorAtEnd
{
NSRange range = { [[self string] length], 0 };
[self setSelectedRange:range];
return self;
}
- selectLineAtPos:(int)pos
{
NSString *data = [self string];
unsigned startInd, endInd;
[data getLineStart:&startInd end:&endInd
contentsEnd:NULL forRange:NSMakeRange(pos, 0)];
[self setSelectedRange:NSMakeRange(startInd, endInd-startInd)];
return self;
}
@end
@implementation SCMTextView
@ -68,17 +90,21 @@
- (void)insertText:(id)aString
{
if([self selectedRange].location<lastRetrieved){
return;
NSRange range = { [[self string] length], 0 };
[self setSelectedRange:range];
}
[super insertText:aString];
}
- placeCursorAtEnd
- (void)paste:(id)sender
{
if([self selectedRange].location<lastRetrieved){
NSRange range = { [[self string] length], 0 };
[self setSelectedRange:range];
return self;
}
[super paste:sender];
}
- (NSString *)getSuffix
@ -115,10 +141,18 @@
if((ch==NSNewlineCharacter || ch==NSCarriageReturnCharacter) &&
len==1 && (modifiers & NSControlKeyMask)){
BOOL res = [[self delegate] processString:[self getSuffix]
NSString *sfx = [self getSuffix];
NSPasteboard *pb = [NSPasteboard generalPasteboard];
[pb declareTypes:[NSArray arrayWithObject:NSStringPboardType]
owner:nil];
[pb setString:sfx forType:NSStringPboardType];
BOOL res =
[[self delegate] processString:sfx
mode:MODE_INTERACTIVE];
if(res==NO){
NSRunAlertPanel(@"Error", [[self delegate] errmsg],
NSRunAlertPanel(@"Error", [(VScheme *)[self delegate] errmsg],
@"Ok", nil, nil);
}
return;

43
Scheme/library.scm
View File

@ -107,3 +107,46 @@
(map-over-single-list car lists))
(apply for-each
(cons proc (map-over-single-list cdr lists)))))))
(define pow (lambda (x y) (exp (* y (log x)))))
(define caar (lambda (p) (car (car p))))
(define cadr (lambda (p) (car (cdr p))))
(define cdar (lambda (p) (cdr (car p))))
(define cddr (lambda (p) (cdr (cdr p))))
(define caaar (lambda (p) (car (car (car p)))))
(define caadr (lambda (p) (car (car (cdr p)))))
(define cadar (lambda (p) (car (cdr (car p)))))
(define caddr (lambda (p) (car (cdr (cdr p)))))
(define cdaar (lambda (p) (cdr (car (car p)))))
(define cdadr (lambda (p) (cdr (car (cdr p)))))
(define cddar (lambda (p) (cdr (cdr (car p)))))
(define cdddr (lambda (p) (cdr (cdr (cdr p)))))
(define min-max
(lambda (pred args)
(letrec
((iter
(lambda (l m)
(if (null? l) m
(iter (cdr l)
(if (pred (car l) m) (car l) m))))))
(iter (cdr args) (car args)))))
(define min
(lambda args
(min-max < args)))
(define max
(lambda args
(min-max > args)))
(define make-range
(lambda (a b)
(if (= a b) (list a)
(cons
a (make-range (+ 1 a) b)))))

44
Scheme/library.scm~
View File

@ -1,3 +1,9 @@
(define vector
(lambda args
(list->vector args)))
(define list-n
(lambda (n)
(if (zero? n) '()
@ -101,3 +107,41 @@
(map-over-single-list car lists))
(apply for-each
(cons proc (map-over-single-list cdr lists)))))))
(define pow (lambda (x y) (exp (* y (log x)))))
(define caar (lambda (p) (car (car p))))
(define cadr (lambda (p) (car (cdr p))))
(define cdar (lambda (p) (cdr (car p))))
(define cddr (lambda (p) (cdr (cdr p))))
(define caaar (lambda (p) (car (car (car p)))))
(define caadr (lambda (p) (car (car (cdr p)))))
(define cadar (lambda (p) (car (cdr (car p)))))
(define caddr (lambda (p) (car (cdr (cdr p)))))
(define cdaar (lambda (p) (cdr (car (car p)))))
(define cdadr (lambda (p) (cdr (car (cdr p)))))
(define cddar (lambda (p) (cdr (cdr (car p)))))
(define cdddr (lambda (p) (cdr (cdr (cdr p)))))
(define min-max
(lambda (pred args)
(letrec
((iter
(lambda (l m)
(if (null? l) m
(iter (cdr l)
(if (pred (car l) m) (car l) m))))))
(iter (cdr args) (car args)))))
(define min
(lambda args
(min-max < args)))
(define max
(lambda args
(min-max > args)))

10
SchemeDelegate.h
View File

@ -14,13 +14,19 @@
NSMutableArray *imageWindows;
NSMutableArray *envWindows;
NSPanel *interruptPanel;
}
- (void)applicationWillFinishLaunching:(NSNotification *)not;
- (void)applicationDidFinishLaunching:(NSNotification *)not;
- makeInterpreterWindow;
- makeStatisticsWindow;
- makeStatisticsPanel;
- makeInterruptPanel;
- (NSPanel *)interruptPanel;
- input:(NSString *)data;
- output:(NSString *)data;
@ -35,5 +41,7 @@
- reset:(id)sender;
- addExternal:(id)sender;
- evaluateExternal:(id)sender;
@end

159
SchemeDelegate.m
View File

@ -9,15 +9,8 @@ VScheme *vm = nil;
- (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;
NSMenu *menu, *info, *file, *scheme, *external, *env,
*edit, *print, *services, *windows;
// Create the app menu
menu = [NSMenu new];
@ -71,6 +64,18 @@ VScheme *vm = nil;
action: @selector(evaluate:)
keyEquivalent: @"#"];
[scheme addItemWithTitle: @"Evaluate external"
action:NULL
keyEquivalent: @""];
external = [NSMenu new];
[scheme setSubmenu: external
forItem: [scheme itemWithTitle: @"Evaluate external"]];
[external addItemWithTitle: @"Add external"
action: @selector(addExternal:)
keyEquivalent: @""];
// Create the environment submenu
env = [NSMenu new];
[menu setSubmenu: env
@ -229,7 +234,8 @@ VScheme *vm = nil;
vm = [[VScheme alloc] init];
[vm setDelegate:self];
[self makeStatisticsWindow];
[self makeStatisticsPanel];
[self makeInterruptPanel];
[self makeInterpreterWindow];
// Make the DocumentController the delegate of the application,
@ -239,6 +245,7 @@ VScheme *vm = nil;
NSWindow *interpreterWindow = nil;
- makeInterpreterWindow
{
NSWindow *window;
@ -310,9 +317,9 @@ NSWindow *interpreterWindow = nil;
return self;
}
- makeStatisticsWindow
- makeStatisticsPanel
{
NSWindow *window;
NSPanel *panel;
NSScrollView *scrollView;
SCMInteractive *textView;
NSRect scrollViewRect = {{0, 0}, {470, 400}};
@ -323,11 +330,11 @@ NSWindow *interpreterWindow = nil;
// 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
panel = [[NSPanel alloc] initWithContentRect: winRect
styleMask: style
backing: NSBackingStoreRetained
defer: NO];
[window setMinSize:NSMakeSize(300, 300)];
[panel setMinSize:NSMakeSize(300, 300)];
scrollView = [[NSScrollView alloc] initWithFrame: scrollViewRect];
[scrollView setHasHorizontalScroller: NO];
@ -363,21 +370,53 @@ NSWindow *interpreterWindow = nil;
[scrollView setDocumentView: textView];
// RELEASE(textView);
[window setContentView: scrollView];
[panel setContentView: scrollView];
// RELEASE(scrollView);
// Make the Document the delegate of the window
[window setDelegate: self];
// Make the Document the delegate of the panel
[panel setDelegate: self];
[panel setWorksWhenModal:NO];
// Make the text view the first responder
// [window makeFirstResponder:textView];
[window setTitle:@"GScheme Statistics"];
[window display];
[window orderFront:nil];
// [panel makeFirstResponder:textView];
[panel setTitle:@"GScheme Statistics"];
[panel display];
[panel orderFront:nil];
return self;
}
#define IPCWIDTH 100
#define IPCHEIGHT 30
- makeInterruptPanel
{
interruptPanel =
[[NSPanel alloc]
initWithContentRect:NSMakeRect(0, 0, IPCWIDTH, IPCHEIGHT)
styleMask:NSBorderlessWindowMask
backing:NSBackingStoreBuffered
defer:NO];
[interruptPanel setReleasedWhenClosed:NO];
NSButton *stopper;
stopper = [NSButton new];
[stopper setTitle:@"Stop"];
[stopper setTarget:vm];
[stopper setAction:@selector(interrupt:)];
[interruptPanel setContentView:stopper];
return self;
}
- (NSPanel *)interruptPanel
{
return interruptPanel;
}
- input:(NSString *)data
{
[intTextView appendString:data];
@ -387,6 +426,7 @@ NSWindow *interpreterWindow = nil;
- output:(NSString *)data
{
[intTextView appendString:data];
[intTextView placeCursorAtEnd];
return self;
}
@ -402,7 +442,12 @@ NSWindow *interpreterWindow = nil;
- statistics:(NSString *)stats
{
NSString *sofar = [statTextView string];
[statTextView setString:[sofar stringByAppendingString:stats]];
[statTextView
replaceCharactersInRange:NSMakeRange([sofar length], 0)
withString:stats];
[statTextView placeCursorAtEnd];
return self;
}
@ -418,6 +463,67 @@ NSWindow *interpreterWindow = nil;
[statTextView setString:GSCHEME];
}
- addExternal:(id)sender
{
NSOpenPanel *openPanel = [NSOpenPanel openPanel];
[openPanel setTitle:@"Add external"];
[openPanel setAllowsMultipleSelection:NO];
[openPanel setPrompt:@"File:"];
[openPanel setCanChooseDirectories:NO];
if([openPanel
runModalForTypes:
[NSArray arrayWithObject:@"scm"]]==NSOKButton){
[[sender menu] addItemWithTitle:[openPanel filename]
action:@selector(evaluateExternal:)
keyEquivalent: @""];
}
return self;
}
extern VScheme *vm;
extern NSWindow *interpreterWindow;
extern int errno;
- evaluateExternal:(id)sender
{
SCMInteractive *intView =
[[interpreterWindow contentView] documentView];
NSString *suffix = [intView getSuffix];
if([suffix length]>0){
[intView appendString:@"\n> "];
}
NSString *progstr;
if((progstr =
[NSString stringWithContentsOfFile:[sender title]])==nil){
NSString *msg = @"Load failed";
if(errno){
char *estr = strerror(errno);
msg = [msg stringByAppendingFormat:@": %s", estr];
}
NSRunAlertPanel(@"Error", msg, @"Ok", nil, nil);
return self;
}
BOOL res = [vm processString:progstr mode:MODE_EVALUATE];
if(res==NO){
NSRunAlertPanel(@"Error", [vm errmsg],
@"Ok", nil, nil);
}
else{
[interpreterWindow makeKeyAndOrderFront:self];
}
return self;
}
- imageWindow:(NSWindow *)window
{
[imageWindows addObject:window];
@ -441,21 +547,20 @@ NSWindow *interpreterWindow = nil;
}
else if([envWindows containsObject:win]==YES){
[envWindows removeObject:win];
[win releaseForms];
}
}
- closeImageWindows:(id)sender
{
[imageWindows
makeObjectsPerformSelector:@selector(close)];
NSArray *cwins = [NSArray arrayWithArray:imageWindows];
[cwins makeObjectsPerformSelector:@selector(close)];
return self;
}
- closeEnvWindows:(id)sender
{
[envWindows
makeObjectsPerformSelector:@selector(close)];
NSArray *cwins = [NSArray arrayWithArray:envWindows];
[cwins makeObjectsPerformSelector:@selector(close)];
return self;
}

45
SchemeTypes.h
View File

@ -2,27 +2,13 @@
#import <AppKit/AppKit.h>
@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
{
@protected
int mark;
}
@ -107,6 +93,7 @@
NSString *value;
}
- initSCMStringLEX:(char *)val;
- initSCMString:(char *)val;
- (NSString *)strVal;
@ -199,18 +186,18 @@
@interface Environment : SCMType
{
Environment *parent;
NSMutableDictionary *data;
NSMapTable *data;
}
+ newParent:(Environment *)par Data:(NSMutableDictionary *)entries;
- initParent:(Environment *)par Data:(NSMutableDictionary *)entries;
+ newParent:(Environment *)par Data:(NSMapTable *)entries;
- initParent:(Environment *)par Data:(NSMapTable *)entries;
- (int)chainLength;
- (NSMutableDictionary *)lookup:(NSString *)sym;
- (NSMapTable *)lookup:(NSString *)sym;
- (Environment *)parent;
- (NSMutableDictionary *)data;
- (NSMapTable *)data;
- setMarkToCurrent;
@ -294,11 +281,16 @@ typedef enum {
@interface ByteCodes : SCMType
{
NSMutableArray *data;
unsigned int capacity;
unsigned int length;
id *data;
BOOL root;
id source;
}
+ new;
- initWithMutableArray:(NSMutableArray *)theData;
- init;
- prependTriple:(Triple *)theTriple;
@ -306,10 +298,17 @@ typedef enum {
- appendByteCodes:(ByteCodes *)codes;
- (NSMutableArray *)codes;
- (id *)codes;
- (unsigned int)length;
- setMarkToCurrent;
- (BOOL)root;
- setRoot:(BOOL)rflag;
- source;
- setSource:(id)src;
- (void)free;
@end

255
SchemeTypes.m
View File

@ -1,42 +1,6 @@
#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;
@ -233,11 +197,11 @@ static int totalAllocated = 0;
- setMarkToCurrent
{
if([self mark]==currentMark){
if(mark==currentMark){
return;
}
[super setMarkToCurrent];
mark = currentMark;
if(MARKABLE(car)){
[car setMarkToCurrent];
}
@ -309,11 +273,11 @@ static int totalAllocated = 0;
{
int index;
if([self mark]==currentMark){
if(mark==currentMark){
return;
}
[super setMarkToCurrent];
mark = currentMark;
for(index=0; index<count; index++){
id obj = data[index];
@ -369,11 +333,11 @@ static int totalAllocated = 0;
- setMarkToCurrent
{
if([self mark]==currentMark){
if(mark==currentMark){
return;
}
[super setMarkToCurrent];
mark = currentMark;
if(MARKABLE(args)){
[args setMarkToCurrent];
}
@ -444,13 +408,13 @@ static int totalAllocated = 0;
@implementation Environment
+ newParent:(Environment *)par Data:(NSMutableDictionary *)entries
+ newParent:(Environment *)par Data:(NSMapTable *)entries
{
return [[super alloc]
initParent:par Data:entries];
}
- initParent:(Environment *)par Data:(NSMutableDictionary *)entries
- initParent:(Environment *)par Data:(NSMapTable *)entries
{
[super init];
@ -458,7 +422,7 @@ static int totalAllocated = 0;
[parent retain];
data = entries; // [entries mutableCopy];
[data retain];
// [data retain];
return self;
}
@ -468,13 +432,13 @@ static int totalAllocated = 0;
return (parent==nil ? 1 : 1+[parent chainLength]);
}
- (NSMutableDictionary *)lookup:(NSString *)sym
- (NSMapTable *)lookup:(NSString *)sym
{
if([data objectForKey:sym]!=nil){
if(NSMapGet(data, sym)!=NULL){
return data;
}
return (parent==nil ? nil : [parent lookup:sym]);
return (parent==nil ? NULL : [parent lookup:sym]);
}
- (Environment *)parent
@ -482,24 +446,27 @@ static int totalAllocated = 0;
return parent;
}
- (NSMutableDictionary *)data
- (NSMapTable *)data
{
return data;
}
- setMarkToCurrent
{
NSEnumerator *enumerator = [data objectEnumerator];
NSMapEnumerator enumerator = NSEnumerateMapTable(data);
id item;
if([self mark]==currentMark){
if(mark==currentMark){
return;
}
[super setMarkToCurrent];
while((item = [enumerator nextObject])!=nil){
if(MARKABLE(item)){
[item setMarkToCurrent];
mark = currentMark;
id key, val;
while(NSNextMapEnumeratorPair
(&enumerator, (void**)&key, (void**)&val)){
if(MARKABLE(val)){
[val setMarkToCurrent];
}
}
@ -510,28 +477,9 @@ static int totalAllocated = 0;
return self;
}
#define GSI_MAP_NOCLEAN 1
#include <base/GSIMap.h>
@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];
}
NSFreeMapTable(data);
[super free];
}
@ -549,7 +497,9 @@ typedef struct {
+ newTag:(int)tagval IntArg1:(int)arg1;
{
NSNumber *num = [NSNumber numberWithInt:arg1];
// NSNumber *num = [NSNumber numberWithInt:arg1];
Int *num = [[Int alloc] initSCMInt:arg1];
return [[super alloc]
initTag:tagval
Arg1:num Arg2:nil Arg3:nil];
@ -581,9 +531,20 @@ typedef struct {
{
tag = tagval;
items[0] = arg1; [arg1 retain];
items[1] = arg2; [arg2 retain];
items[2] = arg3; [arg3 retain];
items[0] = arg1;
if(arg1!=nil){
[arg1 retain];
}
items[1] = arg2;
if(arg2!=nil){
[arg2 retain];
}
items[2] = arg3;
if(arg3!=nil){
[arg3 retain];
}
return self;
}
@ -595,12 +556,14 @@ typedef struct {
- (int)intarg1
{
return [items[0] intValue];
return [items[0] intVal];
}
- setIntArg1:(int)val
{
items[0] = [NSNumber numberWithInt:val];
// items[0] = [NSNumber numberWithInt:val];
items[0] = [[Int alloc] initSCMInt:val];
[items[0] retain];
return self;
}
@ -621,11 +584,11 @@ typedef struct {
- setMarkToCurrent
{
if([self mark]==currentMark){
if(mark==currentMark){
return;
}
[super setMarkToCurrent];
mark = currentMark;
if(MARKABLE(items[0])){
[items[0] setMarkToCurrent];
}
@ -715,8 +678,10 @@ typedef struct {
- initSCMSymbol:(char *)val
{
[super init];
value = [NSString stringWithCString:val];
[value retain];
return self;
}
@ -735,7 +700,7 @@ typedef struct {
@implementation String
- initSCMString:(char *)val
- initSCMStringLEX:(char *)val
{
char *cp, *buf, *from, *to;
int len = strlen(val);
@ -762,6 +727,16 @@ typedef struct {
return self;
}
- initSCMString:(char *)val
{
[super init];
value = [NSString stringWithCString:val];
[value retain];
return self;
}
- (NSString *)strVal
{
return value;
@ -775,89 +750,143 @@ typedef struct {
@end
#define BASE_CAPACITY 16
@implementation ByteCodes
+ new
{
id inst = [super alloc];
[inst initWithMutableArray:[NSMutableArray arrayWithCapacity:1]];
[inst init];
return inst;
}
- initWithMutableArray:(NSMutableArray *)theData
- init
{
[super init];
data = theData;
[data retain];
capacity = BASE_CAPACITY;
length = 0;
data = (id *)NSZoneMalloc(NSDefaultMallocZone(), capacity*sizeof(id));
root = NO;
source = nil;
return self;
}
- prependTriple:(Triple *)theTriple
{
[data prependObjWRP:theTriple];
if(length==capacity){
capacity *= 2;
data = (id *)NSZoneRealloc(NSDefaultMallocZone(), data, capacity*sizeof(id));
}
memmove(data+1, data, length*sizeof(id));
length++;
data[0] = theTriple;
[theTriple retain];
return self;
}
- addTriple:(Triple *)theTriple
{
[data addObjWRP:theTriple];
if(length==capacity){
capacity *= 2;
data = (id *)NSZoneRealloc(NSDefaultMallocZone(), data, capacity*sizeof(id));
}
data[length++] = theTriple;
[theTriple retain];
return self;
}
- appendByteCodes:(ByteCodes *)codes
{
[data addObjectsFromArray:[codes codes]];
unsigned int otherLength = [codes length];
id *otherData = [codes codes];
if(length+otherLength>capacity){
while(length+otherLength>capacity){
capacity *= 2;
}
data = (id *)NSZoneRealloc(NSDefaultMallocZone(), data, capacity*sizeof(id));
}
unsigned int pos;
for(pos=0; pos<otherLength; pos++){
data[length] = otherData[pos];
[data[length] retain];
length++;
}
return self;
}
- (NSMutableArray *)codes
- (id *)codes
{
return data;
}
- (unsigned int)length
{
return length;
}
- setMarkToCurrent
{
int index, count = [data count];
if([self mark]==currentMark){
if(mark==currentMark){
return;
}
[super setMarkToCurrent];
mark = currentMark;
for(index=0; index<count; index++){
id obj = [data objectAtIndex:index];
unsigned int index;
for(index=0; index<length; index++){
id obj = data[index];
if(MARKABLE(obj)){
[obj setMarkToCurrent];
}
}
if(MARKABLE(source)){
[source setMarkToCurrent];
}
return self;
}
@interface GSMutableArray : NSMutableArray
- (BOOL)root
{
@public
id *_contents_array;
unsigned _count;
unsigned _capacity;
int _grow_factor;
return root;
}
@end
typedef struct {
@defs(GSMutableArray)
} *GSMArrayPtr;
- setRoot:(BOOL)rflag
{
root = rflag;
return self;
}
- source
{
return source;
}
- setSource:(id)src
{
source = src;
[src retain];
return self;
}
- (void)free
{
((GSMArrayPtr)data)->_count = 0;
while([data retainCount]>1){
[data release];
}
NSZoneFree(NSDefaultMallocZone(), data);
[super free];
}

6
TestScheme.app/Resources/Info-gnustep.plist
View File

@ -1,6 +0,0 @@
{
NOTE = "Automatically generated, do not edit!";
NSExecutable = "TestScheme";
NSMainNibFile = "";
NSPrincipalClass = "NSApplication";
}

5
TestScheme.app/Resources/TestScheme.desktop
View File

@ -1,5 +0,0 @@
[Desktop Entry]
Encoding=UTF-8
Type=Application
Exec=openapp TestScheme.app
#TryExec=TestScheme.app

218
TestScheme.app/TestScheme
View File

@ -1,218 +0,0 @@
#!/bin/sh
#
# Copyright (C) 1999 Free Software Foundation, Inc.
#
# Author: Adam Fedor <fedor@gnu.org>
# 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 "$@"

38
VScheme.h
View File

@ -7,15 +7,21 @@
#define GSCHEME @"GScheme by Marko Riedel, mriedel@neuearbeit.de\n"
typedef enum {
MODE_INTERACTIVE,
MODE_INTERACTIVE = 0,
MODE_EVALUATE,
MODE_LOAD
} PROCESS_MODE;
typedef enum {
DRAW_MOVE,
DRAW_MOVE = 0,
DRAW_LINE,
DRAW_COLOR
DRAW_COLOR,
DRAW_CIRCLE,
FILL_CIRCLE,
DRAW_RECT,
FILL_RECT,
DRAW_FONT,
DRAW_STRING
} DRAW_INST;
typedef struct _DrawInst {
@ -23,11 +29,16 @@ typedef struct _DrawInst {
union {
NSPoint coord;
float color[3];
float radius;
NSFont *font;
NSString *string;
NSSize size;
} data;
} DrawInst;
@interface VScheme : NSObject
{
int errpos;
BOOL errflag;
NSString *errmsg;
@ -36,10 +47,12 @@ typedef struct _DrawInst {
NSMutableArray *argStack;
NSMutableArray *envStack;
id curcodes;
id *curcodes;
int curpc;
int curlength;
NSString *output;
BOOL hadOutput;
NSMutableString *output;
int maxcode, maxpc, maxarg, maxenv;
@ -47,16 +60,18 @@ typedef struct _DrawInst {
BOOL atImgStart;
NSPoint imgMin, imgMax;
NSPoint imgCur;
NSMutableArray *imgCodes;
NSFont *imgFont;
long int curRecDepth, maxRecDepth;
BOOL interrupted;
}
+ (NSString *)valToString:(id)item seen:(NSMutableSet *)mem;
+ (NSString *)valToString:(id)item;
+ printInstr:(Triple *)instr;
+ printCodes:(NSMutableArray *)codes;
+ printCodes:(ByteCodes *)codes;
- init;
@ -77,6 +92,7 @@ typedef struct _DrawInst {
- (NSString *)output;
- clearOutput;
- (NSSize)stringAtCurrentFont:(NSString *)str;
- recordImgInst:(DrawInst)inst;
- clearImage;
- produceImage;
@ -86,12 +102,15 @@ typedef struct _DrawInst {
- (NSMutableArray *)codeStack;
- (BOOL)errflag;
- (int)errpos;
- (NSString *)errmsg;
- args2list:(int)lower;
- pushCodes:(NSMutableArray *)codes;
- (BOOL)run:(ByteCodes *)prog;
- pushByteCodes:(ByteCodes *)bcodes;
- interrupt:(id)sender;
- (BOOL)run:(ByteCodes *)prog mode:(PROCESS_MODE)pmode;
- special:(id)data output:(ByteCodes *)codes popenv:(int)ec;
- sequence:(id)data output:(ByteCodes *)codes popenv:(int)ec;
@ -99,6 +118,7 @@ typedef struct _DrawInst {
- (BOOL)compile:(id)data output:(ByteCodes *)codes;
- parse:(NSString *)scmText;
- (BOOL)processString:(NSString *)data mode:(PROCESS_MODE)pmode;
@end

668
VScheme.m
View File

File diff suppressed because it is too large Load Diff

6
examples/allocate1.scm Normal file
View File

@ -0,0 +1,6 @@
(define print-it
(lambda ()
(display '(1 2 3))
(newline)
(print-it)))

6
examples/args1.scm Normal file
View File

@ -0,0 +1,6 @@
;; not enough arguments
(define p (lambda (x y) (+ x y)))
(p 6)

6
examples/args2.scm Normal file
View File

@ -0,0 +1,6 @@
;; too many arguments
(define p (lambda (x y) (+ x y)))
(p 6 7 8)

1
examples/browse.scm
View File

@ -7,7 +7,6 @@
(reduce + 0 '(2 3 4))
(define factit
(lambda (n)
(letrec

33
examples/eval.scm Normal file
View File

@ -0,0 +1,33 @@
(define primes
(eval
;;; 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)

56
examples/eval1.scm Normal file
View File

@ -0,0 +1,56 @@
(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))))
(let ((ev (eval '(iter (+ 1 q)))))
ev))))))
(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)

3
examples/library.scm
View File

@ -107,3 +107,6 @@
(map-over-single-list car lists))
(apply for-each
(cons proc (map-over-single-list cdr lists)))))))
(define pow (lambda (x y) (exp (* y (log x)))))

37
examples/mandel.scm Normal file
View File

@ -0,0 +1,37 @@
;; mandelbrot set
(define mandel
(lambda (rmin rmax imin imax res)
(letrec
((rdelta (- rmax rmin)) (idelta (- imax imin))
(rdelta1 (/ rdelta res)) (idelta1 (/ idelta res))
(pcolor
(lambda (re im cre cim n)
(if (or (> n 200) (> (+ (* re re) (* im im)) 4.0))
(let
((c (* 8 (remainder n 8)))
(x (* res (/ (- cre rmin) rdelta)))
(y (* res (/ (- cim imin) idelta))))
(draw-color
(* 255 (remainder n 2))
(* 255 (remainder (quotient n 2) 2))
(* 255 (remainder (quotient n 4) 2)))
(draw-move x y)
(draw-line (+ x 1) (+ y 1)))
(pcolor
(+ (- (* re re) (* im im)) cre)
(+ (* 2 re im) cim)
cre cim (+ 1 n)))))
(iter
(lambda (rep imp)
(if (> rep rmax)
(if (> imp imax) '()
(iter rmin (+ imp idelta1)))
(begin
(pcolor 0 0 rep imp 0)
(iter (+ rep rdelta1) imp))))))
(iter rmin imin))))
(mandel -1.5 0.5 -1.0 1.0 25)

8
examples/parse-error.scm Normal file
View File

@ -0,0 +1,8 @@
;; missing parenthesis
(define adder
(lambda (a)
(lambda (b)
(+ a b)))

55
examples/parse-error1.scm Normal file
View File

@ -0,0 +1,55 @@
(define pi (* 2 (acos 0)))
(define res 200)
(define data
(letrec
((delta (/ (* 2 pi) res))
(vect (make-vector res))
(iter extra-sym
(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)

28
examples/parse-error2.scm Normal file
View File

@ -0,0 +1,28 @@
(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))
(^ test)
(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)

6
examples/parse-error3.scm Normal file
View File

@ -0,0 +1,6 @@
(define testcond
(lambda (l)
(cond
((assq 'a l) => (lambda (p) (set-car! p 'd)))
((assq 'b l) extra-sym => (lambda (p) (set-car! p 'e)))
((assq 'c l) => (lambda (p) (set-car! p 'f))))))

6
examples/parse-error4.scm Normal file
View File

@ -0,0 +1,6 @@
;; an if with three alternatives
(if (zero? 4) 'a 'b 'c)
;; end

49
examples/plotfancy.scm Normal file
View File

@ -0,0 +1,49 @@
(define plotter
(lambda (fx res x1 x2 y1 y2)
(let* ((dx (- x2 x1)) (dy (- y2 y1)) (delta (/ dx res))
(fstr (format "~a" fx))
(f (eval (list 'lambda '(x) fx))))
(letrec
((scaled
(lambda (f x y)
(f
(* res (/ (- x x1) dx))
(* res (/ (- y y1) dy)))))
(scaled-d
(lambda (f x y xd yd)
(f
(+ xd (* res (/ (- x x1) dx)))
(+ yd (* res (/ (- y y1) dy))))))
(plotit
(lambda (x)
(scaled draw-line x (f x))
(if (< x x2) (plotit (+ x delta))))))
(draw-color 0 0 0)
(draw-font "Helvetica" 12)
(scaled draw-move 0 (* 1.1 y2)) (draw-string "y")
(scaled draw-move (* 1.1 x2) 0) (draw-string "x")
(draw-move
(- (/ res 2)
(/ (car (string-size fstr "Helvetica" 12)) 2))
(+ 30 res))
(draw-string (format "~a" fstr))
(scaled draw-move 0 y1)
(scaled draw-line 0 y2)
(scaled-d draw-move 0 y2 -5 -7)
(scaled draw-line 0 y2)
(scaled-d draw-move 0 y2 +5 -7)
(scaled draw-line 0 y2)
(scaled draw-move x1 0)
(scaled draw-line x2 0)
(scaled-d draw-move x2 0 -7 -5)
(scaled draw-line x2 0)
(scaled-d draw-move x2 0 -7 +5)
(scaled draw-line x2 0)
(draw-color 255 0 0)
(scaled draw-move x1 (f x1))
(plotit x1)))))
(plotter '(* x x x) 70 -5.0 5.0 -50.0 50.0)
(plotter '(sin x) 50 -5.0 5.0 -1.0 1.0)
(plotter '(* x (sin x)) 100 -25.0 25.0 -25.0 25.0)
(plotter '(+ (* x x) (* -5 x) 6) 80 -1.0 5.0 -3.0 10.0)

143
examples/qsort.scm Normal file
View File

@ -0,0 +1,143 @@
(define allperms
(lambda (n)
(if (= n 1) '((1))
(letrec
((allpos (list-n n))
(insert
(lambda (pos el l)
(if (= pos 1)
(cons el l)
(cons (car l)
(insert (- pos 1) el (cdr l))))))
(result '()))
(for-each
(lambda (p)
(for-each
(lambda (pos)
(set!
result
(cons
(insert pos n p) result)))
allpos))
(allperms (- n 1)))
result))))
(define make-cmp
(lambda ()
(let ((count 0))
(lambda (what . args)
(case what
((count) count)
((cmp)
(begin
(set! count (+ 1 count))
(< (car args) (cadr args)))))))))
(define qsort
(lambda (perm compare)
(if (null? perm) '()
(if (null? (cdr perm)) perm
(letrec
((pivot (car perm))
(left '()) (leftend '())
(right '()) (rightend '())
(split
(lambda (l)
(if (compare 'cmp (car l) pivot)
(if (null? leftend)
(begin
(set! left (list (car l)))
(set! leftend left))
(begin
(set-cdr! leftend (list (car l)))
(set! leftend (cdr leftend))))
(if (null? rightend)
(begin
(set! right (list (car l)))
(set! rightend right))
(begin
(set-cdr! rightend (list (car l)))
(set! rightend (cdr rightend)))))
(if (not (null? (cdr l))) (split (cdr l))))))
(split (cdr perm))
(append
(qsort left compare)
(list pivot)
(qsort right compare)))))))
(define qsort-stats
(lambda (n)
(map
(lambda (p)
(let ((c (make-cmp)))
(qsort p c)
(c 'count)))
(allperms n))))
(define ints2hist
(lambda (l)
(let* ((minv (apply min l))
(maxv (apply max l))
(v (make-vector (+ 1 (- maxv minv)) 0)))
(letrec
((iter
(lambda (l)
(if (not (null? l))
(begin
(vector-set!
v (- (car l) minv)
(+ 1 (vector-ref v (- (car l) minv))))
(iter (cdr l)))))))
(iter l)
(map
(lambda (pos)
(cons pos (vector-ref v (- pos minv))))
(make-range minv maxv))))))
(define drawhist
(lambda (h)
(letrec
((len (length h)) (total (* 1.0 (apply + (map cdr h))))
(mx (apply max (map cdr h))) (scale 400)
(colors
(list->vector
'((0 0 255) (0 255 0) (0 255 255)
(255 0 0) (255 0 255) (255 255 0))))
(bars
(lambda (pos h)
(let ((frac (/ (cdar h) total)))
(apply draw-color (vector-ref colors (remainder pos 6)))
(draw-move (* pos 40) 0)
(fill-rect 30 (* scale frac))
(if (not (null? (cdr h)))
(bars (+ 1 pos) (cdr h))))))
(labels
(lambda (pos h)
(draw-move (* pos 40) -20)
(draw-string (format "~a" (caar h)))
(if (not (null? (cdr h)))
(labels (+ 1 pos) (cdr h)))))
(values
(lambda (pos h)
(let ((frac (/ (cdar h) total)))
(draw-move (* pos 40) (+ 10 (* scale frac)))
(draw-string (format "~a" (cdar h)))
(if (not (null? (cdr h)))
(values (+ 1 pos) (cdr h)))))))
(bars 0 h)
(draw-color 0 0 0)
(labels 0 h)
(values 0 h)
(draw-move -40 0) (draw-line (* (+ 1 len) 40) 0)
(draw-move -20 -20) (draw-line -20 (* scale (/ mx total))))))
(define qhist
(lambda (n)
(drawhist (ints2hist (qsort-stats n)))))
(qhist 6)

181
examples/qsort1.scm Normal file
View File

@ -0,0 +1,181 @@
(define fact
(lambda (n)
(if (zero? n) 1
(* n (fact (- n 1))))))
(define allperms
(lambda (n)
(let ((f (fact n))
(res '()) (rm -1) (perm '()))
(letrec
((remove
(lambda (l pos)
(if (zero? pos)
(begin
(set! rm (car l))
(remove (cdr l) (- pos 1)))
(if (null? l) l
(cons (car l) (remove (cdr l) (- pos 1)))))))
(process
(lambda (v m dst src)
(if (zero? m)
(set! perm dst)
(let ((src1 (remove src (remainder v m))))
(process
(quotient v m)
(- m 1)
src1
(cons dst rm))))))
(iter
(lambda (v)
(if (< v f)
(begin
(process v n '() (make-range 1 n))
(set! res (cons perm res))
(iter (+ v 1)))))))
(iter 0) res))))
(define allperms
(lambda (n)
(if (= n 1) '((1))
(letrec
((allpos (list-n n))
(insert
(lambda (pos el l)
(if (= pos 1)
(cons el l)
(cons (car l)
(insert (- pos 1) el (cdr l))))))
(result '()))
(for-each
(lambda (p)
(for-each
(lambda (pos)
(set!
result
(cons
(insert pos n p) result)))
allpos))
(allperms (- n 1)))
result))))
(define make-cmp
(lambda ()
(let ((count 0))
(lambda (what . args)
(case what
((count) count)
((cmp)
(begin
(set! count (+ 1 count))
(< (car args) (cadr args)))))))))
(define qsort
(lambda (perm compare)
(if (null? perm) '()
(if (null? (cdr perm)) perm
(letrec
((pivot (car perm))
(left '()) (leftend '())
(right '()) (rightend '())
(split
(lambda (l)
(if (compare 'cmp (car l) pivot)
(if (null? leftend)
(begin
(set! left (list (car l)))
(set! leftend left))
(begin
(set-cdr! leftend (list (car l)))
(set! leftend (cdr leftend))))
(if (null? rightend)
(begin
(set! right (list (car l)))
(set! rightend right))
(begin
(set-cdr! rightend (list (car l)))
(set! rightend (cdr rightend)))))
(if (not (null? (cdr l))) (split (cdr l))))))
(split (cdr perm))
(append
(qsort left compare)
(list pivot)
(qsort right compare)))))))
(define qsort-stats
(lambda (n)
(map
(lambda (p)
(let ((c (make-cmp)))
(qsort p c)
(c 'count)))
(allperms n))))
(define ints2hist
(lambda (l)
(let* ((minv (apply min l))
(maxv (apply max l))
(v (make-vector (+ 1 (- maxv minv)) 0)))
(letrec
((iter
(lambda (l)
(if (not (null? l))
(begin
(vector-set!
v (- (car l) minv)
(+ 1 (vector-ref v (- (car l) minv))))
(iter (cdr l)))))))
(iter l)
(map
(lambda (pos)
(cons pos (vector-ref v (- pos minv))))
(make-range minv maxv))))))
(define drawhist
(lambda (h)
(letrec
((len (length h)) (total (* 1.0 (apply + (map cdr h))))
(mx (apply max (map cdr h))) (scale 400)
(colors
(list->vector
'((0 0 255) (0 255 0) (0 255 255)
(255 0 0) (255 0 255) (255 255 0))))
(bars
(lambda (pos h)
(let ((frac (/ (cdar h) total)))
(apply draw-color (vector-ref colors (remainder pos 6)))
(draw-move (* pos 40) 0)
(fill-rect 30 (* scale frac))
(if (not (null? (cdr h)))
(bars (+ 1 pos) (cdr h))))))
(labels
(lambda (pos h)
(draw-move (* pos 40) -20)
(draw-string (format "~a" (caar h)))
(if (not (null? (cdr h)))
(labels (+ 1 pos) (cdr h)))))
(values
(lambda (pos h)
(let ((frac (/ (cdar h) total)))
(draw-move (* pos 40) (+ 10 (* scale frac)))
(draw-string (format "~a" (cdar h)))
(if (not (null? (cdr h)))
(values (+ 1 pos) (cdr h)))))))
(bars 0 h)
(draw-color 0 0 0)
(labels 0 h)
(values 0 h)
(draw-move -40 0) (draw-line (* (+ 1 len) 40) 0)
(draw-move -20 -20) (draw-line -20 (* scale (/ mx total))))))
(define qhist
(lambda (n)
(drawhist (ints2hist (qsort-stats n)))))
(qhist 6)

98
examples/queenspic.scm Normal file
View File

@ -0,0 +1,98 @@
(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 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 queenspic
(lambda (n)
(let* ((scale 30) (radius (/ scale 3)))
(for-each
(lambda (sol)
(letrec
((drawqueens
(lambda (pos sol)
(if (not (null? sol))
(begin
(draw-move pos (- (* (car sol) scale) (/ scale 2)))
(fill-circle radius)
(drawqueens (+ pos scale) (cdr sol))))))
(drawlines
(lambda (m)
(draw-move 0 (* m scale))
(draw-line (* n scale) (* m scale))
(draw-move (* m scale) 0)
(draw-line (* m scale) (* n scale))
(if (not (zero? m))
(drawlines (- m 1))))))
(draw-color 255 0 0)
(drawqueens 15 sol)
(draw-color 0 0 0)
(drawlines n)
(draw-show)))
(queens n)))))
(queenspic 5)

17
examples/randcircles.scm Normal file
View File

@ -0,0 +1,17 @@
(define randcircles
(lambda (n rmax lmax)
(let
((x (random lmax)) (y (random lmax))
(fill (random 2))
(radius (+ (/ rmax 2) (random (/ rmax 2)))))
(draw-color
(random 256)
(random 256)
(random 256))
(draw-move x y)
((if (zero? fill) draw-circle fill-circle) radius)
(if (not (zero? n))
(randcircles (- n 1) rmax lmax)))))
(randcircles 25 30 250)

28
examples/random.scm Normal file
View File

@ -0,0 +1,28 @@
(define randpoints
(lambda (count)
(letrec
((scale 20)
(points
(lambda (n)
(draw-move
(* (- count n) scale)
(* scale (random count)))
(fill-circle (/ scale 2))
(if (not (zero? n))
(points (- n 1)))))
(grid
(lambda (n)
(draw-move 0 (* scale n))
(draw-line (* scale count) (* scale n))
(if (not (zero? n))
(grid (- n 1))))))
(grid count)
(draw-move 0 0)
(draw-color 255 255 0)
(points count))))
(randpoints 15)
(randpoints 15.0)

18
examples/randrects.scm Normal file
View File

@ -0,0 +1,18 @@
(define randrects
(lambda (n rmax lmax)
(let
((x (random lmax)) (y (random lmax))
(fill (random 2))
(a (+ (/ rmax 2) (random (/ rmax 2))))
(b (+ (/ rmax 2) (random (/ rmax 2)))))
(draw-color
(random 256)
(random 256)
(random 256))
(draw-move x y)
((if (zero? fill) draw-rect fill-rect) a b)
(if (not (zero? n))
(randrects (- n 1) rmax lmax)))))
(randrects 25 60 250)

119
examples/strings.scm Normal file
View File

@ -0,0 +1,119 @@
(integer->char -20)
(integer->char 270)
(char->integer #\N)
(char->integer #\+)
(char->integer #\#)
(define table
(lambda (n)
(if (< n 128)
(begin
(display n) (display " ")
(display (integer->char n)) (display " ")
(display (char->integer (integer->char n)))
(newline)
(table (+ n 1))))))
(table 32)
(list->string '())
(list->string '(#\a #\b #\c))
(list->string '(#\a #\b . #\c))
(define test1
(lambda (n)
(let ((str
(list->string
(map
(lambda (pos)
(integer->char
(+ (char->integer #\A) pos -1)))
(reverse (list-n n))))))
(map
(lambda (pos)
(string-ref str (- pos 1)))
(reverse (list-n n))))))
(test1 5)
(test1 10)
(test1 20)
(define randletters
(lambda (n)
(if (zero? n) '()
(cons
(integer->char
(+ (char->integer #\A) (random 26)))
(randletters (- n 1))))))
(define test2
(lambda (len)
(let* ((r (randletters len))
(s (list->string r)))
(display r) (display " ")
(display s) (display " ")
(display (string->list s)) (newline))))
(test2 5)
(test2 10)
(test2 20)
(string-append)
(apply string-append
(map symbol->string '(one two three four five)))
(make-string 0)
(string->list (make-string 5))
(string->list (make-string 15))
(define test3
(lambda (len)
(if (zero? len) ""
(string-append
(make-string len)
(make-string
len
(integer->char
(+ (char->integer #\a) len -1)))
(test3 (- len 1))))))
(test3 1)
(test3 5)
(test3 7)
(number->string 123.456e7)
(number->string 678.456)
(map number->string (list-n 30))
(define test4
(lambda (base)
(map
(lambda (n)
(number->string n base))
(reverse (list-n 30)))))
(test4 2)
(test4 3)
(test4 8)
(test4 10)
(test4 12)
(test4 16)
(define test5
(lambda (base)
(map
(lambda (n)
(number->string (+ (- n) 1) base))
(reverse (list-n 30)))))
(test5 2)
(test5 3)
(test5 8)
(test5 10)
(test5 12)
(test5 16)

31
examples/text.scm Normal file
View File

@ -0,0 +1,31 @@
;; show some text
(define text
(lambda (fsclist)
(for-each
(lambda (fsc)
(let
((font (car fsc))
(size (cadr fsc))
(color (caddr fsc))
(pos 0))
(apply draw-color color)
(draw-font font size)
(for-each
(lambda (word)
(let ((dim (string-size word font size)))
(draw-move (- (/ (car dim) 2.0)) (* pos (cdr dim)))
(draw-string word)
(set! pos (- pos 1))))
(map
symbol->string
'(The quick brown fox jumps over the lazy dog)))
(draw-show))) fsclist)))
(text
'(("Courier" 36 (255 0 0))
("Helvetica-Bold" 24 (0 255 0))
("Lucida-Italic-Sans" 18 (0 0 255))))

1939
lex.yy.c
View File

File diff suppressed because it is too large Load Diff

2
scheme.flex
View File

@ -180,7 +180,7 @@ STRING "\""([^\n\"\\]|"\\\\"|"\\\"")*"\""
}
{STRING} {
yylval = [[String alloc] initSCMString:yytext];
yylval = [[String alloc] initSCMStringLEX:yytext];
yysofar += yyleng; return STRING;
}

2
scheme.lex.m
View File

@ -996,7 +996,7 @@ case 29:
YY_RULE_SETUP
#line 182 "scheme.flex"
{
yylval = [[String alloc] initSCMString:yytext];
yylval = [[String alloc] initSCMStringLEX:yytext];
yysofar += yyleng; return STRING;
}
YY_BREAK

1108
scheme.tab.m
View File

File diff suppressed because it is too large Load Diff

160
scheme.y
View File

@ -5,9 +5,10 @@
YYSTYPE yyresult;
int yyinputitem;
id yyresultform;
extern int yysofar;
extern NSMutableArray *positions;
extern NSMutableArray *positionStack;
%}
%token LPAREN
@ -53,12 +54,13 @@ extern NSMutableArray *positions;
%%
top: /* empty */ {
yyresult =
$$ = [NSNull null];
yyresultform = $$;
}
| topitem top {
yyresult =
$$ = [Triple newTag:FORM_TOP Arg1:$1 Arg2:$2];
yyresultform = $$;
yyinputitem++;
}
;
@ -69,7 +71,7 @@ topitem: LPAREN DEFINE SYMBOL form RPAREN {
$$ = [Triple newTag:FORM_DEFINE1 Arg1:$3 Arg2:$4];
[positions addObject:entry];
[[positionStack lastObject] addObject:entry];
}
| LPAREN DEFINE nonemptysymlist sequence RPAREN {
NSValue *entry =
@ -77,7 +79,7 @@ topitem: LPAREN DEFINE SYMBOL form RPAREN {
$$ = [Triple newTag:FORM_DEFINE2 Arg1:$3 Arg2:$4];
[positions addObject:entry];
[[positionStack lastObject] addObject:entry];
}
| form {
NSValue *entry =
@ -85,7 +87,7 @@ topitem: LPAREN DEFINE SYMBOL form RPAREN {
$$ = $1;
[positions addObject:entry];
[[positionStack lastObject] addObject:entry];
}
;
@ -105,6 +107,87 @@ revsequence: form {
}
;
qform: INTEGER {
$$ = $1;
}
| CHAR {
$$ = $1;
}
| BOOLEAN {
$$ = $1;
}
| DOUBLE {
$$ = $1;
}
| SYMBOL {
$$ = $1;
}
| STRING {
$$ = $1;
}
| qlist {
$$ = $1;
}
| qvector {
$$ = $1;
}
| QUOTECHAR qform {
$$ = [Pair newCar:[[Symbol alloc] initSCMSymbol:"quote"]
Cdr:[Pair newCar:$2 Cdr:[NSNull null]]];
}
| ARROW {
$$ = [[Symbol alloc] initSCMSymbol:"=>"];
}
| QUOTE {
$$ = [[Symbol alloc] initSCMSymbol:"quote"];
}
| CALLCC {
$$ = [[Symbol alloc] initSCMSymbol:"call-with-current-continuation"];
}
| APPLY {
$$ = [[Symbol alloc] initSCMSymbol:"apply"];
}
| DEFINE {
$$ = [[Symbol alloc] initSCMSymbol:"define"];
}
| SET {
$$ = [[Symbol alloc] initSCMSymbol:"set!"];
}
| LAMBDA {
$$ = [[Symbol alloc] initSCMSymbol:"lambda"];
}
| IF {
$$ = [[Symbol alloc] initSCMSymbol:"if"];
}
| BEGINTOK {
$$ = [[Symbol alloc] initSCMSymbol:"begin"];
}
| AND {
$$ = [[Symbol alloc] initSCMSymbol:"and"];
}
| OR {
$$ = [[Symbol alloc] initSCMSymbol:"or"];
}
| CASE {
$$ = [[Symbol alloc] initSCMSymbol:"case"];
}
| COND {
$$ = [[Symbol alloc] initSCMSymbol:"cond"];
}
| ELSE {
$$ = [[Symbol alloc] initSCMSymbol:"else"];
}
| LET {
$$ = [[Symbol alloc] initSCMSymbol:"let"];
}
| LETSTAR {
$$ = [[Symbol alloc] initSCMSymbol:"let*"];
}
| LETREC {
$$ = [[Symbol alloc] initSCMSymbol:"letrec"];
}
;
form: INTEGER {
$$ = $1;
}
@ -171,14 +254,17 @@ form: INTEGER {
| 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];
@ -189,10 +275,12 @@ singlecond: LPAREN form RPAREN {
| 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]];
@ -217,6 +305,7 @@ case: LPAREN CASE form cases RPAREN {
$$ = [Triple newTag:FORM_CASE Arg1:$3
Arg2:[Pair newCar:$5 Cdr:$4]];
}
;
cond: LPAREN COND conditions RPAREN {
$$ = [Triple newTag:FORM_COND Arg1:$3];
@ -224,6 +313,7 @@ cond: LPAREN COND conditions RPAREN {
| 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];
@ -231,6 +321,7 @@ and: LPAREN AND revsequence RPAREN {
| LPAREN AND RPAREN {
$$ = [Triple newTag:FORM_AND Arg1:[NSNull null]];
}
;
or: LPAREN OR revsequence RPAREN {
$$ = [Triple newTag:FORM_OR Arg1:$3];
@ -238,18 +329,22 @@ or: LPAREN OR revsequence RPAREN {
| 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];
@ -257,6 +352,7 @@ if: LPAREN IF form form RPAREN {
| 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];
@ -264,18 +360,20 @@ lambda: LPAREN LAMBDA SYMBOL sequence RPAREN {
| LPAREN LAMBDA symlist sequence RPAREN {
$$ = [Triple newTag:FORM_LAMBDA2 Arg1:$3 Arg2:$4];
}
;
quote: QUOTECHAR form {
quote: QUOTECHAR qform {
$$ = [Triple newTag:FORM_QUOTE Arg1:$2];
}
| LPAREN QUOTE form RPAREN {
| LPAREN QUOTE qform 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]];
@ -283,18 +381,22 @@ listofbindings: singlebinding {
| 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];
@ -312,6 +414,17 @@ nonemptylistdata: form {
}
;
qnonemptylistdata: qform {
$$ = [Pair newCar:$1 Cdr:[NSNull null]];
}
| qform DOT qform {
$$ = [Pair newCar:$1 Cdr:$3];
}
| qform qnonemptylistdata {
$$ = [Pair newCar:$1 Cdr:$2];
}
;
nonemptyvectdata: form {
$$ = [Pair newCar:$1 Cdr:[NSNull null]];
}
@ -320,11 +433,24 @@ nonemptyvectdata: form {
}
;
qnonemptyvectdata: qform {
$$ = [Pair newCar:$1 Cdr:[NSNull null]];
}
| qform qnonemptyvectdata {
$$ = [Pair newCar:$1 Cdr:$2];
}
;
nonemptylist: LPAREN nonemptylistdata RPAREN {
$$ = $2;
}
;
qnonemptylist: LPAREN qnonemptylistdata RPAREN {
$$ = $2;
}
;
list: nonemptylist {
$$ = $1;
}
@ -333,6 +459,14 @@ list: nonemptylist {
}
;
qlist: qnonemptylist {
$$ = $1;
}
| emptylist {
$$ = $1;
}
;
vector: LVECTPAREN nonemptyvectdata RPAREN {
$$ = [Vector newFromList:$2];
}
@ -341,6 +475,14 @@ vector: LVECTPAREN nonemptyvectdata RPAREN {
}
;
qvector: LVECTPAREN qnonemptyvectdata RPAREN {
$$ = [Vector newFromList:$2];
}
| LVECTPAREN RPAREN {
$$ = [Vector newFromList:(Pair *)[NSNull null]];
}
;
nonemptysymlistdata: SYMBOL {
$$ = [Pair newCar:$1 Cdr:[NSNull null]];
}