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

GScheme-20020806.tar

This commit is contained in:
Lassi Kortela 2022-08-05 12:28:40 +03:00
commit 81e8afedce
74 changed files with 16718 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
Document.h Normal file
View File

@ -0,0 +1,53 @@
/* Document.h Subclass of NSDocument for GScheme application
Copyright (C) 2000 Free Software Foundation, Inc.
Author: Fred Kiefer <fredkiefer@gmx.de>
Date: 2000.
Adapted by: Marko Riedel <mriedel@neuearbeit.de>.
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 <Foundation/NSData.h>
#import <Foundation/NSAttributedString.h>
#import <AppKit/NSDocument.h>
#import <AppKit/NSTextView.h>
@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

237
Document.m Normal file
View File

@ -0,0 +1,237 @@
/* Document.m Subclass of NSDocument for GScheme application
Copyright (C) 2000 Free Software Foundation, Inc.
Author: Fred Kiefer <fredkiefer@gmx.de>
Date: 2000.
Adapted by: Marko Riedel <mriedel@neuearbeit.de>.
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 <AppKit/AppKit.h>
#include <AppKit/NSWindowController.h>
#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

24
EnvWindow.h Normal file
View File

@ -0,0 +1,24 @@
#import <Foundation/Foundation.h>
#import <AppKit/AppKit.h>
#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

134
EnvWindow.m Normal file
View File

@ -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<length; ind++){
// NSLog(@"%@ %d %d\n", self, ind, [forms[ind] retainCount]);
[forms[ind] release];
}
NSZoneFree([self zone], forms);
return self;
}
@end

37
GNUmakefile Normal file
View File

@ -0,0 +1,37 @@
GNUSTEP_INSTALLATION_DIR = $(GNUSTEP_SYSTEM_ROOT)
GNUSTEP_MAKEFILES = $(GNUSTEP_SYSTEM_ROOT)/Makefiles
include $(GNUSTEP_MAKEFILES)/common.make
# The application to be compiled
APP_NAME = GScheme
# The Objective-C source files to be compiled
GScheme_OBJC_FILES = SchemeTypes.m \
Primitive.m \
VScheme.m \
Document.m \
EnvWindow.m \
SCMTextView.m \
scheme.lex.m \
scheme.tab.m \
SchemeDelegate.m \
main.m
SHARED_CFLAGS += -g
AUXILIARY_TOOL_LIBS += -lfl
# The Resource files to be copied into the app's resources directory
GScheme_RESOURCE_FILES = Scheme/*
-include GNUmakefile.preamble
-include GNUmakefile.local
include $(GNUSTEP_MAKEFILES)/application.make
-include GNUmakefile.postamble

218
GScheme.app/GScheme Executable file
View File

@ -0,0 +1,218 @@
#!/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 Normal file
View File

@ -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=

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

@ -0,0 +1,29 @@
{
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 Normal file
View File

@ -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)))))))

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

@ -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)))))))

19
GSchemeInfo.plist Normal file
View File

@ -0,0 +1,19 @@
{
ApplicationName = "GScheme";
ApplicationDescription = "A scheme interpreter";
ApplicationRelease = "GScheme 0.1";
FullVersionID = "0.1, June 2002";
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";
NSTypes = (
{
NSName = "scm";
NSHumanReadableName = "Scheme program";
NSUnixExtensions = ("scm");
NSDOSExtensions = ("scm");
NSRole = Editor;
NSDocumentClass = Document;
}
);
}

249
Primitive.h Normal file
View File

@ -0,0 +1,249 @@
#import <Foundation/Foundation.h>
#import <AppKit/AppKit.h>
#import <math.h>
#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

1566
Primitive.m Normal file
View File

File diff suppressed because it is too large Load Diff

31
SCMTextView.h Normal file
View File

@ -0,0 +1,31 @@
#import <Foundation/Foundation.h>
#import <AppKit/AppKit.h>
#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

155
SCMTextView.m Normal file
View File

@ -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<max &&
[charset characterIsMember:
(ch = [data characterAtIndex:(pos+len)])]){
single = [[NSString alloc] initWithCharacters:&ch length:1];
modified = [modified stringByAppendingString:single];
// [single autorelease];
len++;
}
return [super insertText:modified];
}
}
else if(inslen==1 && ch==NSTabCharacter){
ch = ' ';
single = [[NSString alloc] initWithCharacters:&ch length:1];
modified = [modified stringByAppendingString:single];
modified = [modified stringByAppendingString:single];
// [single autorelease];
return [super insertText:modified];
}
return [super insertText:aString];
}
@end
@implementation SCMInteractive
- (id)initWithFrame:(NSRect)frameRect
{
lastRetrieved = 0;
return [super initWithFrame:frameRect];
}
- (void)insertText:(id)aString
{
if([self selectedRange].location<lastRetrieved){
return;
}
[super insertText:aString];
}
- placeCursorAtEnd
{
NSRange range = { [[self string] length], 0 };
[self setSelectedRange:range];
return self;
}
- (NSString *)getSuffix
{
NSString *str = [super string];
NSString *suffix = [str substringFromIndex:lastRetrieved];
lastRetrieved = [str length];
return suffix;
}
- (void)setString:(NSString *)aString
{
lastRetrieved = [aString length];
[super setString:aString];
}
- (void)appendString:(NSString *)aString
{
unsigned int len = [[super string] length];
NSRange range = {len, 0};
lastRetrieved += [aString length];
[self replaceCharactersInRange:range withString:aString];
}
- (void)keyDown:(NSEvent *)theEvent
{
NSString *chars = [theEvent characters];
unsigned modifiers = [theEvent modifierFlags];
int len = [chars length];
unichar ch = [chars characterAtIndex:0];
BOOL rep = [theEvent isARepeat];
if((ch==NSNewlineCharacter || ch==NSCarriageReturnCharacter) &&
len==1 && (modifiers & NSControlKeyMask)){
BOOL res = [[self delegate] processString:[self getSuffix]
mode:MODE_INTERACTIVE];
if(res==NO){
NSRunAlertPanel(@"Error", [[self delegate] errmsg],
@"Ok", nil, nil);
}
return;
}
else if(ch==NSBackspaceCharacter &&
(len==1 || rep==YES) &&
[self selectedRange].location<lastRetrieved+len){
NSBeep();
return;
}
else if(ch==NSDeleteFunctionKey &&
(len==1 || rep==YES) &&
[self selectedRange].location<lastRetrieved){
NSBeep();
return;
}
return [super keyDown:theEvent];
}
- (void)delete:(id)sender
{
NSRange range = [self rangeForUserTextChange];
if(range.location != NSNotFound &&
range.location >= lastRetrieved){
[super delete:sender];
}
else{
NSBeep();
}
}
@end

109
Scheme/library.scm Normal file
View File

@ -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)))))))

103
Scheme/library.scm~ Normal file
View File

@ -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)))))))

39
SchemeDelegate.h Normal file
View File

@ -0,0 +1,39 @@
#import <Foundation/Foundation.h>
#import <AppKit/AppKit.h>
#import <AppKit/NSDocumentController.h>
#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

462
SchemeDelegate.m Normal file
View File

@ -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

316
SchemeTypes.h Normal file
View File

@ -0,0 +1,316 @@
#import <Foundation/Foundation.h>
#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
{
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

864
SchemeTypes.m Normal file
View File

@ -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:&current];
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<count; index++){
id obj = data[index];
if(MARKABLE(obj)){
[obj setMarkToCurrent];
}
}
return self;
}
- (void)free
{
NSZoneFree([self zone], data);
[super free];
}
@end
@implementation Closure
+ newArgs:(id)argsval Body:(id)codes Env:(id)envval
{
return [[super alloc]
initArgs:argsval Body:codes Env:envval];
}
- initArgs:(id)argsval Body:(id)codes Env:(id)envval
{
[super init];
args = argsval; [args retain];
body = codes; [body retain];
env = envval; [env retain];
return self;
}
- args
{
return args;
}
- body
{
return body;
}
- env
{
return env;
}
- setMarkToCurrent
{
if([self mark]==currentMark){
return;
}
[super setMarkToCurrent];
if(MARKABLE(args)){
[args setMarkToCurrent];
}
if(MARKABLE(body)){
[body setMarkToCurrent];
}
if(MARKABLE(env)){
[env setMarkToCurrent];
}
return self;
}
@end
@implementation Thunk
+ newArgp:(int)argpval Envp:(int)envpval Codep:(int)codepval
{
return [[super alloc]
initArgp:argpval Envp:envpval Codep:codepval];
}
- initArgp:(int)argpval Envp:(int)envpval Codep:(int)codepval
{
argp = argpval;
envp = envpval;
codep = codepval;
return self;
}
- (int)argp
{
return argp;
}
- setArgp:(int)argpval
{
argp = argpval;
return self;
}
- (int)envp
{
return envp;
}
- setEnvp:(int)envpval
{
envp = envpval;
return self;
}
- (int)codep
{
return codep;
}
- setCodep:(int)codepval
{
codep = codepval;
return self;
}
@end
@implementation Environment
+ newParent:(Environment *)par Data:(NSMutableDictionary *)entries
{
return [[super alloc]
initParent:par Data:entries];
}
- initParent:(Environment *)par Data:(NSMutableDictionary *)entries
{
[super init];
parent = par;
[parent retain];
data = entries; // [entries mutableCopy];
[data retain];
return self;
}
- (int)chainLength
{
return (parent==nil ? 1 : 1+[parent chainLength]);
}
- (NSMutableDictionary *)lookup:(NSString *)sym
{
if([data objectForKey:sym]!=nil){
return data;
}
return (parent==nil ? nil : [parent lookup:sym]);
}
- (Environment *)parent
{
return parent;
}
- (NSMutableDictionary *)data
{
return data;
}
- setMarkToCurrent
{
NSEnumerator *enumerator = [data objectEnumerator];
id item;
if([self mark]==currentMark){
return;
}
[super setMarkToCurrent];
while((item = [enumerator nextObject])!=nil){
if(MARKABLE(item)){
[item setMarkToCurrent];
}
}
if(MARKABLE(parent)){
[parent setMarkToCurrent];
}
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];
}
[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; index++){
id obj = [data objectAtIndex:index];
if(MARKABLE(obj)){
[obj setMarkToCurrent];
}
}
return self;
}
@interface GSMutableArray : NSMutableArray
{
@public
id *_contents_array;
unsigned _count;
unsigned _capacity;
int _grow_factor;
}
@end
typedef struct {
@defs(GSMutableArray)
} *GSMArrayPtr;
- (void)free
{
((GSMArrayPtr)data)->_count = 0;
while([data retainCount]>1){
[data release];
}
[super free];
}
@end

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

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

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

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

218
TestScheme.app/TestScheme Executable file
View File

@ -0,0 +1,218 @@
#!/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 "$@"

40
USAGE Normal file
View File

@ -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.

120
VScheme.h Normal file
View File

@ -0,0 +1,120 @@
#import <Foundation/Foundation.h>
#import <AppKit/AppKit.h>
#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

1722
VScheme.m Normal file
View File

File diff suppressed because it is too large Load Diff

23
examples/allocate.scm Normal file
View File

@ -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)

10
examples/and-or.scm Normal file
View File

@ -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))

35
examples/browse.scm Normal file
View File

@ -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) '()))

11
examples/call-cc.scm Normal file
View File

@ -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)))

15
examples/call-cc1.scm Normal file
View File

@ -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)

13
examples/case.scm Normal file
View File

@ -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))

15
examples/characters.scm Normal file
View File

@ -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)))

55
examples/circle.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
(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)

19
examples/circular.scm Normal file
View File

@ -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

28
examples/cond.scm Normal file
View File

@ -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

11
examples/deep-recursion.scm Normal file
View File

@ -0,0 +1,11 @@
(define r
(lambda (n)
(if (= n 0) '()
(r (- n 1)))))
(r 10)
(r -10)

10
examples/eq-mem-association.scm Normal file
View File

@ -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)

16
examples/factorial.scm Normal file
View File

@ -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)

27
examples/koch-curve.scm Normal file
View File

@ -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)

3
examples/let-over-lambda.scm Normal file
View File

@ -0,0 +1,3 @@
(define count
(let ((c 0)) (lambda () (set! c (+ 1 c)) c)))
(count) (count) (count)

11
examples/letrec.scm Normal file
View File

@ -0,0 +1,11 @@
(define (a proc)
(proc 5))
(letrec
((res '()))
(a
(lambda (arg)
(if (< arg 0)
(set! res (- arg))
(set! res arg)))))

109
examples/library.scm Normal file
View File

@ -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)))))))

12
examples/list-misc.scm Normal file
View File

@ -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)

4
examples/misc.scm Normal file
View File

@ -0,0 +1,4 @@
(define (a x y . rest ) (+ x y (apply * rest)))
(a 1 2 3 4 5)

26
examples/plotter.scm Normal file
View File

@ -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)

32
examples/primes.scm Normal file
View File

@ -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)

103
examples/queens.scm Normal file
View File

@ -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))))))

8
examples/reduce.scm Normal file
View File

@ -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))

32
examples/rootfinder.scm Normal file
View File

@ -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

13
examples/simple.scm Normal file
View File

@ -0,0 +1,13 @@
(define a
(lambda (x)
(lambda (y)
(+ x y))))
(define a5 (a 5))
(define a7 (a 7))
(a5 4)
(a7 2)

7
examples/tail-recursion.scm Normal file
View File

@ -0,0 +1,7 @@
(define tailrec
(lambda (n)
(display n) (newline)
(if (= n 0) '()
(tailrec (- n 1)))))
(tailrec 5)

1939
lex.yy.c Normal file
View File

File diff suppressed because it is too large Load Diff

64
main.m Normal file
View File

@ -0,0 +1,64 @@
/* main.m: Main Body of GNUstep GScheme demo application
Copyright (C) 2000 Free Software Foundation, Inc.
Author: Fred Kiefer <fredkiefer@gmx.de>
Date: 2000.
Adapted by: Marko Riedel <mriedel@neuearbeit.de>.
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 <locale.h>
#import <stdio.h>
#import <stdlib.h>
#import <Foundation/Foundation.h>
#import <AppKit/AppKit.h>
#import <AppKit/NSDocumentController.h>
#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];
}

2562
php/scheme.php Normal file
View File

File diff suppressed because it is too large Load Diff

210
scheme.flex Normal file
View File

@ -0,0 +1,210 @@
%{
#import <Foundation/Foundation.h>
#import <AppKit/AppKit.h>
#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;
%%

1939
scheme.lex.m Normal file
View File

File diff suppressed because it is too large Load Diff

1614
scheme.tab.m Normal file
View File

File diff suppressed because it is too large Load Diff

34
scheme.tab.m.h Normal file
View File

@ -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;

369
scheme.y Normal file
View File

@ -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;
}
;
%%

18
scratch/allocate.scm Normal file
View File

@ -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)

18
scratch/allocate.scm~ Normal file
View File

@ -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)

12
test/classes.m Normal file
View File

@ -0,0 +1,12 @@
#import <Foundation/Foundation.h>
#import <AppKit/AppKit.h>
int main(int argc, char **argv)
{
void *state;
Class cl;
while((cl = objc_next_class(&state))){
NSLog(@"%@\n", NSStringFromClass(cl));
}
}

15
test/classes.m~ Normal file
View File

@ -0,0 +1,15 @@
#import <Foundation/Foundation.h>
#import <AppKit/AppKit.h>
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"]);
}

1
test/commands.txt Normal file
View File

@ -0,0 +1 @@
flex scheme.flex

26
test/compileit Executable file
View File

@ -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

26
test/compileit~ Executable file
View File

@ -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

BIN
test/sscanf Executable file
View File

Binary file not shown.

13
test/sscanf.c Normal file
View File

@ -0,0 +1,13 @@
#include <stdio.h>
#include <stdlib.h>
int main(int argc, char **argv)
{
char buf[128];
while(gets(buf)!=NULL){
double val;
sscanf(buf, "%le", &val);
printf("got %le\n", val);
}
}

15
test/test.m Normal file
View File

@ -0,0 +1,15 @@
#import <Foundation/Foundation.h>
#import <AppKit/AppKit.h>
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"]);
}

15
test/test.m~ Normal file
View File

@ -0,0 +1,15 @@
#import <Foundation/Foundation.h>
#import <AppKit/AppKit.h>
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]);
}

18
test/testschemeparser.c~ Normal file
View File

@ -0,0 +1,18 @@
/*
test scheme parser
by marko riedel, mriedel@neuearbeit.de
*/
#include <stdio.h>
#include <stdlib.h>
#include "schemenode.h"
extern scmnodeptr yylval;
int main(int argc, char **argv)
{
yyparse();
print(yylval);
}

186
testscheme.m Normal file
View File

@ -0,0 +1,186 @@
/*
test scheme parser
by marko riedel, mriedel@neuearbeit.de
*/
#include <locale.h>
#include <stdio.h>
#include <stdlib.h>
#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<indent; pos++){
putchar(' ');
}
if(item==[NSNull null]){
puts("'()");
}
else if([item isKindOfClass:[Boolean class]]){
printf("BOOL: %s\n", (![item boolVal] ? "NO" : "YES"));
}
else if([item isKindOfClass:[Char class]]){
char c = [item charVal];
if(c=='\n'){
printf("CHAR: <\\newline>\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;
}