hyung-hwan/qse
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Browse Source
This commit is contained in:
hyung-hwan
2008-06-04 02:18:55 +00:00
parent 5786cae59c
commit 8179c37c29
105 changed files with 0 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

180
ase/lib/lsp/aselsp.dsp Normal file
View File

@ -0,0 +1,180 @@
# Microsoft Developer Studio Project File - Name="aselsp" - Package Owner=<4>
# Microsoft Developer Studio Generated Build File, Format Version 6.00
# ** DO NOT EDIT **
# TARGTYPE "Win32 (x86) Static Library" 0x0104
CFG=aselsp - Win32 Debug
!MESSAGE This is not a valid makefile. To build this project using NMAKE,
!MESSAGE use the Export Makefile command and run
!MESSAGE
!MESSAGE NMAKE /f "aselsp.mak".
!MESSAGE
!MESSAGE You can specify a configuration when running NMAKE
!MESSAGE by defining the macro CFG on the command line. For example:
!MESSAGE
!MESSAGE NMAKE /f "aselsp.mak" CFG="aselsp - Win32 Debug"
!MESSAGE
!MESSAGE Possible choices for configuration are:
!MESSAGE
!MESSAGE "aselsp - Win32 Release" (based on "Win32 (x86) Static Library")
!MESSAGE "aselsp - Win32 Debug" (based on "Win32 (x86) Static Library")
!MESSAGE
# Begin Project
# PROP AllowPerConfigDependencies 0
# PROP Scc_ProjName ""
# PROP Scc_LocalPath ""
CPP=cl.exe
RSC=rc.exe
!IF "$(CFG)" == "aselsp - Win32 Release"
# PROP BASE Use_MFC 0
# PROP BASE Use_Debug_Libraries 0
# PROP BASE Output_Dir "Release"
# PROP BASE Intermediate_Dir "Release"
# PROP BASE Target_Dir ""
# PROP Use_MFC 0
# PROP Use_Debug_Libraries 0
# PROP Output_Dir "../release/lib"
# PROP Intermediate_Dir "release"
# PROP Target_Dir ""
MTL=midl.exe
# ADD BASE CPP /nologo /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_MBCS" /D "_LIB" /YX /FD /c
# ADD CPP /nologo /MT /W3 /GX /O2 /I "../.." /D "NDEBUG" /D "WIN32" /D "_UNICODE" /YX /FD /c
# ADD BASE RSC /l 0x409 /d "NDEBUG"
# ADD RSC /l 0x409 /d "NDEBUG"
BSC32=bscmake.exe
# ADD BASE BSC32 /nologo
# ADD BSC32 /nologo
LIB32=link.exe -lib
# ADD BASE LIB32 /nologo
!ELSEIF "$(CFG)" == "aselsp - Win32 Debug"
# PROP BASE Use_MFC 0
# PROP BASE Use_Debug_Libraries 1
# PROP BASE Output_Dir "Debug"
# PROP BASE Intermediate_Dir "Debug"
# PROP BASE Target_Dir ""
# PROP Use_MFC 0
# PROP Use_Debug_Libraries 1
# PROP Output_Dir "../debug/lib"
# PROP Intermediate_Dir "debug"
# PROP Target_Dir ""
MTL=midl.exe
# ADD BASE CPP /nologo /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_MBCS" /D "_LIB" /YX /FD /GZ /c
# ADD CPP /nologo /MTd /W3 /Gm /GX /ZI /Od /I "../.." /D "_DEBUG" /D "WIN32" /D "_UNICODE" /YX /FD /GZ /c
# ADD BASE RSC /l 0x409 /d "_DEBUG"
# ADD RSC /l 0x409 /d "_DEBUG"
BSC32=bscmake.exe
# ADD BASE BSC32 /nologo
# ADD BSC32 /nologo
LIB32=link.exe -lib
# ADD BASE LIB32 /nologo
!ENDIF
# Begin Target
# Name "aselsp - Win32 Release"
# Name "aselsp - Win32 Debug"
# Begin Group "Source Files"
# PROP Default_Filter "cpp;c;cxx;rc;def;r;odl;idl;hpj;bat"
# Begin Source File
SOURCE=.\env.c
# End Source File
# Begin Source File
SOURCE=.\err.c
# End Source File
# Begin Source File
SOURCE=.\eval.c
# End Source File
# Begin Source File
SOURCE=.\lsp.c
# End Source File
# Begin Source File
SOURCE=.\mem.c
# End Source File
# Begin Source File
SOURCE=.\misc.c
# End Source File
# Begin Source File
SOURCE=.\name.c
# End Source File
# Begin Source File
SOURCE=.\prim.c
# End Source File
# Begin Source File
SOURCE=.\prim_compar.c
# End Source File
# Begin Source File
SOURCE=.\prim_let.c
# End Source File
# Begin Source File
SOURCE=.\prim_math.c
# End Source File
# Begin Source File
SOURCE=.\prim_prog.c
# End Source File
# Begin Source File
SOURCE=.\print.c
# End Source File
# Begin Source File
SOURCE=.\read.c
# End Source File
# End Group
# Begin Group "Header Files"
# PROP Default_Filter "h;hpp;hxx;hm;inl"
# Begin Source File
SOURCE=.\env.h
# End Source File
# Begin Source File
SOURCE=.\lsp.h
# End Source File
# Begin Source File
SOURCE=.\lsp_i.h
# End Source File
# Begin Source File
SOURCE=.\mem.h
# End Source File
# Begin Source File
SOURCE=.\misc.h
# End Source File
# Begin Source File
SOURCE=.\name.h
# End Source File
# Begin Source File
SOURCE=.\obj.h
# End Source File
# Begin Source File
SOURCE=.\prim.h
# End Source File
# End Group
# End Target
# End Project

903
ase/lib/lsp/aselsp.vcproj Normal file
View File

@ -0,0 +1,903 @@
<?xml version="1.0" encoding="Windows-1252"?>
<VisualStudioProject
ProjectType="Visual C++"
Version="8.00"
Name="aselsp"
ProjectGUID="{42FE7CED-34B7-45C8-92C9-8856E16640D2}"
RootNamespace="aselsp"
>
<Platforms>
<Platform
Name="Win32"
/>
<Platform
Name="x64"
/>
</Platforms>
<ToolFiles>
</ToolFiles>
<Configurations>
<Configuration
Name="Release|Win32"
OutputDirectory="$(SolutionDir)$(ConfigurationName)\lib"
IntermediateDirectory="$(ConfigurationName)"
ConfigurationType="4"
InheritedPropertySheets="$(VCInstallDir)VCProjectDefaults\UpgradeFromVC60.vsprops"
UseOfMFC="0"
ATLMinimizesCRunTimeLibraryUsage="false"
CharacterSet="1"
>
<Tool
Name="VCPreBuildEventTool"
/>
<Tool
Name="VCCustomBuildTool"
/>
<Tool
Name="VCXMLDataGeneratorTool"
/>
<Tool
Name="VCWebServiceProxyGeneratorTool"
/>
<Tool
Name="VCMIDLTool"
/>
<Tool
Name="VCCLCompilerTool"
Optimization="2"
InlineFunctionExpansion="1"
AdditionalIncludeDirectories="../.."
PreprocessorDefinitions="NDEBUG;WIN32"
StringPooling="true"
RuntimeLibrary="0"
EnableFunctionLevelLinking="true"
WarningLevel="3"
SuppressStartupBanner="true"
/>
<Tool
Name="VCManagedResourceCompilerTool"
/>
<Tool
Name="VCResourceCompilerTool"
PreprocessorDefinitions="NDEBUG"
Culture="1033"
/>
<Tool
Name="VCPreLinkEventTool"
/>
<Tool
Name="VCLibrarianTool"
/>
<Tool
Name="VCALinkTool"
/>
<Tool
Name="VCXDCMakeTool"
/>
<Tool
Name="VCBscMakeTool"
SuppressStartupBanner="true"
/>
<Tool
Name="VCFxCopTool"
/>
<Tool
Name="VCPostBuildEventTool"
/>
</Configuration>
<Configuration
Name="Release|x64"
OutputDirectory="$(SolutionDir)$(ConfigurationName)\lib"
IntermediateDirectory="$(ConfigurationName)"
ConfigurationType="4"
InheritedPropertySheets="$(VCInstallDir)VCProjectDefaults\UpgradeFromVC60.vsprops"
UseOfMFC="0"
ATLMinimizesCRunTimeLibraryUsage="false"
CharacterSet="1"
>
<Tool
Name="VCPreBuildEventTool"
/>
<Tool
Name="VCCustomBuildTool"
/>
<Tool
Name="VCXMLDataGeneratorTool"
/>
<Tool
Name="VCWebServiceProxyGeneratorTool"
/>
<Tool
Name="VCMIDLTool"
TargetEnvironment="3"
/>
<Tool
Name="VCCLCompilerTool"
Optimization="2"
InlineFunctionExpansion="1"
AdditionalIncludeDirectories="../.."
PreprocessorDefinitions="NDEBUG;WIN32"
StringPooling="true"
RuntimeLibrary="0"
EnableFunctionLevelLinking="true"
WarningLevel="3"
SuppressStartupBanner="true"
/>
<Tool
Name="VCManagedResourceCompilerTool"
/>
<Tool
Name="VCResourceCompilerTool"
PreprocessorDefinitions="NDEBUG"
Culture="1033"
/>
<Tool
Name="VCPreLinkEventTool"
/>
<Tool
Name="VCLibrarianTool"
/>
<Tool
Name="VCALinkTool"
/>
<Tool
Name="VCXDCMakeTool"
/>
<Tool
Name="VCBscMakeTool"
SuppressStartupBanner="true"
/>
<Tool
Name="VCFxCopTool"
/>
<Tool
Name="VCPostBuildEventTool"
/>
</Configuration>
<Configuration
Name="Debug|Win32"
OutputDirectory="$(SolutionDir)$(ConfigurationName)\lib"
IntermediateDirectory="$(ConfigurationName)"
ConfigurationType="4"
InheritedPropertySheets="$(VCInstallDir)VCProjectDefaults\UpgradeFromVC60.vsprops"
UseOfMFC="0"
ATLMinimizesCRunTimeLibraryUsage="false"
CharacterSet="1"
>
<Tool
Name="VCPreBuildEventTool"
/>
<Tool
Name="VCCustomBuildTool"
/>
<Tool
Name="VCXMLDataGeneratorTool"
/>
<Tool
Name="VCWebServiceProxyGeneratorTool"
/>
<Tool
Name="VCMIDLTool"
/>
<Tool
Name="VCCLCompilerTool"
Optimization="0"
AdditionalIncludeDirectories="../.."
PreprocessorDefinitions="_DEBUG;WIN32"
MinimalRebuild="true"
BasicRuntimeChecks="3"
RuntimeLibrary="1"
WarningLevel="3"
SuppressStartupBanner="true"
DebugInformationFormat="4"
/>
<Tool
Name="VCManagedResourceCompilerTool"
/>
<Tool
Name="VCResourceCompilerTool"
PreprocessorDefinitions="_DEBUG"
Culture="1033"
/>
<Tool
Name="VCPreLinkEventTool"
/>
<Tool
Name="VCLibrarianTool"
/>
<Tool
Name="VCALinkTool"
/>
<Tool
Name="VCXDCMakeTool"
/>
<Tool
Name="VCBscMakeTool"
SuppressStartupBanner="true"
/>
<Tool
Name="VCFxCopTool"
/>
<Tool
Name="VCPostBuildEventTool"
/>
</Configuration>
<Configuration
Name="Debug|x64"
OutputDirectory="$(SolutionDir)$(ConfigurationName)\lib"
IntermediateDirectory="$(ConfigurationName)"
ConfigurationType="4"
InheritedPropertySheets="$(VCInstallDir)VCProjectDefaults\UpgradeFromVC60.vsprops"
UseOfMFC="0"
ATLMinimizesCRunTimeLibraryUsage="false"
CharacterSet="1"
>
<Tool
Name="VCPreBuildEventTool"
/>
<Tool
Name="VCCustomBuildTool"
/>
<Tool
Name="VCXMLDataGeneratorTool"
/>
<Tool
Name="VCWebServiceProxyGeneratorTool"
/>
<Tool
Name="VCMIDLTool"
TargetEnvironment="3"
/>
<Tool
Name="VCCLCompilerTool"
Optimization="0"
AdditionalIncludeDirectories="../.."
PreprocessorDefinitions="_DEBUG;WIN32"
MinimalRebuild="true"
BasicRuntimeChecks="3"
RuntimeLibrary="1"
WarningLevel="3"
SuppressStartupBanner="true"
DebugInformationFormat="3"
/>
<Tool
Name="VCManagedResourceCompilerTool"
/>
<Tool
Name="VCResourceCompilerTool"
PreprocessorDefinitions="_DEBUG"
Culture="1033"
/>
<Tool
Name="VCPreLinkEventTool"
/>
<Tool
Name="VCLibrarianTool"
/>
<Tool
Name="VCALinkTool"
/>
<Tool
Name="VCXDCMakeTool"
/>
<Tool
Name="VCBscMakeTool"
SuppressStartupBanner="true"
/>
<Tool
Name="VCFxCopTool"
/>
<Tool
Name="VCPostBuildEventTool"
/>
</Configuration>
</Configurations>
<References>
</References>
<Files>
<Filter
Name="Source Files"
Filter="cpp;c;cxx;rc;def;r;odl;idl;hpj;bat"
>
<File
RelativePath="env.c"
>
<FileConfiguration
Name="Release|Win32"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Release|x64"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Debug|Win32"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Debug|x64"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
</File>
<File
RelativePath="err.c"
>
<FileConfiguration
Name="Release|Win32"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Release|x64"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Debug|Win32"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Debug|x64"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
</File>
<File
RelativePath="eval.c"
>
<FileConfiguration
Name="Release|Win32"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Release|x64"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Debug|Win32"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Debug|x64"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
</File>
<File
RelativePath="lsp.c"
>
<FileConfiguration
Name="Release|Win32"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Release|x64"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Debug|Win32"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Debug|x64"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
</File>
<File
RelativePath="mem.c"
>
<FileConfiguration
Name="Release|Win32"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Release|x64"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Debug|Win32"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Debug|x64"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
</File>
<File
RelativePath="misc.c"
>
<FileConfiguration
Name="Release|Win32"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Release|x64"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Debug|Win32"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Debug|x64"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
</File>
<File
RelativePath="name.c"
>
<FileConfiguration
Name="Release|Win32"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Release|x64"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Debug|Win32"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Debug|x64"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
</File>
<File
RelativePath="prim.c"
>
<FileConfiguration
Name="Release|Win32"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Release|x64"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Debug|Win32"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Debug|x64"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
</File>
<File
RelativePath="prim_compar.c"
>
<FileConfiguration
Name="Release|Win32"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Release|x64"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Debug|Win32"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Debug|x64"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
</File>
<File
RelativePath="prim_let.c"
>
<FileConfiguration
Name="Release|Win32"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Release|x64"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Debug|Win32"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Debug|x64"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
</File>
<File
RelativePath="prim_math.c"
>
<FileConfiguration
Name="Release|Win32"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Release|x64"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Debug|Win32"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Debug|x64"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
</File>
<File
RelativePath="prim_prog.c"
>
<FileConfiguration
Name="Release|Win32"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Release|x64"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Debug|Win32"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Debug|x64"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
</File>
<File
RelativePath="print.c"
>
<FileConfiguration
Name="Release|Win32"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Release|x64"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Debug|Win32"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Debug|x64"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
</File>
<File
RelativePath="read.c"
>
<FileConfiguration
Name="Release|Win32"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Release|x64"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Debug|Win32"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
<FileConfiguration
Name="Debug|x64"
>
<Tool
Name="VCCLCompilerTool"
AdditionalIncludeDirectories=""
PreprocessorDefinitions=""
/>
</FileConfiguration>
</File>
</Filter>
<Filter
Name="Header Files"
Filter="h;hpp;hxx;hm;inl"
>
<File
RelativePath="env.h"
>
</File>
<File
RelativePath="lsp.h"
>
</File>
<File
RelativePath="lsp_i.h"
>
</File>
<File
RelativePath="mem.h"
>
</File>
<File
RelativePath="misc.h"
>
</File>
<File
RelativePath="name.h"
>
</File>
<File
RelativePath="obj.h"
>
</File>
<File
RelativePath="prim.h"
>
</File>
</Filter>
</Files>
<Globals>
</Globals>
</VisualStudioProject>

28
ase/lib/lsp/descrip.mms Normal file
View File

@ -0,0 +1,28 @@
#
# OpenVMS MMS/MMK
#
objects = lsp.obj name.obj mem.obj env.obj err.obj read.obj eval.obj print.obj misc.obj prim.obj prim_prog.obj prim_let.obj prim_compar.obj prim_math.obj
CFLAGS = /include="../.."
#CFLAGS = /pointer_size=long /include="../.."
aselsp.olb : $(objects)
$(LIBR)/create $(MMS$TARGET) *.obj
# $(LIBR)/create $(MMS$TARGET) $(objects)
lsp.obj depends_on lsp.c
name.obj depends_on name.c
mem.obj depends_on mem.c
env.obj depends_on env.c
err.obj depends_on err.c
read.obj depends_on read.c
eval.obj depends_on eval.c
print.obj depends_on print.c
misc.obj depends_on misc.c
prim.obj depends_on prim.c
prim_prog.obj depends_on prim_prog.c
prim_let.obj depends_on prim_let.c
prim_compar.obj depends_on prim_compar.c
prim_math.obj depends_on prim_math.c

146
ase/lib/lsp/env.c Normal file
View File

@ -0,0 +1,146 @@
/*
* $Id: env.c 117 2008-03-03 11:20:05Z baconevi $
*
* {License}
*/
#include <ase/lsp/lsp_i.h>
/* TODO: make the frame hash accessible */
static ase_lsp_assoc_t* __new_assoc (
ase_lsp_t* lsp, ase_lsp_obj_t* name,
ase_lsp_obj_t* value, ase_lsp_obj_t* func)
{
ase_lsp_assoc_t* assoc;
assoc = (ase_lsp_assoc_t*)
ASE_LSP_MALLOC (lsp, sizeof(ase_lsp_assoc_t));
if (assoc == ASE_NULL)
{
ase_lsp_seterror (lsp, ASE_LSP_ENOMEM, ASE_NULL, 0);
return ASE_NULL;
}
assoc->name = name;
assoc->value = value;
assoc->func = func;
assoc->link = ASE_NULL;
return assoc;
}
ase_lsp_frame_t* ase_lsp_newframe (ase_lsp_t* lsp)
{
ase_lsp_frame_t* frame;
frame = (ase_lsp_frame_t*)
ASE_LSP_MALLOC (lsp, sizeof(ase_lsp_frame_t));
if (frame == ASE_NULL)
{
ase_lsp_seterror (lsp, ASE_LSP_ENOMEM, ASE_NULL, 0);
return ASE_NULL;
}
frame->assoc = ASE_NULL;
frame->link = ASE_NULL;
return frame;
}
void ase_lsp_freeframe (ase_lsp_t* lsp, ase_lsp_frame_t* frame)
{
ase_lsp_assoc_t* assoc, * link;
/* destroy the associations */
assoc = frame->assoc;
while (assoc != ASE_NULL)
{
link = assoc->link;
ASE_LSP_FREE (lsp, assoc);
assoc = link;
}
ASE_LSP_FREE (lsp, frame);
}
ase_lsp_assoc_t* ase_lsp_lookupinframe (
ase_lsp_t* lsp, ase_lsp_frame_t* frame, ase_lsp_obj_t* name)
{
ase_lsp_assoc_t* assoc;
ASE_ASSERT (ASE_LSP_TYPE(name) == ASE_LSP_OBJ_SYM);
assoc = frame->assoc;
while (assoc != ASE_NULL)
{
if (name == assoc->name) return assoc;
assoc = assoc->link;
}
return ASE_NULL;
}
ase_lsp_assoc_t* ase_lsp_insvalueintoframe (
ase_lsp_t* lsp, ase_lsp_frame_t* frame,
ase_lsp_obj_t* name, ase_lsp_obj_t* value)
{
ase_lsp_assoc_t* assoc;
ASE_ASSERT (ASE_LSP_TYPE(name) == ASE_LSP_OBJ_SYM);
assoc = __new_assoc (lsp, name, value, ASE_NULL);
if (assoc == ASE_NULL) return ASE_NULL;
assoc->link = frame->assoc;
frame->assoc = assoc;
return assoc;
}
ase_lsp_assoc_t* ase_lsp_insfuncintoframe (
ase_lsp_t* lsp, ase_lsp_frame_t* frame,
ase_lsp_obj_t* name, ase_lsp_obj_t* func)
{
ase_lsp_assoc_t* assoc;
ASE_ASSERT (ASE_LSP_TYPE(name) == ASE_LSP_OBJ_SYM);
assoc = __new_assoc (lsp, name, ASE_NULL, func);
if (assoc == ASE_NULL) return ASE_NULL;
assoc->link = frame->assoc;
frame->assoc = assoc;
return assoc;
}
ase_lsp_tlink_t* ase_lsp_pushtmp (ase_lsp_t* lsp, ase_lsp_obj_t* obj)
{
ase_lsp_tlink_t* tlink;
tlink = (ase_lsp_tlink_t*)
ASE_LSP_MALLOC (lsp, sizeof(ase_lsp_tlink_t));
if (tlink == ASE_NULL)
{
ase_lsp_seterror (lsp, ASE_LSP_ENOMEM, ASE_NULL, 0);
return ASE_NULL;
}
tlink->obj = obj;
tlink->link = lsp->mem->tlink;
lsp->mem->tlink = tlink;
lsp->mem->tlink_count++;
return tlink;
}
void ase_lsp_poptmp (ase_lsp_t* lsp)
{
ase_lsp_tlink_t* top;
ASE_ASSERT (lsp->mem->tlink != ASE_NULL);
top = lsp->mem->tlink;
lsp->mem->tlink = top->link;
lsp->mem->tlink_count--;
ASE_LSP_FREE (lsp, top);
}

63
ase/lib/lsp/env.h Normal file
View File

@ -0,0 +1,63 @@
/*
* $Id: env.h 117 2008-03-03 11:20:05Z baconevi $
*
* {License}
*/
#ifndef _ASE_LSP_ENV_H_
#define _ASE_LSP_ENV_H_
#ifndef _ASE_LSP_LSP_H_
#error Never include this file directly. Include <ase/lsp/lsp.h> instead
#endif
typedef struct ase_lsp_assoc_t ase_lsp_assoc_t;
typedef struct ase_lsp_frame_t ase_lsp_frame_t;
typedef struct ase_lsp_tlink_t ase_lsp_tlink_t;
struct ase_lsp_assoc_t
{
ase_lsp_obj_t* name; /* ase_lsp_obj_sym_t */
ase_lsp_obj_t* value; /* value as a variable */
ase_lsp_obj_t* func; /* function definition */
ase_lsp_assoc_t* link;
};
struct ase_lsp_frame_t
{
ase_lsp_assoc_t* assoc;
ase_lsp_frame_t* link;
};
struct ase_lsp_tlink_t
{
ase_lsp_obj_t* obj;
ase_lsp_tlink_t* link;
};
#ifdef __cplusplus
extern "C" {
#endif
ase_lsp_frame_t* ase_lsp_newframe (ase_lsp_t* lsp);
void ase_lsp_freeframe (ase_lsp_t* lsp, ase_lsp_frame_t* frame);
ase_lsp_assoc_t* ase_lsp_lookupinframe (
ase_lsp_t* lsp, ase_lsp_frame_t* frame, ase_lsp_obj_t* name);
ase_lsp_assoc_t* ase_lsp_insvalueintoframe (
ase_lsp_t* lsp, ase_lsp_frame_t* frame,
ase_lsp_obj_t* name, ase_lsp_obj_t* value);
ase_lsp_assoc_t* ase_lsp_insfuncintoframe (
ase_lsp_t* lsp, ase_lsp_frame_t* frame,
ase_lsp_obj_t* name, ase_lsp_obj_t* func);
ase_lsp_tlink_t* ase_lsp_pushtmp (ase_lsp_t* lsp, ase_lsp_obj_t* obj);
void ase_lsp_poptmp (ase_lsp_t* lsp);
#ifdef __cplusplus
}
#endif
#endif

130
ase/lib/lsp/err.c Normal file
View File

@ -0,0 +1,130 @@
/*
* $Id: err.c 117 2008-03-03 11:20:05Z baconevi $
*
* {License}
*/
#include <ase/lsp/lsp_i.h>
static const ase_char_t* __geterrstr (int errnum)
{
static const ase_char_t* __errstr[] =
{
ASE_T("no error"),
ASE_T("out of memory"),
ASE_T("exit"),
ASE_T("end of source"),
ASE_T("unexpected end of string"),
ASE_T("input not attached"),
ASE_T("input"),
ASE_T("output not attached"),
ASE_T("output"),
ASE_T("syntax"),
ASE_T("right parenthesis expected"),
ASE_T("bad arguments"),
ASE_T("too few arguments"),
ASE_T("too many arguments"),
ASE_T("undefined function '%s'"),
ASE_T("bad function"),
ASE_T("duplicate formal"),
ASE_T("bad symbol"),
ASE_T("undefined symbol '%s'"),
ASE_T("empty body"),
ASE_T("bad value"),
ASE_T("divide by zero")
};
if (errnum >= 0 && errnum < ASE_COUNTOF(__errstr))
{
return __errstr[errnum];
}
return ASE_T("unknown error");
}
void ase_lsp_geterror (
ase_lsp_t* lsp, int* errnum, const ase_char_t** errmsg)
{
if (errnum != ASE_NULL) *errnum = lsp->errnum;
if (errmsg != ASE_NULL) *errmsg = lsp->errmsg;
}
void ase_lsp_seterror (
ase_lsp_t* lsp, int errnum,
const ase_char_t** errarg, ase_size_t argcnt)
{
const ase_char_t* errfmt;
ASE_ASSERT (argcnt <= 5);
lsp->errnum = errnum;
errfmt = __geterrstr (errnum);
switch (argcnt)
{
case 0:
lsp->prmfns.misc.sprintf (
lsp->prmfns.misc.custom_data,
lsp->errmsg,
ASE_COUNTOF(lsp->errmsg),
errfmt);
return;
case 1:
lsp->prmfns.misc.sprintf (
lsp->prmfns.misc.custom_data,
lsp->errmsg,
ASE_COUNTOF(lsp->errmsg),
errfmt,
errarg[0]);
return;
case 2:
lsp->prmfns.misc.sprintf (
lsp->prmfns.misc.custom_data,
lsp->errmsg,
ASE_COUNTOF(lsp->errmsg),
errfmt,
errarg[0],
errarg[1]);
return;
case 3:
lsp->prmfns.misc.sprintf (
lsp->prmfns.misc.custom_data,
lsp->errmsg,
ASE_COUNTOF(lsp->errmsg),
errfmt,
errarg[0],
errarg[1],
errarg[2]);
return;
case 4:
lsp->prmfns.misc.sprintf (
lsp->prmfns.misc.custom_data,
lsp->errmsg,
ASE_COUNTOF(lsp->errmsg),
errfmt,
errarg[0],
errarg[1],
errarg[2],
errarg[3]);
return;
case 5:
lsp->prmfns.misc.sprintf (
lsp->prmfns.misc.custom_data,
lsp->errmsg,
ASE_COUNTOF(lsp->errmsg),
errfmt,
errarg[0],
errarg[1],
errarg[2],
errarg[3],
errarg[4]);
return;
}
}

380
ase/lib/lsp/eval.c Normal file
View File

@ -0,0 +1,380 @@
/*
* $Id: eval.c 117 2008-03-03 11:20:05Z baconevi $
*
* {License}
*/
#include <ase/lsp/lsp_i.h>
static ase_lsp_obj_t* __eval (ase_lsp_t* lsp, ase_lsp_obj_t* obj);
static ase_lsp_obj_t* makefn (
ase_lsp_t* lsp, ase_lsp_obj_t* cdr, int is_macro);
static ase_lsp_obj_t* eval_cons (
ase_lsp_t* lsp, ase_lsp_obj_t* cons);
static ase_lsp_obj_t* apply (
ase_lsp_t* lsp, ase_lsp_obj_t* func, ase_lsp_obj_t* actual);
static ase_lsp_obj_t* apply_to_prim (
ase_lsp_t* lsp, ase_lsp_obj_t* func, ase_lsp_obj_t* actual);
ase_lsp_obj_t* ase_lsp_eval (ase_lsp_t* lsp, ase_lsp_obj_t* obj)
{
if (ASE_LSP_TYPE(obj) == ASE_LSP_OBJ_CONS)
{
return eval_cons (lsp, obj);
}
else if (ASE_LSP_TYPE(obj) == ASE_LSP_OBJ_SYM)
{
ase_lsp_assoc_t* assoc;
/*
if (obj == lsp->mem->lambda || obj == lsp->mem->macro) {
ase_char_t* arg[1];
arg[0] = ASE_LSP_SYMPTR(obj);
printf ("lambda or macro can't be used as a normal symbol\n");
ase_lsp_seterror (
lsp, ASE_LSP_EBADSYM,
arg, ASE_COUNTOF(arg));
return ASE_NULL;
}
*/
assoc = ase_lsp_lookup(lsp->mem, obj);
if (assoc == ASE_NULL || assoc->value == ASE_NULL)
{
if (lsp->opt_undef_symbol)
{
const ase_char_t* arg[1];
arg[0] = ASE_LSP_SYMPTR(obj);
ase_lsp_seterror (
lsp, ASE_LSP_EUNDEFSYM,
arg, ASE_COUNTOF(arg));
return ASE_NULL;
}
return lsp->mem->nil;
}
obj = assoc->value;
}
return obj;
}
static ase_lsp_obj_t* makefn (ase_lsp_t* lsp, ase_lsp_obj_t* cdr, int is_macro)
{
ase_lsp_obj_t* func, * formal, * body, * p;
if (cdr == lsp->mem->nil)
{
ase_lsp_seterror (lsp, ASE_LSP_EARGFEW, ASE_NULL, 0);
return ASE_NULL;
}
if (ASE_LSP_TYPE(cdr) != ASE_LSP_OBJ_CONS)
{
ase_lsp_seterror (lsp, ASE_LSP_EARGBAD, ASE_NULL, 0);
return ASE_NULL;
}
formal = ASE_LSP_CAR(cdr);
body = ASE_LSP_CDR(cdr);
if (body == lsp->mem->nil)
{
ase_lsp_seterror (lsp, ASE_LSP_EEMPBDY, ASE_NULL, 0);
return ASE_NULL;
}
/* TODO: more lambda expression syntax checks required???. */
/* check if the lambda express has non-nil value
* at the terminating cdr */
for (p = body; ASE_LSP_TYPE(p) == ASE_LSP_OBJ_CONS; p = ASE_LSP_CDR(p));
if (p != lsp->mem->nil)
{
/* like in (lambda (x) (+ x 10) . 4) */
ase_lsp_seterror (lsp, ASE_LSP_EARGBAD, ASE_NULL, 0);
return ASE_NULL;
}
func = (is_macro)?
ase_lsp_makemacro (lsp->mem, formal, body):
ase_lsp_makefunc (lsp->mem, formal, body);
if (func == ASE_NULL) return ASE_NULL;
return func;
}
static ase_lsp_obj_t* eval_cons (ase_lsp_t* lsp, ase_lsp_obj_t* cons)
{
ase_lsp_obj_t* car, * cdr;
ASE_ASSERT (ASE_LSP_TYPE(cons) == ASE_LSP_OBJ_CONS);
car = ASE_LSP_CAR(cons);
cdr = ASE_LSP_CDR(cons);
if (car == lsp->mem->lambda)
{
/* (lambda (x) (+ x 20)) */
return makefn (lsp, cdr, 0);
}
else if (car == lsp->mem->macro)
{
/* (macro (x) (+ x 20)) */
return makefn (lsp, cdr, 1);
}
else if (ASE_LSP_TYPE(car) == ASE_LSP_OBJ_SYM)
{
ase_lsp_assoc_t* assoc;
if ((assoc = ase_lsp_lookup(lsp->mem, car)) != ASE_NULL)
{
/*ase_lsp_obj_t* func = assoc->value;*/
ase_lsp_obj_t* func = assoc->func;
if (func == ASE_NULL)
{
/* the symbol's function definition is void */
const ase_char_t* arg[1];
arg[0] = ASE_LSP_SYMPTR(car);
ase_lsp_seterror (
lsp, ASE_LSP_EUNDEFFN,
arg, ASE_COUNTOF(arg));
return ASE_NULL;
}
if (ASE_LSP_TYPE(func) == ASE_LSP_OBJ_FUNC ||
ASE_LSP_TYPE(func) == ASE_LSP_OBJ_MACRO)
{
return apply (lsp, func, cdr);
}
else if (ASE_LSP_TYPE(func) == ASE_LSP_OBJ_PRIM)
{
/* primitive function */
return apply_to_prim (lsp, func, cdr);
}
else
{
const ase_char_t* arg[1];
arg[0] = ASE_LSP_SYMPTR(car);
ase_lsp_seterror (
lsp, ASE_LSP_EUNDEFFN,
arg, ASE_COUNTOF(arg));
return ASE_NULL;
}
}
else
{
const ase_char_t* arg[1];
arg[0] = ASE_LSP_SYMPTR(car);
ase_lsp_seterror (
lsp, ASE_LSP_EUNDEFFN,
arg, ASE_COUNTOF(arg));
return ASE_NULL;
}
}
else if (ASE_LSP_TYPE(car) == ASE_LSP_OBJ_FUNC ||
ASE_LSP_TYPE(car) == ASE_LSP_OBJ_MACRO)
{
return apply (lsp, car, cdr);
}
else if (ASE_LSP_TYPE(car) == ASE_LSP_OBJ_CONS)
{
/* anonymous function or macros
* ((lambda (x) (+ x 10)) 50) */
if (ASE_LSP_CAR(car) == lsp->mem->lambda)
{
ase_lsp_obj_t* func = makefn (lsp, ASE_LSP_CDR(car), 0);
if (func == ASE_NULL) return ASE_NULL;
return apply (lsp, func, cdr);
}
else if (ASE_LSP_CAR(car) == lsp->mem->macro)
{
ase_lsp_obj_t* func = makefn (lsp, ASE_LSP_CDR(car), 1);
if (func == ASE_NULL) return ASE_NULL;
return apply (lsp, func, cdr);
}
}
ase_lsp_seterror (lsp, ASE_LSP_EBADFN, ASE_NULL, 0);
return ASE_NULL;
}
static ase_lsp_obj_t* apply (
ase_lsp_t* lsp, ase_lsp_obj_t* func, ase_lsp_obj_t* actual)
{
ase_lsp_frame_t* frame;
ase_lsp_obj_t* formal;
ase_lsp_obj_t* body;
ase_lsp_obj_t* value;
ase_lsp_mem_t* mem;
ASE_ASSERT (ASE_LSP_TYPE(func) == ASE_LSP_OBJ_FUNC ||
ASE_LSP_TYPE(func) == ASE_LSP_OBJ_MACRO);
ASE_ASSERT (ASE_LSP_TYPE(ASE_LSP_CDR(func)) == ASE_LSP_OBJ_CONS);
mem = lsp->mem;
if (ASE_LSP_TYPE(func) == ASE_LSP_OBJ_MACRO)
{
formal = ASE_LSP_MFORMAL (func);
body = ASE_LSP_MBODY (func);
}
else
{
formal = ASE_LSP_FFORMAL (func);
body = ASE_LSP_FBODY (func);
}
/* make a new frame. */
frame = ase_lsp_newframe (lsp);
if (frame == ASE_NULL) return ASE_NULL;
/* attach it to the brooding frame list to
* prevent them from being garbage-collected. */
frame->link = mem->brooding_frame;
mem->brooding_frame = frame;
/* evaluate arguments and push them into the frame. */
while (formal != mem->nil)
{
if (actual == mem->nil)
{
mem->brooding_frame = frame->link;
ase_lsp_freeframe (lsp, frame);
ase_lsp_seterror (lsp, ASE_LSP_EARGFEW, ASE_NULL, 0);
return ASE_NULL;
}
value = ASE_LSP_CAR(actual);
if (ASE_LSP_TYPE(func) != ASE_LSP_OBJ_MACRO)
{
/* macro doesn't evaluate actual arguments. */
value = ase_lsp_eval (lsp, value);
if (value == ASE_NULL)
{
mem->brooding_frame = frame->link;
ase_lsp_freeframe (lsp, frame);
return ASE_NULL;
}
}
if (ase_lsp_lookupinframe (
lsp, frame, ASE_LSP_CAR(formal)) != ASE_NULL)
{
mem->brooding_frame = frame->link;
ase_lsp_freeframe (lsp, frame);
ase_lsp_seterror (lsp, ASE_LSP_EDUPFML, ASE_NULL, 0);
return ASE_NULL;
}
if (ase_lsp_insvalueintoframe (
lsp, frame, ASE_LSP_CAR(formal), value) == ASE_NULL)
{
mem->brooding_frame = frame->link;
ase_lsp_freeframe (lsp, frame);
return ASE_NULL;
}
actual = ASE_LSP_CDR(actual);
formal = ASE_LSP_CDR(formal);
}
if (ASE_LSP_TYPE(actual) == ASE_LSP_OBJ_CONS)
{
mem->brooding_frame = frame->link;
ase_lsp_freeframe (lsp, frame);
ase_lsp_seterror (lsp, ASE_LSP_EARGMANY, ASE_NULL, 0);
return ASE_NULL;
}
else if (actual != mem->nil)
{
mem->brooding_frame = frame->link;
ase_lsp_freeframe (lsp, frame);
ase_lsp_seterror (lsp, ASE_LSP_EARGBAD, ASE_NULL, 0);
return ASE_NULL;
}
/* push the frame */
mem->brooding_frame = frame->link;
frame->link = mem->frame;
mem->frame = frame;
/* do the evaluation of the body */
value = mem->nil;
while (body != mem->nil)
{
value = ase_lsp_eval(lsp, ASE_LSP_CAR(body));
if (value == ASE_NULL)
{
mem->frame = frame->link;
ase_lsp_freeframe (lsp, frame);
return ASE_NULL;
}
body = ASE_LSP_CDR(body);
}
/* pop the frame. */
mem->frame = frame->link;
/* destroy the frame. */
ase_lsp_freeframe (lsp, frame);
/*if (ASE_LSP_CAR(func) == mem->macro) {*/
if (ASE_LSP_TYPE(func) == ASE_LSP_OBJ_MACRO)
{
value = ase_lsp_eval (lsp, value);
if (value == ASE_NULL) return ASE_NULL;
}
return value;
}
static ase_lsp_obj_t* apply_to_prim (
ase_lsp_t* lsp, ase_lsp_obj_t* func, ase_lsp_obj_t* actual)
{
ase_lsp_obj_t* obj;
ase_size_t count = 0;
ASE_ASSERT (ASE_LSP_TYPE(func) == ASE_LSP_OBJ_PRIM);
obj = actual;
while (ASE_LSP_TYPE(obj) == ASE_LSP_OBJ_CONS)
{
count++;
obj = ASE_LSP_CDR(obj);
}
if (obj != lsp->mem->nil)
{
ase_lsp_seterror (lsp, ASE_LSP_EARGBAD, ASE_NULL, 0);
return ASE_NULL;
}
if (count < ASE_LSP_PMINARGS(func))
{
ase_lsp_seterror (lsp, ASE_LSP_EARGFEW, ASE_NULL, 0);
return ASE_NULL;
}
if (count > ASE_LSP_PMAXARGS(func))
{
ase_lsp_seterror (lsp, ASE_LSP_EARGMANY, ASE_NULL, 0);
return ASE_NULL;
}
return ASE_LSP_PIMPL(func) (lsp, actual);
}

218
ase/lib/lsp/lsp.c Normal file
View File

@ -0,0 +1,218 @@
/*
* $Id: lsp.c 117 2008-03-03 11:20:05Z baconevi $
*
* {License}
*/
#if defined(__BORLANDC__)
#pragma hdrstop
#define Library
#endif
#include <ase/lsp/lsp_i.h>
static int __add_builtin_prims (ase_lsp_t* lsp);
ase_lsp_t* ase_lsp_open (
const ase_lsp_prmfns_t* prmfns,
ase_size_t mem_ubound, ase_size_t mem_ubound_inc)
{
ase_lsp_t* lsp;
if (prmfns == ASE_NULL) return ASE_NULL;
if (prmfns->mmgr.malloc == ASE_NULL ||
prmfns->mmgr.realloc == ASE_NULL ||
prmfns->mmgr.free == ASE_NULL) return ASE_NULL;
if (prmfns->ccls.is_upper == ASE_NULL ||
prmfns->ccls.is_lower == ASE_NULL ||
prmfns->ccls.is_alpha == ASE_NULL ||
prmfns->ccls.is_digit == ASE_NULL ||
prmfns->ccls.is_xdigit == ASE_NULL ||
prmfns->ccls.is_alnum == ASE_NULL ||
prmfns->ccls.is_space == ASE_NULL ||
prmfns->ccls.is_print == ASE_NULL ||
prmfns->ccls.is_graph == ASE_NULL ||
prmfns->ccls.is_cntrl == ASE_NULL ||
prmfns->ccls.is_punct == ASE_NULL ||
prmfns->ccls.to_upper == ASE_NULL ||
prmfns->ccls.to_lower == ASE_NULL) return ASE_NULL;
if (prmfns->misc.sprintf == ASE_NULL ||
prmfns->misc.dprintf == ASE_NULL) return ASE_NULL;
#if defined(_WIN32) && defined(_MSC_VER) && defined(_DEBUG)
lsp = (ase_lsp_t*) malloc (ASE_SIZEOF(ase_lsp_t));
#else
lsp = (ase_lsp_t*) prmfns->mmgr.malloc (
prmfns->mmgr.custom_data, ASE_SIZEOF(ase_lsp_t));
#endif
if (lsp == ASE_NULL) return ASE_NULL;
/* it uses the built-in ase_lsp_memset because lsp is not
* fully initialized yet */
ase_memset (lsp, 0, ASE_SIZEOF(ase_lsp_t));
ase_memcpy (&lsp->prmfns, prmfns, ASE_SIZEOF(lsp->prmfns));
if (ase_lsp_name_open(&lsp->token.name, 0, lsp) == ASE_NULL)
{
ASE_LSP_FREE (lsp, lsp);
return ASE_NULL;
}
lsp->errnum = ASE_LSP_ENOERR;
lsp->errmsg[0] = ASE_T('\0');
lsp->opt_undef_symbol = 1;
/*lsp->opt_undef_symbol = 0;*/
lsp->curc = ASE_CHAR_EOF;
lsp->input_func = ASE_NULL;
lsp->output_func = ASE_NULL;
lsp->input_arg = ASE_NULL;
lsp->output_arg = ASE_NULL;
lsp->mem = ase_lsp_openmem (lsp, mem_ubound, mem_ubound_inc);
if (lsp->mem == ASE_NULL)
{
ase_lsp_name_close (&lsp->token.name);
ASE_LSP_FREE (lsp, lsp);
return ASE_NULL;
}
if (__add_builtin_prims(lsp) == -1)
{
ase_lsp_closemem (lsp->mem);
ase_lsp_name_close (&lsp->token.name);
ASE_LSP_FREE (lsp, lsp);
return ASE_NULL;
}
lsp->max_eval_depth = 0; /* TODO: put restriction here.... */
lsp->cur_eval_depth = 0;
return lsp;
}
void ase_lsp_close (ase_lsp_t* lsp)
{
ase_lsp_closemem (lsp->mem);
ase_lsp_name_close (&lsp->token.name);
ASE_LSP_FREE (lsp, lsp);
}
int ase_lsp_attinput (ase_lsp_t* lsp, ase_lsp_io_t input, void* arg)
{
if (ase_lsp_detinput(lsp) == -1) return -1;
ASE_ASSERT (lsp->input_func == ASE_NULL);
if (input(ASE_LSP_IO_OPEN, arg, ASE_NULL, 0) == -1)
{
/* TODO: set error number */
return -1;
}
lsp->input_func = input;
lsp->input_arg = arg;
lsp->curc = ASE_CHAR_EOF;
return 0;
}
int ase_lsp_detinput (ase_lsp_t* lsp)
{
if (lsp->input_func != ASE_NULL)
{
if (lsp->input_func (
ASE_LSP_IO_CLOSE, lsp->input_arg, ASE_NULL, 0) == -1)
{
/* TODO: set error number */
return -1;
}
lsp->input_func = ASE_NULL;
lsp->input_arg = ASE_NULL;
lsp->curc = ASE_CHAR_EOF;
}
return 0;
}
int ase_lsp_attoutput (ase_lsp_t* lsp, ase_lsp_io_t output, void* arg)
{
if (ase_lsp_detoutput(lsp) == -1) return -1;
ASE_ASSERT (lsp->output_func == ASE_NULL);
if (output(ASE_LSP_IO_OPEN, arg, ASE_NULL, 0) == -1)
{
/* TODO: set error number */
return -1;
}
lsp->output_func = output;
lsp->output_arg = arg;
return 0;
}
int ase_lsp_detoutput (ase_lsp_t* lsp)
{
if (lsp->output_func != ASE_NULL)
{
if (lsp->output_func (
ASE_LSP_IO_CLOSE, lsp->output_arg, ASE_NULL, 0) == -1)
{
/* TODO: set error number */
return -1;
}
lsp->output_func = ASE_NULL;
lsp->output_arg = ASE_NULL;
}
return 0;
}
static int __add_builtin_prims (ase_lsp_t* lsp)
{
#define ADD_PRIM(mem,name,name_len,pimpl,min_args,max_args) \
if (ase_lsp_addprim(mem,name,name_len,pimpl,min_args,max_args) == -1) return -1;
#define MAX_ARGS ASE_TYPE_MAX(ase_size_t)
ADD_PRIM (lsp, ASE_T("exit"), 4, ase_lsp_prim_exit, 0, 0);
ADD_PRIM (lsp, ASE_T("eval"), 4, ase_lsp_prim_eval, 1, 1);
ADD_PRIM (lsp, ASE_T("prog1"), 5, ase_lsp_prim_prog1, 1, MAX_ARGS);
ADD_PRIM (lsp, ASE_T("progn"), 5, ase_lsp_prim_progn, 1, MAX_ARGS);
ADD_PRIM (lsp, ASE_T("gc"), 2, ase_lsp_prim_gc, 0, 0);
ADD_PRIM (lsp, ASE_T("cond"), 4, ase_lsp_prim_cond, 0, MAX_ARGS);
ADD_PRIM (lsp, ASE_T("if"), 2, ase_lsp_prim_if, 2, MAX_ARGS);
ADD_PRIM (lsp, ASE_T("while"), 5, ase_lsp_prim_while, 1, MAX_ARGS);
ADD_PRIM (lsp, ASE_T("car"), 3, ase_lsp_prim_car, 1, 1);
ADD_PRIM (lsp, ASE_T("cdr"), 3, ase_lsp_prim_cdr, 1, 1);
ADD_PRIM (lsp, ASE_T("cons"), 4, ase_lsp_prim_cons, 2, 2);
ADD_PRIM (lsp, ASE_T("length"), 6, ase_lsp_prim_length, 1, 1);
ADD_PRIM (lsp, ASE_T("set"), 3, ase_lsp_prim_set, 2, 2);
ADD_PRIM (lsp, ASE_T("setq"), 4, ase_lsp_prim_setq, 1, MAX_ARGS);
ADD_PRIM (lsp, ASE_T("quote"), 5, ase_lsp_prim_quote, 1, 1);
ADD_PRIM (lsp, ASE_T("defun"), 5, ase_lsp_prim_defun, 3, MAX_ARGS);
ADD_PRIM (lsp, ASE_T("demac"), 5, ase_lsp_prim_demac, 3, MAX_ARGS);
ADD_PRIM (lsp, ASE_T("let"), 3, ase_lsp_prim_let, 1, MAX_ARGS);
ADD_PRIM (lsp, ASE_T("let*"), 4, ase_lsp_prim_letx, 1, MAX_ARGS);
/*ADD_PRIM (lsp, ASE_T("or"), 2, ase_lsp_prim_or, 2, MAX_ARGS);*/
ADD_PRIM (lsp, ASE_T("="), 1, ase_lsp_prim_eq, 2, 2);
ADD_PRIM (lsp, ASE_T("/="), 2, ase_lsp_prim_ne, 2, 2);
ADD_PRIM (lsp, ASE_T(">"), 1, ase_lsp_prim_gt, 2, 2);
ADD_PRIM (lsp, ASE_T("<"), 1, ase_lsp_prim_lt, 2, 2);
ADD_PRIM (lsp, ASE_T(">="), 2, ase_lsp_prim_ge, 2, 2);
ADD_PRIM (lsp, ASE_T("<="), 2, ase_lsp_prim_le, 2, 2);
ADD_PRIM (lsp, ASE_T("+"), 1, ase_lsp_prim_plus, 1, MAX_ARGS);
ADD_PRIM (lsp, ASE_T("-"), 1, ase_lsp_prim_minus, 1, MAX_ARGS);
ADD_PRIM (lsp, ASE_T("*"), 1, ase_lsp_prim_mul, 1, MAX_ARGS);
ADD_PRIM (lsp, ASE_T("/"), 1, ase_lsp_prim_div, 1, MAX_ARGS);
ADD_PRIM (lsp, ASE_T("%"), 1, ase_lsp_prim_mod , 1, MAX_ARGS);
return 0;
}

123
ase/lib/lsp/lsp.h Normal file
View File

@ -0,0 +1,123 @@
/*
* $Id: lsp.h 117 2008-03-03 11:20:05Z baconevi $
*
* {License}
*/
#ifndef _ASE_LSP_LSP_H_
#define _ASE_LSP_LSP_H_
#include <ase/cmn/types.h>
#include <ase/cmn/macros.h>
typedef struct ase_lsp_t ase_lsp_t;
typedef struct ase_lsp_obj_t ase_lsp_obj_t;
typedef struct ase_lsp_prmfns_t ase_lsp_prmfns_t;
typedef ase_ssize_t (*ase_lsp_io_t) (
int cmd, void* arg, ase_char_t* data, ase_size_t count);
typedef ase_real_t (*ase_lsp_pow_t) (
void* custom, ase_real_t x, ase_real_t y);
typedef int (*ase_lsp_sprintf_t) (
void* custom, ase_char_t* buf, ase_size_t size,
const ase_char_t* fmt, ...);
typedef void (*ase_lsp_dprintf_t) (void* custom, const ase_char_t* fmt, ...);
struct ase_lsp_prmfns_t
{
ase_mmgr_t mmgr;
ase_ccls_t ccls;
/* utilities */
struct
{
ase_lsp_sprintf_t sprintf;
ase_lsp_dprintf_t dprintf;
void* custom_data;
} misc;
};
/* io function commands */
enum
{
ASE_LSP_IO_OPEN = 0,
ASE_LSP_IO_CLOSE = 1,
ASE_LSP_IO_READ = 2,
ASE_LSP_IO_WRITE = 3
};
/* option code */
enum
{
ASE_LSP_UNDEFSYMBOL = (1 << 0)
};
/* error code */
enum
{
ASE_LSP_ENOERR,
ASE_LSP_ENOMEM,
ASE_LSP_EEXIT,
ASE_LSP_EEND,
ASE_LSP_EENDSTR,
ASE_LSP_ENOINP,
ASE_LSP_EINPUT,
ASE_LSP_ENOOUTP,
ASE_LSP_EOUTPUT,
ASE_LSP_ESYNTAX,
ASE_LSP_ERPAREN,
ASE_LSP_EARGBAD,
ASE_LSP_EARGFEW,
ASE_LSP_EARGMANY,
ASE_LSP_EUNDEFFN,
ASE_LSP_EBADFN,
ASE_LSP_EDUPFML,
ASE_LSP_EBADSYM,
ASE_LSP_EUNDEFSYM,
ASE_LSP_EEMPBDY,
ASE_LSP_EVALBAD,
ASE_LSP_EDIVBY0
};
typedef ase_lsp_obj_t* (*ase_lsp_prim_t) (ase_lsp_t* lsp, ase_lsp_obj_t* obj);
#ifdef __cplusplus
extern "C" {
#endif
ase_lsp_t* ase_lsp_open (
const ase_lsp_prmfns_t* prmfns,
ase_size_t mem_ubound, ase_size_t mem_ubound_inc);
void ase_lsp_close (ase_lsp_t* lsp);
void ase_lsp_geterror (
ase_lsp_t* lsp, int* errnum, const ase_char_t** errmsg);
void ase_lsp_seterror (
ase_lsp_t* lsp, int errnum,
const ase_char_t** errarg, ase_size_t argcnt);
int ase_lsp_attinput (ase_lsp_t* lsp, ase_lsp_io_t input, void* arg);
int ase_lsp_detinput (ase_lsp_t* lsp);
int ase_lsp_attoutput (ase_lsp_t* lsp, ase_lsp_io_t output, void* arg);
int ase_lsp_detoutput (ase_lsp_t* lsp);
ase_lsp_obj_t* ase_lsp_read (ase_lsp_t* lsp);
ase_lsp_obj_t* ase_lsp_eval (ase_lsp_t* lsp, ase_lsp_obj_t* obj);
int ase_lsp_print (ase_lsp_t* lsp, const ase_lsp_obj_t* obj);
int ase_lsp_addprim (
ase_lsp_t* lsp, const ase_char_t* name, ase_size_t name_len,
ase_lsp_prim_t prim, ase_size_t min_args, ase_size_t max_args);
int ase_lsp_removeprim (ase_lsp_t* lsp, const ase_char_t* name);
#ifdef __cplusplus
}
#endif
#endif

78
ase/lib/lsp/lsp_i.h Normal file
View File

@ -0,0 +1,78 @@
/*
* $Id: lsp_i.h 117 2008-03-03 11:20:05Z baconevi $
*
* {License}
*/
#ifndef _ASE_LSP_LSPI_H_
#define _ASE_LSP_LSPI_H_
#include <ase/cmn/mem.h>
#include <ase/cmn/str.h>
#include <ase/lsp/lsp.h>
#include <ase/lsp/env.h>
#include <ase/lsp/obj.h>
#include <ase/lsp/mem.h>
#include <ase/lsp/misc.h>
#include <ase/lsp/prim.h>
#include <ase/lsp/name.h>
#ifdef _MSC_VER
#pragma warning (disable: 4996)
#endif
#define ASE_LSP_MALLOC(lsp,size) ASE_MALLOC(&(lsp)->prmfns.mmgr,size)
#define ASE_LSP_REALLOC(lsp,ptr,size) ASE_REALLOC(&(lsp)->prmfns.mmgr,ptr,size)
#define ASE_LSP_FREE(lsp,ptr) ASE_FREE(&(lsp)->prmfns.mmgr,ptr)
#define ASE_LSP_ISUPPER(lsp,c) ASE_ISUPPER(&(lsp)->prmfns.ccls,c)
#define ASE_LSP_ISLOWER(lsp,c) ASE_ISLOWER(&(lsp)->prmfns.ccls,c)
#define ASE_LSP_ISALPHA(lsp,c) ASE_ISALPHA(&(lsp)->prmfns.ccls,c)
#define ASE_LSP_ISDIGIT(lsp,c) ASE_ISDIGIT(&(lsp)->prmfns.ccls,c)
#define ASE_LSP_ISXDIGIT(lsp,c) ASE_ISXDIGIT(&(lsp)->prmfns.ccls,c)
#define ASE_LSP_ISALNUM(lsp,c) ASE_ISALNUM(&(lsp)->prmfns.ccls,c)
#define ASE_LSP_ISSPACE(lsp,c) ASE_ISSPACE(&(lsp)->prmfns.ccls,c)
#define ASE_LSP_ISPRINT(lsp,c) ASE_ISPRINT(&(lsp)->prmfns.ccls,c)
#define ASE_LSP_ISGRAPH(lsp,c) ASE_ISGRAPH(&(lsp)->prmfns.ccls,c)
#define ASE_LSP_ISCNTRL(lsp,c) ASE_ISCNTRL(&(lsp)->prmfns.ccls,c)
#define ASE_LSP_ISPUNCT(lsp,c) ASE_ISPUNCT(&(lsp)->prmfns.ccls,c)
#define ASE_LSP_TOUPPER(lsp,c) ASE_TOUPPER(&(lsp)->prmfns.ccls,c)
#define ASE_LSP_TOLOWER(lsp,c) ASE_TOLOWER(&(lsp)->prmfns.ccls,c)
struct ase_lsp_t
{
ase_lsp_prmfns_t prmfns;
/* error */
int errnum;
ase_char_t errmsg[256];
/* options */
int opt_undef_symbol;
/* for read */
ase_cint_t curc;
struct
{
int type;
ase_long_t ival;
ase_real_t rval;
ase_lsp_name_t name;
} token;
/* io functions */
ase_lsp_io_t input_func;
ase_lsp_io_t output_func;
void* input_arg;
void* output_arg;
/* security options */
ase_size_t max_eval_depth;
ase_size_t cur_eval_depth;
/* memory manager */
ase_lsp_mem_t* mem;
};
#endif

93
ase/lib/lsp/makefile.in Normal file
View File

@ -0,0 +1,93 @@
#
# $Id: makefile.in,v 1.3 2007/04/30 06:09:46 bacon Exp $
#
NAME = aselsp
CC = @CC@
AR = @AR@
MAKE = @MAKE@
RANLIB = @RANLIB@
CFLAGS = @CFLAGS@ -I@abs_top_builddir@/..
LDFLAGS = @LDFLAGS@
LIBS = @LIBS@
MODE = @BUILDMODE@
OUT_DIR = ../$(MODE)/lib
OUT_FILE = $(OUT_DIR)/lib$(NAME).a
TMP_DIR = $(MODE)
OBJ_FILES = \
$(TMP_DIR)/lsp.o \
$(TMP_DIR)/name.o \
$(TMP_DIR)/mem.o \
$(TMP_DIR)/env.o \
$(TMP_DIR)/err.o \
$(TMP_DIR)/eval.o \
$(TMP_DIR)/read.o \
$(TMP_DIR)/print.o \
$(TMP_DIR)/misc.o \
$(TMP_DIR)/prim.o \
$(TMP_DIR)/prim_prog.o \
$(TMP_DIR)/prim_let.o \
$(TMP_DIR)/prim_compar.o \
$(TMP_DIR)/prim_math.o
lib: $(OUT_FILE)
$(OUT_FILE): $(TMP_DIR) $(OBJ_FILES) $(OUT_DIR)
$(AR) cr $(OUT_FILE) $(OBJ_FILES)
if [ ! -z "$(RANLIB)" ]; then $(RANLIB) $(OUT_FILE); fi
$(TMP_DIR)/lsp.o: lsp.c
$(CC) $(CFLAGS) -o $@ -c lsp.c
$(TMP_DIR)/name.o: name.c
$(CC) $(CFLAGS) -o $@ -c name.c
$(TMP_DIR)/mem.o: mem.c
$(CC) $(CFLAGS) -o $@ -c mem.c
$(TMP_DIR)/env.o: env.c
$(CC) $(CFLAGS) -o $@ -c env.c
$(TMP_DIR)/err.o: err.c
$(CC) $(CFLAGS) -o $@ -c err.c
$(TMP_DIR)/eval.o: eval.c
$(CC) $(CFLAGS) -o $@ -c eval.c
$(TMP_DIR)/read.o: read.c
$(CC) $(CFLAGS) -o $@ -c read.c
$(TMP_DIR)/print.o: print.c
$(CC) $(CFLAGS) -o $@ -c print.c
$(TMP_DIR)/misc.o: misc.c
$(CC) $(CFLAGS) -o $@ -c misc.c
$(TMP_DIR)/prim.o: prim.c
$(CC) $(CFLAGS) -o $@ -c prim.c
$(TMP_DIR)/prim_prog.o: prim_prog.c
$(CC) $(CFLAGS) -o $@ -c prim_prog.c
$(TMP_DIR)/prim_let.o: prim_let.c
$(CC) $(CFLAGS) -o $@ -c prim_let.c
$(TMP_DIR)/prim_compar.o: prim_compar.c
$(CC) $(CFLAGS) -o $@ -c prim_compar.c
$(TMP_DIR)/prim_math.o: prim_math.c
$(CC) $(CFLAGS) -o $@ -c prim_math.c
$(OUT_DIR):
mkdir -p $(OUT_DIR)
$(TMP_DIR):
mkdir -p $(TMP_DIR)
clean:
rm -rf $(OUT_FILE) $(OBJ_FILES)

21
ase/lib/lsp/makefile.msw.bcc Normal file
View File

@ -0,0 +1,21 @@
SRCS = lsp.c name.c mem.c env.c err.c read.c eval.c print.c misc.c \
prim.c prim_prog.c prim_let.c prim_compar.c prim_math.c
OBJS = $(SRCS:.c=.obj)
OUT = aselsp.lib
CC = bcc32
CFLAGS = -O2 -WM -w -w-inl -w-sig -w-spa -w-hid -RT- -I../..
all: $(OBJS)
tlib $(OUT) @&&!
+-$(**: = &^
+-)
!
clean:
-del $(OBJS) $(OUT) *.obj
.SUFFIXES: .c .obj
.c.obj:
$(CC) $(CFLAGS) -c $<

24
ase/lib/lsp/makefile.msw.cl Normal file
View File

@ -0,0 +1,24 @@
OUT = aselsp
SRCS = lsp.c name.c mem.c env.c err.c read.c eval.c print.c misc.c \
prim.c prim_prog.c prim_let.c prim_compar.c prim_math.c
OBJS = $(SRCS:.c=.obj)
CC = cl
LD = link
CFLAGS = /nologo /O2 /MT /W3 /GR- /Za -I../..
all: lib
lib: $(OBJS)
$(LD) -lib @<<
/nologo /out:$(OUT).lib $(OBJS)
<<
clean:
del $(OBJS) $(OUT) *.obj
.SUFFIXES: .c .obj
.c.obj:
$(CC) $(CFLAGS) /c $<

603
ase/lib/lsp/mem.c Normal file
View File

@ -0,0 +1,603 @@
/*
* $Id: mem.c 117 2008-03-03 11:20:05Z baconevi $
*
* {License}
*/
#include <ase/lsp/lsp_i.h>
ase_lsp_mem_t* ase_lsp_openmem (
ase_lsp_t* lsp, ase_size_t ubound, ase_size_t ubound_inc)
{
ase_lsp_mem_t* mem;
ase_size_t i;
/* allocate memory */
mem = (ase_lsp_mem_t*) ASE_LSP_MALLOC (lsp, ASE_SIZEOF(ase_lsp_mem_t));
if (mem == ASE_NULL) return ASE_NULL;
ase_memset (mem, 0, ASE_SIZEOF(ase_lsp_mem_t));
mem->lsp = lsp;
/* create a new root environment frame */
mem->frame = ase_lsp_newframe (lsp);
if (mem->frame == ASE_NULL)
{
ASE_LSP_FREE (lsp, mem);
return ASE_NULL;
}
mem->root_frame = mem->frame;
mem->brooding_frame = ASE_NULL;
mem->tlink = ASE_NULL;
mem->tlink_count = 0;
/* initialize object allocation list */
mem->ubound = ubound;
mem->ubound_inc = ubound_inc;
mem->count = 0;
for (i = 0; i < ASE_LSP_TYPE_COUNT; i++)
{
mem->used[i] = ASE_NULL;
mem->free[i] = ASE_NULL;
}
mem->read = ASE_NULL;
/* when "ubound" is too small, the garbage collection can
* be performed while making the common objects. */
mem->nil = ASE_NULL;
mem->t = ASE_NULL;
mem->quote = ASE_NULL;
mem->lambda = ASE_NULL;
mem->macro = ASE_NULL;
/* initialize common object pointers */
mem->nil = ase_lsp_makenil (mem);
mem->t = ase_lsp_maketrue (mem);
mem->quote = ase_lsp_makesym (mem, ASE_T("quote"), 5);
mem->lambda = ase_lsp_makesym (mem, ASE_T("lambda"), 6);
mem->macro = ase_lsp_makesym (mem, ASE_T("macro"), 5);
if (mem->nil == ASE_NULL ||
mem->t == ASE_NULL ||
mem->quote == ASE_NULL ||
mem->lambda == ASE_NULL ||
mem->macro == ASE_NULL)
{
ase_lsp_dispose_all (mem);
ase_lsp_freeframe (lsp, mem->frame);
ASE_LSP_FREE (lsp, mem);
return ASE_NULL;
}
ASE_LSP_PERM(mem->nil) = 1;
ASE_LSP_PERM(mem->t) = 1;
ASE_LSP_PERM(mem->quote) = 1;
ASE_LSP_PERM(mem->lambda) = 1;
ASE_LSP_PERM(mem->macro) = 1;
return mem;
}
void ase_lsp_closemem (ase_lsp_mem_t* mem)
{
/* dispose of the allocated objects */
ase_lsp_dispose_all (mem);
/* dispose of environment frames */
ase_lsp_freeframe (mem->lsp, mem->frame);
/* free the memory */
ASE_LSP_FREE (mem->lsp, mem);
}
ase_lsp_obj_t* ase_lsp_alloc (ase_lsp_mem_t* mem, int type, ase_size_t size)
{
ase_lsp_obj_t* obj;
/* TODO: remove the following line... */
ase_lsp_gc (mem);
if (mem->count >= mem->ubound) ase_lsp_gc (mem);
if (mem->count >= mem->ubound)
{
mem->ubound += mem->ubound_inc;
if (mem->count >= mem->ubound) return ASE_NULL;
}
obj = (ase_lsp_obj_t*) ASE_LSP_MALLOC (mem->lsp, size);
if (obj == ASE_NULL)
{
ase_lsp_gc (mem);
obj = (ase_lsp_obj_t*) ASE_LSP_MALLOC (mem->lsp, size);
if (obj == ASE_NULL)
{
ase_lsp_seterror (mem->lsp, ASE_LSP_ENOMEM, ASE_NULL, 0);
return ASE_NULL;
}
}
ASE_LSP_TYPE(obj) = type;
ASE_LSP_SIZE(obj) = size;
ASE_LSP_MARK(obj) = 0;
ASE_LSP_PERM(obj) = 0;
ASE_LSP_LOCK(obj) = 0;
/* insert the object at the head of the used list */
ASE_LSP_LINK(obj) = mem->used[type];
mem->used[type] = obj;
mem->count++;
#if 0
ase_dprint1 (ASE_T("mem->count: %u\n"), mem->count);
#endif
return obj;
}
void ase_lsp_dispose (
ase_lsp_mem_t* mem, ase_lsp_obj_t* prev, ase_lsp_obj_t* obj)
{
ASE_ASSERT (obj != ASE_NULL);
ASE_ASSERT (mem->count > 0);
/* TODO: push the object to the free list for more
* efficient memory management */
if (prev == ASE_NULL)
mem->used[ASE_LSP_TYPE(obj)] = ASE_LSP_LINK(obj);
else ASE_LSP_LINK(prev) = ASE_LSP_LINK(obj);
mem->count--;
#if 0
ase_dprint1 (ASE_T("mem->count: %u\n"), mem->count);
#endif
ASE_LSP_FREE (mem->lsp, obj);
}
void ase_lsp_dispose_all (ase_lsp_mem_t* mem)
{
ase_lsp_obj_t* obj, * next;
ase_size_t i;
for (i = 0; i < ASE_LSP_TYPE_COUNT; i++)
{
obj = mem->used[i];
while (obj != ASE_NULL)
{
next = ASE_LSP_LINK(obj);
ase_lsp_dispose (mem, ASE_NULL, obj);
obj = next;
}
}
}
static void __mark_obj (ase_lsp_t* lsp, ase_lsp_obj_t* obj)
{
ASE_ASSERT (obj != ASE_NULL);
/* TODO: can it be recursive? */
if (ASE_LSP_MARK(obj) != 0) return;
ASE_LSP_MARK(obj) = 1;
if (ASE_LSP_TYPE(obj) == ASE_LSP_OBJ_CONS)
{
__mark_obj (lsp, ASE_LSP_CAR(obj));
__mark_obj (lsp, ASE_LSP_CDR(obj));
}
else if (ASE_LSP_TYPE(obj) == ASE_LSP_OBJ_FUNC)
{
__mark_obj (lsp, ASE_LSP_FFORMAL(obj));
__mark_obj (lsp, ASE_LSP_FBODY(obj));
}
else if (ASE_LSP_TYPE(obj) == ASE_LSP_OBJ_MACRO)
{
__mark_obj (lsp, ASE_LSP_MFORMAL(obj));
__mark_obj (lsp, ASE_LSP_MBODY(obj));
}
}
/*
* ase_lsp_lockobj and ase_lsp_deepunlockobj are just called by ase_lsp_read.
*/
void ase_lsp_lockobj (ase_lsp_t* lsp, ase_lsp_obj_t* obj)
{
ASE_ASSERTX (obj != ASE_NULL,
"an object pointer should not be ASE_NULL");
if (ASE_LSP_PERM(obj) == 0) ASE_LSP_LOCK(obj)++;
}
void ase_lsp_unlockobj (ase_lsp_t* lsp, ase_lsp_obj_t* obj)
{
ASE_ASSERTX (obj != ASE_NULL,
"an object pointer should not be ASE_NULL");
if (ASE_LSP_PERM(obj) != 0) return;
ASE_ASSERTX (ASE_LSP_LOCK(obj) > 0,
"the lock count should be greater than zero to be unlocked");
ASE_LSP_LOCK(obj)--;
}
void ase_lsp_deepunlockobj (ase_lsp_t* lsp, ase_lsp_obj_t* obj)
{
ASE_ASSERTX (obj != ASE_NULL,
"an object pointer should not be ASE_NULL");
if (ASE_LSP_PERM(obj) == 0)
{
ASE_ASSERTX (ASE_LSP_LOCK(obj) > 0,
"the lock count should be greater than zero to be unlocked");
ASE_LSP_LOCK(obj)--;
}
if (ASE_LSP_TYPE(obj) == ASE_LSP_OBJ_CONS)
{
ase_lsp_deepunlockobj (lsp, ASE_LSP_CAR(obj));
ase_lsp_deepunlockobj (lsp, ASE_LSP_CDR(obj));
}
else if (ASE_LSP_TYPE(obj) == ASE_LSP_OBJ_FUNC)
{
ase_lsp_deepunlockobj (lsp, ASE_LSP_FFORMAL(obj));
ase_lsp_deepunlockobj (lsp, ASE_LSP_FBODY(obj));
}
else if (ASE_LSP_TYPE(obj) == ASE_LSP_OBJ_MACRO)
{
ase_lsp_deepunlockobj (lsp, ASE_LSP_MFORMAL(obj));
ase_lsp_deepunlockobj (lsp, ASE_LSP_MBODY(obj));
}
}
static void __mark_objs_in_use (ase_lsp_mem_t* mem)
{
ase_lsp_frame_t* frame;
ase_lsp_assoc_t* assoc;
ase_lsp_tlink_t* tlink;
/*ase_lsp_arr_t* arr;*/
/*ase_size_t i;*/
#if 0
ase_dprint0 (ASE_T("marking environment frames\n"));
#endif
/* mark objects in the environment frames */
frame = mem->frame;
while (frame != ASE_NULL)
{
assoc = frame->assoc;
while (assoc != ASE_NULL)
{
__mark_obj (mem->lsp, assoc->name);
if (assoc->value != ASE_NULL)
__mark_obj (mem->lsp, assoc->value);
if (assoc->func != ASE_NULL)
__mark_obj (mem->lsp, assoc->func);
assoc = assoc->link;
}
frame = frame->link;
}
#if 0
ase_dprint0 (ASE_T("marking interim frames\n"));
#endif
/* mark objects in the interim frames */
frame = mem->brooding_frame;
while (frame != ASE_NULL)
{
assoc = frame->assoc;
while (assoc != ASE_NULL)
{
__mark_obj (mem->lsp, assoc->name);
if (assoc->value != ASE_NULL)
__mark_obj (mem->lsp, assoc->value);
if (assoc->func != ASE_NULL)
__mark_obj (mem->lsp, assoc->func);
assoc = assoc->link;
}
frame = frame->link;
}
/* ase_dprint0 (ASE_T("marking the read object\n"));*/
if (mem->read != ASE_NULL) __mark_obj (mem->lsp, mem->read);
/* ase_dprint0 (ASE_T("marking the temporary objects\n"));*/
for (tlink = mem->tlink; tlink != ASE_NULL; tlink = tlink->link)
{
__mark_obj (mem->lsp, tlink->obj);
}
#if 0
ase_dprint0 (ASE_T("marking builtin objects\n"));
#endif
/* mark common objects */
if (mem->t != ASE_NULL) __mark_obj (mem->lsp, mem->t);
if (mem->nil != ASE_NULL) __mark_obj (mem->lsp, mem->nil);
if (mem->quote != ASE_NULL) __mark_obj (mem->lsp, mem->quote);
if (mem->lambda != ASE_NULL) __mark_obj (mem->lsp, mem->lambda);
if (mem->macro != ASE_NULL) __mark_obj (mem->lsp, mem->macro);
}
//#include <ase/utl/stdio.h>
static void __sweep_unmarked_objs (ase_lsp_mem_t* mem)
{
ase_lsp_obj_t* obj, * prev, * next;
ase_size_t i;
/* scan all the allocated objects and get rid of unused objects */
for (i = 0; i < ASE_LSP_TYPE_COUNT; i++)
{
prev = ASE_NULL;
obj = mem->used[i];
#if 0
ase_dprint1 (ASE_T("sweeping objects of type: %u\n"), i);
#endif
while (obj != ASE_NULL)
{
next = ASE_LSP_LINK(obj);
if (ASE_LSP_LOCK(obj) == 0 &&
ASE_LSP_MARK(obj) == 0 &&
ASE_LSP_PERM(obj) == 0)
{
/* dispose of unused objects */
/*
if (i == ASE_LSP_OBJ_INT)
ase_printf (ASE_T("disposing....%d [%d]\n"), i, (int)ASE_LSP_IVAL(obj));
if (i == ASE_LSP_OBJ_REAL)
ase_printf (ASE_T("disposing....%d [%Lf]\n"), i, (double)ASE_LSP_RVAL(obj));
else if (i == ASE_LSP_OBJ_SYM)
ase_printf (ASE_T("disposing....%d [%s]\n"), i, ASE_LSP_SYMPTR(obj));
else if (i == ASE_LSP_OBJ_STR)
ase_printf (ASE_T("disposing....%d [%s]\n"), i, ASE_LSP_STRPTR(obj));
else
ase_printf (ASE_T("disposing....%d\n"), i);
*/
ase_lsp_dispose (mem, prev, obj);
}
else
{
/* unmark the object in use */
ASE_LSP_MARK(obj) = 0;
prev = obj;
}
obj = next;
}
}
}
void ase_lsp_gc (ase_lsp_mem_t* mem)
{
__mark_objs_in_use (mem);
__sweep_unmarked_objs (mem);
}
ase_lsp_obj_t* ase_lsp_makenil (ase_lsp_mem_t* mem)
{
if (mem->nil != ASE_NULL) return mem->nil;
mem->nil = ase_lsp_alloc (
mem, ASE_LSP_OBJ_NIL, ASE_SIZEOF(ase_lsp_obj_nil_t));
return mem->nil;
}
ase_lsp_obj_t* ase_lsp_maketrue (ase_lsp_mem_t* mem)
{
if (mem->t != ASE_NULL) return mem->t;
mem->t = ase_lsp_alloc (
mem, ASE_LSP_OBJ_TRUE, ASE_SIZEOF(ase_lsp_obj_true_t));
return mem->t;
}
ase_lsp_obj_t* ase_lsp_makeintobj (ase_lsp_mem_t* mem, ase_long_t value)
{
ase_lsp_obj_t* obj;
obj = ase_lsp_alloc (mem,
ASE_LSP_OBJ_INT, ASE_SIZEOF(ase_lsp_obj_int_t));
if (obj == ASE_NULL) return ASE_NULL;
ASE_LSP_IVAL(obj) = value;
return obj;
}
ase_lsp_obj_t* ase_lsp_makerealobj (ase_lsp_mem_t* mem, ase_real_t value)
{
ase_lsp_obj_t* obj;
obj = ase_lsp_alloc (mem,
ASE_LSP_OBJ_REAL, ASE_SIZEOF(ase_lsp_obj_real_t));
if (obj == ASE_NULL) return ASE_NULL;
ASE_LSP_RVAL(obj) = value;
return obj;
}
ase_lsp_obj_t* ase_lsp_makesym (
ase_lsp_mem_t* mem, const ase_char_t* str, ase_size_t len)
{
ase_lsp_obj_t* obj;
/* look for a sysmbol with the given name */
obj = mem->used[ASE_LSP_OBJ_SYM];
while (obj != ASE_NULL)
{
/* if there is a symbol with the same name, it is just used. */
if (ase_strxncmp (
ASE_LSP_SYMPTR(obj),
ASE_LSP_SYMLEN(obj),
str, len) == 0) return obj;
obj = ASE_LSP_LINK(obj);
}
/* no such symbol found. create a new one */
obj = ase_lsp_alloc (mem, ASE_LSP_OBJ_SYM,
ASE_SIZEOF(ase_lsp_obj_sym_t)+(len + 1)*ASE_SIZEOF(ase_char_t));
if (obj == ASE_NULL) return ASE_NULL;
/* fill in the symbol buffer */
ase_strncpy (ASE_LSP_SYMPTR(obj), str, len);
return obj;
}
ase_lsp_obj_t* ase_lsp_makestr (
ase_lsp_mem_t* mem, const ase_char_t* str, ase_size_t len)
{
ase_lsp_obj_t* obj;
/* allocate memory for the string */
obj = ase_lsp_alloc (mem, ASE_LSP_OBJ_STR,
ASE_SIZEOF(ase_lsp_obj_str_t)+(len + 1)*ASE_SIZEOF(ase_char_t));
if (obj == ASE_NULL) return ASE_NULL;
/* fill in the string buffer */
ase_strncpy (ASE_LSP_STRPTR(obj), str, len);
return obj;
}
ase_lsp_obj_t* ase_lsp_makecons (
ase_lsp_mem_t* mem, ase_lsp_obj_t* car, ase_lsp_obj_t* cdr)
{
ase_lsp_obj_t* obj;
obj = ase_lsp_alloc (mem,
ASE_LSP_OBJ_CONS, ASE_SIZEOF(ase_lsp_obj_cons_t));
if (obj == ASE_NULL) return ASE_NULL;
ASE_LSP_CAR(obj) = car;
ASE_LSP_CDR(obj) = cdr;
return obj;
}
ase_lsp_obj_t* ase_lsp_makefunc (
ase_lsp_mem_t* mem, ase_lsp_obj_t* formal, ase_lsp_obj_t* body)
{
ase_lsp_obj_t* obj;
obj = ase_lsp_alloc (mem,
ASE_LSP_OBJ_FUNC, ASE_SIZEOF(ase_lsp_obj_func_t));
if (obj == ASE_NULL) return ASE_NULL;
ASE_LSP_FFORMAL(obj) = formal;
ASE_LSP_FBODY(obj) = body;
return obj;
}
ase_lsp_obj_t* ase_lsp_makemacro (
ase_lsp_mem_t* mem, ase_lsp_obj_t* formal, ase_lsp_obj_t* body)
{
ase_lsp_obj_t* obj;
obj = ase_lsp_alloc (mem,
ASE_LSP_OBJ_MACRO, ASE_SIZEOF(ase_lsp_obj_macro_t));
if (obj == ASE_NULL) return ASE_NULL;
ASE_LSP_MFORMAL(obj) = formal;
ASE_LSP_MBODY(obj) = body;
return obj;
}
ase_lsp_obj_t* ase_lsp_makeprim (ase_lsp_mem_t* mem,
ase_lsp_prim_t impl, ase_size_t min_args, ase_size_t max_args)
{
ase_lsp_obj_t* obj;
obj = ase_lsp_alloc (
mem, ASE_LSP_OBJ_PRIM, ASE_SIZEOF(ase_lsp_obj_prim_t));
if (obj == ASE_NULL) return ASE_NULL;
ASE_LSP_PIMPL(obj) = impl;
ASE_LSP_PMINARGS(obj) = min_args;
ASE_LSP_PMAXARGS(obj) = max_args;
return obj;
}
ase_lsp_assoc_t* ase_lsp_lookup (ase_lsp_mem_t* mem, ase_lsp_obj_t* name)
{
ase_lsp_frame_t* frame;
ase_lsp_assoc_t* assoc;
ASE_ASSERT (ASE_LSP_TYPE(name) == ASE_LSP_OBJ_SYM);
frame = mem->frame;
while (frame != ASE_NULL)
{
assoc = ase_lsp_lookupinframe (mem->lsp, frame, name);
if (assoc != ASE_NULL) return assoc;
frame = frame->link;
}
return ASE_NULL;
}
ase_lsp_assoc_t* ase_lsp_setvalue (
ase_lsp_mem_t* mem, ase_lsp_obj_t* name, ase_lsp_obj_t* value)
{
ase_lsp_assoc_t* assoc;
assoc = ase_lsp_lookup (mem, name);
if (assoc == ASE_NULL)
{
assoc = ase_lsp_insvalueintoframe (
mem->lsp, mem->root_frame, name, value);
if (assoc == ASE_NULL) return ASE_NULL;
}
else assoc->value = value;
return assoc;
}
ase_lsp_assoc_t* ase_lsp_setfunc (
ase_lsp_mem_t* mem, ase_lsp_obj_t* name, ase_lsp_obj_t* func)
{
ase_lsp_assoc_t* assoc;
assoc = ase_lsp_lookup (mem, name);
if (assoc == ASE_NULL)
{
assoc = ase_lsp_insfuncintoframe (
mem->lsp, mem->root_frame, name, func);
if (assoc == ASE_NULL) return ASE_NULL;
}
else assoc->func = func;
return assoc;
}
ase_size_t ase_lsp_conslen (ase_lsp_mem_t* mem, ase_lsp_obj_t* obj)
{
ase_size_t count;
ASE_ASSERT (
obj == mem->nil || ASE_LSP_TYPE(obj) == ASE_LSP_OBJ_CONS);
count = 0;
/*while (obj != mem->nil) {*/
while (ASE_LSP_TYPE(obj) == ASE_LSP_OBJ_CONS)
{
count++;
obj = ASE_LSP_CDR(obj);
}
return count;
}

99
ase/lib/lsp/mem.h Normal file
View File

@ -0,0 +1,99 @@
/*
* $Id: mem.h 117 2008-03-03 11:20:05Z baconevi $
*
* {License}
*/
#ifndef _ASE_LSP_MEM_H_
#define _ASE_LSP_MEM_H_
#ifndef _ASE_LSP_LSP_H_
#error Never include this file directly. Include <ase/lsp/lsp.h> instead
#endif
typedef struct ase_lsp_mem_t ase_lsp_mem_t;
struct ase_lsp_mem_t
{
ase_lsp_t* lsp;
/* object allocation list */
ase_size_t ubound; /* upper bounds of the maximum number of objects */
ase_size_t ubound_inc; /* increment of the upper bounds */
ase_size_t count; /* the number of objects currently allocated */
ase_lsp_obj_t* used[ASE_LSP_TYPE_COUNT];
ase_lsp_obj_t* free[ASE_LSP_TYPE_COUNT];
ase_lsp_obj_t* read;
/* commonly accessed objects */
ase_lsp_obj_t* nil; /* ase_lsp_obj_nil_t */
ase_lsp_obj_t* t; /* ase_lsp_obj_true_t */
ase_lsp_obj_t* quote; /* ase_lsp_obj_sym_t */
ase_lsp_obj_t* lambda; /* ase_lsp_obj_sym_t */
ase_lsp_obj_t* macro; /* ase_lsp_obj_sym_t */
/* run-time environment frame */
ase_lsp_frame_t* frame;
/* pointer to a global-level frame */
ase_lsp_frame_t* root_frame;
/* pointer to an interim frame not yet added to "frame" */
ase_lsp_frame_t* brooding_frame;
/* links for temporary objects */
ase_lsp_tlink_t* tlink;
ase_size_t tlink_count;
};
#ifdef __cplusplus
extern "C" {
#endif
ase_lsp_mem_t* ase_lsp_openmem (
ase_lsp_t* lsp, ase_size_t ubound, ase_size_t ubound_inc);
void ase_lsp_closemem (ase_lsp_mem_t* mem);
ase_lsp_obj_t* ase_lsp_alloc (ase_lsp_mem_t* mem, int type, ase_size_t size);
void ase_lsp_dispose (ase_lsp_mem_t* mem, ase_lsp_obj_t* prev, ase_lsp_obj_t* obj);
void ase_lsp_dispose_all (ase_lsp_mem_t* mem);
void ase_lsp_gc (ase_lsp_mem_t* mem);
void ase_lsp_lockobj (ase_lsp_t* lsp, ase_lsp_obj_t* obj);
void ase_lsp_unlockobj (ase_lsp_t* lsp, ase_lsp_obj_t* obj);
void ase_lsp_deepunlockobj (ase_lsp_t* lsp, ase_lsp_obj_t* obj);
/* object creation of standard types */
ase_lsp_obj_t* ase_lsp_makenil (ase_lsp_mem_t* mem);
ase_lsp_obj_t* ase_lsp_maketrue (ase_lsp_mem_t* mem);
ase_lsp_obj_t* ase_lsp_makeintobj (ase_lsp_mem_t* mem, ase_long_t value);
ase_lsp_obj_t* ase_lsp_makerealobj (ase_lsp_mem_t* mem, ase_real_t value);
ase_lsp_obj_t* ase_lsp_makesym (
ase_lsp_mem_t* mem, const ase_char_t* str, ase_size_t len);
ase_lsp_obj_t* ase_lsp_makestr (
ase_lsp_mem_t* mem, const ase_char_t* str, ase_size_t len);
ase_lsp_obj_t* ase_lsp_makecons (
ase_lsp_mem_t* mem, ase_lsp_obj_t* car, ase_lsp_obj_t* cdr);
ase_lsp_obj_t* ase_lsp_makefunc (
ase_lsp_mem_t* mem, ase_lsp_obj_t* formal, ase_lsp_obj_t* body);
ase_lsp_obj_t* ase_lsp_makemacro (
ase_lsp_mem_t* mem, ase_lsp_obj_t* formal, ase_lsp_obj_t* body);
ase_lsp_obj_t* ase_lsp_makeprim (ase_lsp_mem_t* mem,
ase_lsp_prim_t impl, ase_size_t min_args, ase_size_t max_args);
/* frame lookup */
ase_lsp_assoc_t* ase_lsp_lookup (ase_lsp_mem_t* mem, ase_lsp_obj_t* name);
ase_lsp_assoc_t* ase_lsp_setvalue (
ase_lsp_mem_t* mem, ase_lsp_obj_t* name, ase_lsp_obj_t* value);
ase_lsp_assoc_t* ase_lsp_setfunc (
ase_lsp_mem_t* mem, ase_lsp_obj_t* name, ase_lsp_obj_t* func);
/* cons operations */
ase_size_t ase_lsp_conslen (ase_lsp_mem_t* mem, ase_lsp_obj_t* obj);
#ifdef __cplusplus
}
#endif
#endif

575
ase/lib/lsp/misc.c Normal file
View File

@ -0,0 +1,575 @@
/*
* $Id: misc.c 117 2008-03-03 11:20:05Z baconevi $
*
* {License}
*/
#include <ase/lsp/lsp_i.h>
ase_long_t ase_lsp_strxtolong (
ase_lsp_t* lsp, const ase_char_t* str, ase_size_t len,
int base, const ase_char_t** endptr)
{
ase_long_t n = 0;
const ase_char_t* p;
const ase_char_t* end;
ase_size_t rem;
int digit, negative = 0;
ASE_ASSERT (base < 37);
p = str;
end = str + len;
/* strip off leading spaces */
/*while (ASE_LSP_ISSPACE(lsp,*p)) p++;*/
/* check for a sign */
/*while (*p != ASE_T('\0')) */
while (p < end)
{
if (*p == ASE_T('-'))
{
negative = ~negative;
p++;
}
else if (*p == ASE_T('+')) p++;
else break;
}
/* check for a binary/octal/hexadecimal notation */
rem = end - p;
if (base == 0)
{
if (rem >= 1 && *p == ASE_T('0'))
{
p++;
if (rem == 1) base = 8;
else if (*p == ASE_T('x') || *p == ASE_T('X'))
{
p++; base = 16;
}
else if (*p == ASE_T('b') || *p == ASE_T('B'))
{
p++; base = 2;
}
else base = 8;
}
else base = 10;
}
else if (rem >= 2 && base == 16)
{
if (*p == ASE_T('0') &&
(*(p+1) == ASE_T('x') || *(p+1) == ASE_T('X'))) p += 2;
}
else if (rem >= 2 && base == 2)
{
if (*p == ASE_T('0') &&
(*(p+1) == ASE_T('b') || *(p+1) == ASE_T('B'))) p += 2;
}
/* process the digits */
/*while (*p != ASE_T('\0'))*/
while (p < end)
{
if (*p >= ASE_T('0') && *p <= ASE_T('9'))
digit = *p - ASE_T('0');
else if (*p >= ASE_T('A') && *p <= ASE_T('Z'))
digit = *p - ASE_T('A') + 10;
else if (*p >= ASE_T('a') && *p <= ASE_T('z'))
digit = *p - ASE_T('a') + 10;
else break;
if (digit >= base) break;
n = n * base + digit;
p++;
}
if (endptr != ASE_NULL) *endptr = p;
return (negative)? -n: n;
}
/*
* ase_lsp_strtoreal is almost a replica of strtod.
*
* strtod.c --
*
* Source code for the "strtod" library procedure.
*
* Copyright (c) 1988-1993 The Regents of the University of California.
* Copyright (c) 1994 Sun Microsystems, Inc.
*
* Permission to use, copy, modify, and distribute this
* software and its documentation for any purpose and without
* fee is hereby granted, provided that the above copyright
* notice appear in all copies. The University of California
* makes no representations about the suitability of this
* software for any purpose. It is provided "as is" without
* express or implied warranty.
*/
#define MAX_EXPONENT 511
ase_real_t ase_lsp_strtoreal (ase_lsp_t* lsp, const ase_char_t* str)
{
/*
* Table giving binary powers of 10. Entry is 10^2^i.
* Used to convert decimal exponents into floating-point numbers.
*/
static ase_real_t powers_of_10[] =
{
10., 100., 1.0e4, 1.0e8, 1.0e16,
1.0e32, 1.0e64, 1.0e128, 1.0e256
};
ase_real_t fraction, dbl_exp, * d;
const ase_char_t* p;
ase_cint_t c;
int exp = 0; /* Esseonent read from "EX" field */
/*
* Esseonent that derives from the fractional part. Under normal
* circumstatnces, it is the negative of the number of digits in F.
* However, if I is very long, the last digits of I get dropped
* (otherwise a long I with a large negative exponent could cause an
* unnecessary overflow on I alone). In this case, frac_exp is
* incremented one for each dropped digit.
*/
int frac_exp;
int mant_size; /* Number of digits in mantissa. */
int dec_pt; /* Number of mantissa digits BEFORE decimal point */
const ase_char_t *pexp; /* Temporarily holds location of exponent in string */
int negative = 0, exp_negative = 0;
p = str;
/* strip off leading blanks */
/*while (ASE_LSP_ISSPACE(lsp,*p)) p++;*/
/* check for a sign */
while (*p != ASE_T('\0'))
{
if (*p == ASE_T('-'))
{
negative = ~negative;
p++;
}
else if (*p == ASE_T('+')) p++;
else break;
}
/* Count the number of digits in the mantissa (including the decimal
* point), and also locate the decimal point. */
dec_pt = -1;
for (mant_size = 0; ; mant_size++)
{
c = *p;
if (!ASE_LSP_ISDIGIT (lsp, c))
{
if ((c != ASE_T('.')) || (dec_pt >= 0)) break;
dec_pt = mant_size;
}
p++;
}
/*
* Now suck up the digits in the mantissa. Use two integers to
* collect 9 digits each (this is faster than using floating-point).
* If the mantissa has more than 18 digits, ignore the extras, since
* they can't affect the value anyway.
*/
pexp = p;
p -= mant_size;
if (dec_pt < 0)
{
dec_pt = mant_size;
}
else
{
mant_size--; /* One of the digits was the point */
}
if (mant_size > 18)
{
frac_exp = dec_pt - 18;
mant_size = 18;
}
else
{
frac_exp = dec_pt - mant_size;
}
if (mant_size == 0)
{
fraction = 0.0;
/*p = str;*/
p = pexp;
goto done;
}
else
{
int frac1, frac2;
frac1 = 0;
for ( ; mant_size > 9; mant_size--)
{
c = *p;
p++;
if (c == ASE_T('.'))
{
c = *p;
p++;
}
frac1 = 10 * frac1 + (c - ASE_T('0'));
}
frac2 = 0;
for (; mant_size > 0; mant_size--) {
c = *p;
p++;
if (c == ASE_T('.'))
{
c = *p;
p++;
}
frac2 = 10*frac2 + (c - ASE_T('0'));
}
fraction = (1.0e9 * frac1) + frac2;
}
/* Skim off the exponent */
p = pexp;
if ((*p == ASE_T('E')) || (*p == ASE_T('e')))
{
p++;
if (*p == ASE_T('-'))
{
exp_negative = 1;
p++;
}
else
{
if (*p == ASE_T('+')) p++;
exp_negative = 0;
}
if (!ASE_LSP_ISDIGIT (lsp, *p))
{
/* p = pexp; */
/* goto done; */
goto no_exp;
}
while (ASE_LSP_ISDIGIT (lsp, *p))
{
exp = exp * 10 + (*p - ASE_T('0'));
p++;
}
}
no_exp:
if (exp_negative) exp = frac_exp - exp;
else exp = frac_exp + exp;
/*
* Generate a floating-point number that represents the exponent.
* Do this by processing the exponent one bit at a time to combine
* many powers of 2 of 10. Then combine the exponent with the
* fraction.
*/
if (exp < 0)
{
exp_negative = 1;
exp = -exp;
}
else exp_negative = 0;
if (exp > MAX_EXPONENT) exp = MAX_EXPONENT;
dbl_exp = 1.0;
for (d = powers_of_10; exp != 0; exp >>= 1, d++)
{
if (exp & 01) dbl_exp *= *d;
}
if (exp_negative) fraction /= dbl_exp;
else fraction *= dbl_exp;
done:
return (negative)? -fraction: fraction;
}
ase_real_t ase_lsp_strxtoreal (
ase_lsp_t* lsp, const ase_char_t* str, ase_size_t len,
const ase_char_t** endptr)
{
/*
* Table giving binary powers of 10. Entry is 10^2^i.
* Used to convert decimal exponents into floating-point numbers.
*/
static ase_real_t powers_of_10[] =
{
10., 100., 1.0e4, 1.0e8, 1.0e16,
1.0e32, 1.0e64, 1.0e128, 1.0e256
};
ase_real_t fraction, dbl_exp, * d;
const ase_char_t* p, * end;
ase_cint_t c;
int exp = 0; /* Esseonent read from "EX" field */
/*
* Esseonent that derives from the fractional part. Under normal
* circumstatnces, it is the negative of the number of digits in F.
* However, if I is very long, the last digits of I get dropped
* (otherwise a long I with a large negative exponent could cause an
* unnecessary overflow on I alone). In this case, frac_exp is
* incremented one for each dropped digit.
*/
int frac_exp;
int mant_size; /* Number of digits in mantissa. */
int dec_pt; /* Number of mantissa digits BEFORE decimal point */
const ase_char_t *pexp; /* Temporarily holds location of exponent in string */
int negative = 0, exp_negative = 0;
p = str;
end = str + len;
/* Strip off leading blanks and check for a sign */
/*while (ASE_LSP_ISSPACE(lsp,*p)) p++;*/
/*while (*p != ASE_T('\0')) */
while (p < end)
{
if (*p == ASE_T('-'))
{
negative = ~negative;
p++;
}
else if (*p == ASE_T('+')) p++;
else break;
}
/* Count the number of digits in the mantissa (including the decimal
* point), and also locate the decimal point. */
dec_pt = -1;
/*for (mant_size = 0; ; mant_size++) */
for (mant_size = 0; p < end; mant_size++)
{
c = *p;
if (!ASE_LSP_ISDIGIT (lsp, c))
{
if (c != ASE_T('.') || dec_pt >= 0) break;
dec_pt = mant_size;
}
p++;
}
/*
* Now suck up the digits in the mantissa. Use two integers to
* collect 9 digits each (this is faster than using floating-point).
* If the mantissa has more than 18 digits, ignore the extras, since
* they can't affect the value anyway.
*/
pexp = p;
p -= mant_size;
if (dec_pt < 0)
{
dec_pt = mant_size;
}
else
{
mant_size--; /* One of the digits was the point */
}
if (mant_size > 18) /* TODO: is 18 correct for ase_real_t??? */
{
frac_exp = dec_pt - 18;
mant_size = 18;
}
else
{
frac_exp = dec_pt - mant_size;
}
if (mant_size == 0)
{
fraction = 0.0;
/*p = str;*/
p = pexp;
goto done;
}
else
{
int frac1, frac2;
frac1 = 0;
for ( ; mant_size > 9; mant_size--)
{
c = *p;
p++;
if (c == ASE_T('.'))
{
c = *p;
p++;
}
frac1 = 10 * frac1 + (c - ASE_T('0'));
}
frac2 = 0;
for (; mant_size > 0; mant_size--) {
c = *p++;
if (c == ASE_T('.'))
{
c = *p;
p++;
}
frac2 = 10 * frac2 + (c - ASE_T('0'));
}
fraction = (1.0e9 * frac1) + frac2;
}
/* Skim off the exponent */
p = pexp;
if (p < end && (*p == ASE_T('E') || *p == ASE_T('e')))
{
p++;
if (p < end)
{
if (*p == ASE_T('-'))
{
exp_negative = 1;
p++;
}
else
{
if (*p == ASE_T('+')) p++;
exp_negative = 0;
}
}
else exp_negative = 0;
if (!(p < end && ASE_LSP_ISDIGIT (lsp, *p)))
{
/*p = pexp;*/
/*goto done;*/
goto no_exp;
}
while (p < end && ASE_LSP_ISDIGIT (lsp, *p))
{
exp = exp * 10 + (*p - ASE_T('0'));
p++;
}
}
no_exp:
if (exp_negative) exp = frac_exp - exp;
else exp = frac_exp + exp;
/*
* Generate a floating-point number that represents the exponent.
* Do this by processing the exponent one bit at a time to combine
* many powers of 2 of 10. Then combine the exponent with the
* fraction.
*/
if (exp < 0)
{
exp_negative = 1;
exp = -exp;
}
else exp_negative = 0;
if (exp > MAX_EXPONENT) exp = MAX_EXPONENT;
dbl_exp = 1.0;
for (d = powers_of_10; exp != 0; exp >>= 1, d++)
{
if (exp & 01) dbl_exp *= *d;
}
if (exp_negative) fraction /= dbl_exp;
else fraction *= dbl_exp;
done:
if (endptr != ASE_NULL) *endptr = p;
return (negative)? -fraction: fraction;
}
ase_size_t ase_lsp_longtostr (
ase_long_t value, int radix, const ase_char_t* prefix,
ase_char_t* buf, ase_size_t size)
{
ase_long_t t, rem;
ase_size_t len, ret, i;
ase_size_t prefix_len;
prefix_len = (prefix != ASE_NULL)? ase_strlen(prefix): 0;
t = value;
if (t == 0)
{
/* zero */
if (buf == ASE_NULL) return prefix_len + 1;
if (size < prefix_len+1)
{
/* buffer too small */
return (ase_size_t)-1;
}
for (i = 0; i < prefix_len; i++) buf[i] = prefix[i];
buf[prefix_len] = ASE_T('0');
if (size > prefix_len+1) buf[prefix_len+1] = ASE_T('\0');
return 1;
}
/* non-zero values */
len = prefix_len;
if (t < 0) { t = -t; len++; }
while (t > 0) { len++; t /= radix; }
if (buf == ASE_NULL)
{
/* if buf is not given, return the number of bytes required */
return len;
}
if (size < len) return (ase_size_t)-1; /* buffer too small */
if (size > len) buf[len] = ASE_T('\0');
ret = len;
t = value;
if (t < 0) t = -t;
while (t > 0)
{
rem = t % radix;
if (rem >= 10)
buf[--len] = (ase_char_t)rem + ASE_T('a') - 10;
else
buf[--len] = (ase_char_t)rem + ASE_T('0');
t /= radix;
}
if (value < 0)
{
for (i = 1; i <= prefix_len; i++)
{
buf[i] = prefix[i-1];
len--;
}
buf[--len] = ASE_T('-');
}
else
{
for (i = 0; i < prefix_len; i++) buf[i] = prefix[i];
}
return ret;
}

26
ase/lib/lsp/misc.h Normal file
View File

@ -0,0 +1,26 @@
/*
* $Id: misc.h 117 2008-03-03 11:20:05Z baconevi $
*
* {License}
*/
#ifndef _ASE_LSP_MISC_H_
#define _ASE_LSP_MISC_H_
#ifndef _ASE_LSP_LSP_H_
#error Never include this file directly. Include <ase/lsp/lsp.h> instead
#endif
#ifdef __cplusplus
extern "C" {
#endif
void* ase_lsp_memcpy (void* dst, const void* src, ase_size_t n);
void* ase_lsp_memset (void* dst, int val, ase_size_t n);
#ifdef __cplusplus
}
#endif
#endif

125
ase/lib/lsp/name.c Normal file
View File

@ -0,0 +1,125 @@
/*
* $Id: name.c 117 2008-03-03 11:20:05Z baconevi $
*
* {License}
*/
#include <ase/lsp/lsp_i.h>
ase_lsp_name_t* ase_lsp_name_open (
ase_lsp_name_t* name, ase_size_t capa, ase_lsp_t* lsp)
{
if (capa == 0) capa = ASE_COUNTOF(name->static_buf) - 1;
if (name == ASE_NULL)
{
name = (ase_lsp_name_t*)
ASE_LSP_MALLOC (lsp, ASE_SIZEOF(ase_lsp_name_t));
if (name == ASE_NULL) return ASE_NULL;
name->__dynamic = ase_true;
}
else name->__dynamic = ase_false;
if (capa < ASE_COUNTOF(name->static_buf))
{
name->buf = name->static_buf;
}
else
{
name->buf = (ase_char_t*)
ASE_LSP_MALLOC (lsp, (capa+1)*ASE_SIZEOF(ase_char_t));
if (name->buf == ASE_NULL)
{
if (name->__dynamic) ASE_LSP_FREE (lsp, name);
return ASE_NULL;
}
}
name->size = 0;
name->capa = capa;
name->buf[0] = ASE_T('\0');
name->lsp = lsp;
return name;
}
void ase_lsp_name_close (ase_lsp_name_t* name)
{
if (name->capa >= ASE_COUNTOF(name->static_buf))
{
ASE_ASSERT (name->buf != name->static_buf);
ASE_LSP_FREE (name->lsp, name->buf);
}
if (name->__dynamic) ASE_LSP_FREE (name->lsp, name);
}
int ase_lsp_name_addc (ase_lsp_name_t* name, ase_cint_t c)
{
if (name->size >= name->capa)
{
/* double the capacity */
ase_size_t new_capa = name->capa * 2;
if (new_capa >= ASE_COUNTOF(name->static_buf))
{
ase_char_t* space;
if (name->capa < ASE_COUNTOF(name->static_buf))
{
space = (ase_char_t*) ASE_LSP_MALLOC (
name->lsp, (new_capa+1)*ASE_SIZEOF(ase_char_t));
if (space == ASE_NULL) return -1;
/* don't need to copy up to the terminating null */
ase_memcpy (space, name->buf, name->capa*ASE_SIZEOF(ase_char_t));
}
else
{
space = (ase_char_t*) ASE_LSP_REALLOC (
name->lsp, name->buf,
(new_capa+1)*ASE_SIZEOF(ase_char_t));
if (space == ASE_NULL) return -1;
}
name->buf = space;
}
name->capa = new_capa;
}
name->buf[name->size++] = c;
name->buf[name->size] = ASE_T('\0');
return 0;
}
int ase_lsp_name_adds (ase_lsp_name_t* name, const ase_char_t* s)
{
while (*s != ASE_T('\0'))
{
if (ase_lsp_name_addc(name, *s) == -1) return -1;
s++;
}
return 0;
}
void ase_lsp_name_clear (ase_lsp_name_t* name)
{
name->size = 0;
name->buf[0] = ASE_T('\0');
}
int ase_lsp_name_compare (ase_lsp_name_t* name, const ase_char_t* str)
{
ase_char_t* p = name->buf;
ase_size_t index = 0;
while (index < name->size)
{
if (*p > *str) return 1;
if (*p < *str) return -1;
index++; p++; str++;
}
return (*str == ASE_T('\0'))? 0: -1;
}

42
ase/lib/lsp/name.h Normal file
View File

@ -0,0 +1,42 @@
/*
* $Id: name.h 117 2008-03-03 11:20:05Z baconevi $
*
* {License}
*/
#ifndef _ASE_LSP_NAME_H_
#define _ASE_LSP_NAME_H_
#include <ase/cmn/types.h>
#include <ase/cmn/macros.h>
struct ase_lsp_name_t
{
ase_size_t capa;
ase_size_t size;
ase_char_t* buf;
ase_char_t static_buf[128];
ase_lsp_t* lsp;
ase_bool_t __dynamic;
};
typedef struct ase_lsp_name_t ase_lsp_name_t;
#ifdef __cplusplus
extern "C" {
#endif
ase_lsp_name_t* ase_lsp_name_open (
ase_lsp_name_t* name, ase_size_t capa, ase_lsp_t* lsp);
void ase_lsp_name_close (ase_lsp_name_t* name);
int ase_lsp_name_addc (ase_lsp_name_t* name, ase_cint_t c);
int ase_lsp_name_adds (ase_lsp_name_t* name, const ase_char_t* s);
void ase_lsp_name_clear (ase_lsp_name_t* name);
int ase_lsp_name_compare (ase_lsp_name_t* name, const ase_char_t* str);
#ifdef __cplusplus
}
#endif
#endif

161
ase/lib/lsp/obj.h Normal file
View File

@ -0,0 +1,161 @@
/*
* $Id: obj.h 117 2008-03-03 11:20:05Z baconevi $
*
* {License}
*/
#ifndef _ASE_LSP_OBJ_H_
#define _ASE_LSP_OBJ_H_
#ifndef _ASE_LSP_LSP_H_
#error Never include this file directly. Include <ase/lsp/lsp.h> instead
#endif
/* object types */
enum
{
ASE_LSP_OBJ_NIL = 0,
ASE_LSP_OBJ_TRUE,
ASE_LSP_OBJ_INT,
ASE_LSP_OBJ_REAL,
ASE_LSP_OBJ_SYM,
ASE_LSP_OBJ_STR,
ASE_LSP_OBJ_CONS,
ASE_LSP_OBJ_FUNC,
ASE_LSP_OBJ_MACRO,
ASE_LSP_OBJ_PRIM,
ASE_LSP_TYPE_COUNT /* the number of lsp object types */
};
typedef struct ase_lsp_objhdr_t ase_lsp_objhdr_t;
typedef struct ase_lsp_obj_nil_t ase_lsp_obj_nil_t;
typedef struct ase_lsp_obj_true_t ase_lsp_obj_true_t;
typedef struct ase_lsp_obj_int_t ase_lsp_obj_int_t;
typedef struct ase_lsp_obj_real_t ase_lsp_obj_real_t;
typedef struct ase_lsp_obj_sym_t ase_lsp_obj_sym_t;
typedef struct ase_lsp_obj_str_t ase_lsp_obj_str_t;
typedef struct ase_lsp_obj_cons_t ase_lsp_obj_cons_t;
typedef struct ase_lsp_obj_func_t ase_lsp_obj_func_t;
typedef struct ase_lsp_obj_macro_t ase_lsp_obj_macro_t;
typedef struct ase_lsp_obj_prim_t ase_lsp_obj_prim_t;
struct ase_lsp_objhdr_t
{
ase_uint32_t type: 8;
ase_uint32_t mark: 4;
ase_uint32_t perm: 4;
ase_uint32_t lock: 16;
ase_size_t size;
ase_lsp_obj_t* link;
};
struct ase_lsp_obj_t
{
ase_lsp_objhdr_t hdr;
};
struct ase_lsp_obj_nil_t
{
ase_lsp_objhdr_t hdr;
};
struct ase_lsp_obj_true_t
{
ase_lsp_objhdr_t hdr;
};
struct ase_lsp_obj_int_t
{
ase_lsp_objhdr_t hdr;
ase_long_t value;
};
struct ase_lsp_obj_real_t
{
ase_lsp_objhdr_t hdr;
ase_real_t value;
};
struct ase_lsp_obj_sym_t
{
ase_lsp_objhdr_t hdr;
#if defined(__GNUC__)
ase_char_t buffer[0];
#endif
};
struct ase_lsp_obj_str_t
{
ase_lsp_objhdr_t hdr;
#if defined(__GNUC__)
ase_char_t buffer[0];
#endif
};
struct ase_lsp_obj_cons_t
{
ase_lsp_objhdr_t hdr;
ase_lsp_obj_t* car;
ase_lsp_obj_t* cdr;
};
struct ase_lsp_obj_func_t
{
ase_lsp_objhdr_t hdr;
ase_lsp_obj_t* formal;
ase_lsp_obj_t* body;
};
struct ase_lsp_obj_macro_t
{
ase_lsp_objhdr_t hdr;
ase_lsp_obj_t* formal;
ase_lsp_obj_t* body;
};
struct ase_lsp_obj_prim_t
{
ase_lsp_objhdr_t hdr;
ase_lsp_prim_t impl;
ase_size_t min_args;
ase_size_t max_args;
};
/* header access */
#define ASE_LSP_TYPE(x) (((ase_lsp_obj_t*)x)->hdr.type)
#define ASE_LSP_SIZE(x) (((ase_lsp_obj_t*)x)->hdr.size)
#define ASE_LSP_MARK(x) (((ase_lsp_obj_t*)x)->hdr.mark)
#define ASE_LSP_PERM(x) (((ase_lsp_obj_t*)x)->hdr.perm)
#define ASE_LSP_LOCK(x) (((ase_lsp_obj_t*)x)->hdr.lock)
#define ASE_LSP_LINK(x) (((ase_lsp_obj_t*)x)->hdr.link)
/* value access */
#define ASE_LSP_IVAL(x) (((ase_lsp_obj_int_t*)x)->value)
#define ASE_LSP_RVAL(x) (((ase_lsp_obj_real_t*)x)->value)
#if defined(__GNUC__)
#define ASE_LSP_SYMPTR(x) (((ase_lsp_obj_sym_t*)x)->buffer)
#else
#define ASE_LSP_SYMPTR(x) ((ase_char_t*)(((ase_lsp_obj_sym_t*)x) + 1))
#endif
#define ASE_LSP_SYMLEN(x) ((((ase_lsp_obj_sym_t*)x)->hdr.size - sizeof(ase_lsp_obj_t)) / sizeof(ase_char_t) - 1)
#if defined(__GNUC__)
#define ASE_LSP_STRPTR(x) (((ase_lsp_obj_str_t*)x)->buffer)
#else
#define ASE_LSP_STRPTR(x) ((ase_char_t*)(((ase_lsp_obj_str_t*)x) + 1))
#endif
#define ASE_LSP_STRLEN(x) ((((ase_lsp_obj_str_t*)x)->hdr.size - sizeof(ase_lsp_obj_t)) / sizeof(ase_char_t) - 1)
#define ASE_LSP_CAR(x) (((ase_lsp_obj_cons_t*)x)->car)
#define ASE_LSP_CDR(x) (((ase_lsp_obj_cons_t*)x)->cdr)
#define ASE_LSP_FFORMAL(x) (((ase_lsp_obj_func_t*)x)->formal)
#define ASE_LSP_FBODY(x) (((ase_lsp_obj_func_t*)x)->body)
#define ASE_LSP_MFORMAL(x) (((ase_lsp_obj_macro_t*)x)->formal)
#define ASE_LSP_MBODY(x) (((ase_lsp_obj_macro_t*)x)->body)
#define ASE_LSP_PIMPL(x) (((ase_lsp_obj_prim_t*)x)->impl)
#define ASE_LSP_PMINARGS(x) (((ase_lsp_obj_prim_t*)x)->min_args)
#define ASE_LSP_PMAXARGS(x) (((ase_lsp_obj_prim_t*)x)->max_args)
#endif

621
ase/lib/lsp/prim.c Normal file
View File

@ -0,0 +1,621 @@
/*
* $Id: prim.c 117 2008-03-03 11:20:05Z baconevi $
*
* {License}
*/
#include <ase/lsp/lsp_i.h>
static int __add_prim (ase_lsp_mem_t* mem,
const ase_char_t* name, ase_size_t len,
ase_lsp_prim_t pimpl, ase_size_t min_args, ase_size_t max_args);
int ase_lsp_addprim (
ase_lsp_t* lsp, const ase_char_t* name, ase_size_t name_len,
ase_lsp_prim_t prim, ase_size_t min_args, ase_size_t max_args)
{
return __add_prim (lsp->mem, name, name_len, prim, min_args, max_args);
}
int ase_lsp_removeprim (ase_lsp_t* lsp, const ase_char_t* name)
{
/* TODO: */
return -1;
}
static int __add_prim (ase_lsp_mem_t* mem,
const ase_char_t* name, ase_size_t name_len,
ase_lsp_prim_t pimpl, ase_size_t min_args, ase_size_t max_args)
{
ase_lsp_obj_t* n, * p;
n = ase_lsp_makesym (mem, name, name_len);
if (n == ASE_NULL) return -1;
if (ase_lsp_pushtmp (mem->lsp, n) == ASE_NULL) return -1;
p = ase_lsp_makeprim (mem, pimpl, min_args, max_args);
if (p == ASE_NULL)
{
ase_lsp_poptmp (mem->lsp);
return -1;
}
if (ase_lsp_pushtmp (mem->lsp, p) == ASE_NULL)
{
ase_lsp_poptmp (mem->lsp);
return -1;
}
if (ase_lsp_setfunc(mem, n, p) == ASE_NULL)
{
ase_lsp_poptmp (mem->lsp);
ase_lsp_poptmp (mem->lsp);
return -1;
}
ase_lsp_poptmp (mem->lsp);
ase_lsp_poptmp (mem->lsp);
return 0;
}
ase_lsp_obj_t* ase_lsp_prim_exit (ase_lsp_t* lsp, ase_lsp_obj_t* args)
{
lsp->errnum = ASE_LSP_EEXIT;
return ASE_NULL;
}
ase_lsp_obj_t* ase_lsp_prim_eval (ase_lsp_t* lsp, ase_lsp_obj_t* args)
{
ase_lsp_obj_t* tmp1, * tmp2;
ASE_ASSERT (ASE_LSP_TYPE(args) == ASE_LSP_OBJ_CONS);
tmp1 = ase_lsp_eval (lsp, ASE_LSP_CAR(args));
if (tmp1 == ASE_NULL) return ASE_NULL;
if (ase_lsp_pushtmp (lsp, tmp1) == ASE_NULL) return ASE_NULL;
tmp2 = ase_lsp_eval (lsp, tmp1);
if (tmp2 == ASE_NULL)
{
ase_lsp_poptmp (lsp);
return ASE_NULL;
}
ase_lsp_poptmp (lsp);
return tmp2;
}
ase_lsp_obj_t* ase_lsp_prim_gc (ase_lsp_t* lsp, ase_lsp_obj_t* args)
{
ase_lsp_gc (lsp->mem);
return lsp->mem->nil;
}
ase_lsp_obj_t* ase_lsp_prim_cond (ase_lsp_t* lsp, ase_lsp_obj_t* args)
{
/*
* (cond
* (condition1 result1)
* (consition2 result2)
* ...
* (t resultN))
*/
ase_lsp_obj_t* tmp, * ret;
while (ASE_LSP_TYPE(args) == ASE_LSP_OBJ_CONS)
{
if (ASE_LSP_TYPE(ASE_LSP_CAR(args)) != ASE_LSP_OBJ_CONS)
{
ase_lsp_seterror (lsp, ASE_LSP_EARGBAD, ASE_NULL, 0);
return ASE_NULL;
}
tmp = ase_lsp_eval (lsp, ASE_LSP_CAR(ASE_LSP_CAR(args)));
if (tmp == ASE_NULL) return ASE_NULL;
if (ase_lsp_pushtmp (lsp, tmp) == ASE_NULL) return ASE_NULL;
if (tmp != lsp->mem->nil)
{
int f = 0;
tmp = ASE_LSP_CDR(ASE_LSP_CAR(args));
ret = lsp->mem->nil;
while (ASE_LSP_TYPE(tmp) == ASE_LSP_OBJ_CONS)
{
ret = ase_lsp_eval (lsp, ASE_LSP_CAR(tmp));
if (ret == ASE_NULL)
{
if (!f) ase_lsp_poptmp (lsp); /* ret */
ase_lsp_poptmp (lsp); /* tmp */
return ASE_NULL;
}
if (!f) ase_lsp_poptmp (lsp); /* ret */
if (ase_lsp_pushtmp (lsp, ret) == ASE_NULL)
{
ase_lsp_poptmp (lsp); /* tmp */
return ASE_NULL;
}
f = 1;
tmp = ASE_LSP_CDR(tmp);
}
if (tmp != lsp->mem->nil)
{
if (!f) ase_lsp_poptmp (lsp); /* ret */
ase_lsp_poptmp (lsp); /* tmp */
ase_lsp_seterror (lsp, ASE_LSP_EARGBAD, ASE_NULL, 0);
return ASE_NULL;
}
if (!f) ase_lsp_poptmp (lsp); /* ret */
ase_lsp_poptmp (lsp); /* tmp */
return ret;
}
ase_lsp_poptmp (lsp); /* tmp */
args = ASE_LSP_CDR(args);
}
return lsp->mem->nil;
}
ase_lsp_obj_t* ase_lsp_prim_if (ase_lsp_t* lsp, ase_lsp_obj_t* args)
{
ase_lsp_obj_t* tmp;
ASE_ASSERT (ASE_LSP_TYPE(args) == ASE_LSP_OBJ_CONS);
tmp = ase_lsp_eval (lsp, ASE_LSP_CAR(args));
if (tmp == ASE_NULL) return ASE_NULL;
if (ase_lsp_pushtmp (lsp, tmp) == ASE_NULL) return ASE_NULL;
if (tmp != lsp->mem->nil)
{
tmp = ase_lsp_eval (lsp, ASE_LSP_CAR(ASE_LSP_CDR(args)));
if (tmp == ASE_NULL)
{
ase_lsp_poptmp (lsp); /* tmp */
return ASE_NULL;
}
ase_lsp_poptmp (lsp); /* tmp */
return tmp;
}
else
{
ase_lsp_obj_t* res = lsp->mem->nil;
int f = 0;
tmp = ASE_LSP_CDR(ASE_LSP_CDR(args));
while (ASE_LSP_TYPE(tmp) == ASE_LSP_OBJ_CONS)
{
res = ase_lsp_eval (lsp, ASE_LSP_CAR(tmp));
if (res == ASE_NULL)
{
if (!f) ase_lsp_poptmp (lsp); /* res */
ase_lsp_poptmp (lsp); /* tmp */
return ASE_NULL;
}
if (!f) ase_lsp_poptmp (lsp); /* res */
if (ase_lsp_pushtmp (lsp, res) == ASE_NULL)
{
ase_lsp_poptmp (lsp); /* tmp */
return ASE_NULL;
}
f = 1;
tmp = ASE_LSP_CDR(tmp);
}
if (tmp != lsp->mem->nil)
{
if (!f) ase_lsp_poptmp (lsp); /* ret */
ase_lsp_poptmp (lsp); /* tmp */
ase_lsp_seterror (lsp, ASE_LSP_EARGBAD, ASE_NULL, 0);
return ASE_NULL;
}
if (!f) ase_lsp_poptmp (lsp); /* ret */
ase_lsp_poptmp (lsp); /* tmp */
return res;
}
}
ase_lsp_obj_t* ase_lsp_prim_while (ase_lsp_t* lsp, ase_lsp_obj_t* args)
{
/*
* (setq a 1)
* (while (< a 100) (setq a (+ a 1)))
*/
ase_lsp_obj_t* tmp;
ASE_ASSERT (ASE_LSP_TYPE(args) == ASE_LSP_OBJ_CONS);
while (1)
{
tmp = ase_lsp_eval (lsp, ASE_LSP_CAR(args));
if (tmp == ASE_NULL) return ASE_NULL;
if (tmp == lsp->mem->nil) break;
if (ase_lsp_pushtmp (lsp, tmp) == ASE_NULL) return ASE_NULL;
tmp = ASE_LSP_CDR(args);
while (ASE_LSP_TYPE(tmp) == ASE_LSP_OBJ_CONS)
{
if (ase_lsp_eval(lsp, ASE_LSP_CAR(tmp)) == ASE_NULL)
{
ase_lsp_poptmp (lsp); /* tmp */
return ASE_NULL;
}
tmp = ASE_LSP_CDR(tmp);
}
if (tmp != lsp->mem->nil)
{
ase_lsp_poptmp (lsp); /* tmp */
ase_lsp_seterror (lsp, ASE_LSP_EARGBAD, ASE_NULL, 0);
return ASE_NULL;
}
ase_lsp_poptmp (lsp); /* tmp */
}
return lsp->mem->nil;
}
ase_lsp_obj_t* ase_lsp_prim_car (ase_lsp_t* lsp, ase_lsp_obj_t* args)
{
/*
* (car '(10 20 30))
*/
ase_lsp_obj_t* tmp;
ASE_ASSERT (ASE_LSP_TYPE(args) == ASE_LSP_OBJ_CONS);
tmp = ase_lsp_eval (lsp, ASE_LSP_CAR(args));
if (tmp == ASE_NULL) return ASE_NULL;
if (tmp == lsp->mem->nil) return lsp->mem->nil;
if (ASE_LSP_TYPE(tmp) != ASE_LSP_OBJ_CONS)
{
ase_lsp_seterror (lsp, ASE_LSP_EARGBAD, ASE_NULL, 0);
return ASE_NULL;
}
return ASE_LSP_CAR(tmp);
}
ase_lsp_obj_t* ase_lsp_prim_cdr (ase_lsp_t* lsp, ase_lsp_obj_t* args)
{
/*
* (cdr '(10 20 30))
*/
ase_lsp_obj_t* tmp;
ASE_ASSERT (ASE_LSP_TYPE(args) == ASE_LSP_OBJ_CONS);
tmp = ase_lsp_eval (lsp, ASE_LSP_CAR(args));
if (tmp == ASE_NULL) return ASE_NULL;
if (tmp == lsp->mem->nil) return lsp->mem->nil;
if (ASE_LSP_TYPE(tmp) != ASE_LSP_OBJ_CONS)
{
ase_lsp_seterror (lsp, ASE_LSP_EARGBAD, ASE_NULL, 0);
return ASE_NULL;
}
return ASE_LSP_CDR(tmp);
}
ase_lsp_obj_t* ase_lsp_prim_cons (ase_lsp_t* lsp, ase_lsp_obj_t* args)
{
/*
* (cons 10 20)
* (cons '(10 20) 30)
*/
ase_lsp_obj_t* car, * cdr, * cons;
ASE_ASSERT (ASE_LSP_TYPE(args) == ASE_LSP_OBJ_CONS);
car = ase_lsp_eval (lsp, ASE_LSP_CAR(args));
if (car == ASE_NULL) return ASE_NULL;
if (ase_lsp_pushtmp (lsp, car) == ASE_NULL) return ASE_NULL;
cdr = ase_lsp_eval (lsp, ASE_LSP_CAR(ASE_LSP_CDR(args)));
if (cdr == ASE_NULL)
{
ase_lsp_poptmp (lsp); /* car */
return ASE_NULL;
}
if (ase_lsp_pushtmp (lsp, cdr) == ASE_NULL)
{
ase_lsp_poptmp (lsp); /* car */
return ASE_NULL;
}
cons = ase_lsp_makecons (lsp->mem, car, cdr);
if (cons == ASE_NULL)
{
ase_lsp_poptmp (lsp); /* cdr */
ase_lsp_poptmp (lsp); /* car */
return ASE_NULL;
}
ase_lsp_poptmp (lsp); /* cdr */
ase_lsp_poptmp (lsp); /* car */
return cons;
}
ase_lsp_obj_t* ase_lsp_prim_length (ase_lsp_t* lsp, ase_lsp_obj_t* args)
{
ase_lsp_obj_t* body, * tmp;
ase_long_t len = 0;
ASE_ASSERT (ASE_LSP_TYPE(args) == ASE_LSP_OBJ_CONS);
body = args;
while (ASE_LSP_TYPE(body) == ASE_LSP_OBJ_CONS)
{
tmp = ase_lsp_eval (lsp, ASE_LSP_CAR(body));
if (tmp == ASE_NULL) return ASE_NULL;
if (ASE_LSP_TYPE(tmp) == ASE_LSP_OBJ_NIL)
{
len = 0;
}
else if (ASE_LSP_TYPE(tmp) == ASE_LSP_OBJ_STR)
{
len = ASE_LSP_STRLEN(tmp);
}
else if (ASE_LSP_TYPE(tmp) == ASE_LSP_OBJ_SYM)
{
len = ASE_LSP_SYMLEN(tmp);
}
else if (ASE_LSP_TYPE(tmp) == ASE_LSP_OBJ_CONS)
{
len = 0;
do
{
len++;
tmp = ASE_LSP_CDR(tmp);
}
while (ASE_LSP_TYPE(tmp) == ASE_LSP_OBJ_CONS);
/* TODO: more flexible without the check below?
* both of the following expression evalute
* to 3 without it.
* (length '(9 9 9 . 9))
* (length '(9 9 9))
*/
if (ASE_LSP_TYPE(tmp) != ASE_LSP_OBJ_NIL)
{
ase_lsp_seterror (lsp, ASE_LSP_EVALBAD, ASE_NULL, 0);
return ASE_NULL;
}
}
else
{
ase_lsp_seterror (lsp, ASE_LSP_EVALBAD, ASE_NULL, 0);
return ASE_NULL;
}
body = ASE_LSP_CDR(body);
}
ASE_ASSERT (body == lsp->mem->nil);
return ase_lsp_makeintobj (lsp->mem, len);
}
ase_lsp_obj_t* ase_lsp_prim_set (ase_lsp_t* lsp, ase_lsp_obj_t* args)
{
/*
* (set 'flowers 'rose)
* (set flowers 20)
* rose
*/
ase_lsp_obj_t* p1, * p2;
ASE_ASSERT (ASE_LSP_TYPE(args) == ASE_LSP_OBJ_CONS);
p1 = ase_lsp_eval (lsp, ASE_LSP_CAR(args));
if (p1 == ASE_NULL) return ASE_NULL;
if (ase_lsp_pushtmp (lsp, p1) == ASE_NULL) return ASE_NULL;
if (ASE_LSP_TYPE(p1) != ASE_LSP_OBJ_SYM)
{
ase_lsp_poptmp (lsp); /* p1 */
ase_lsp_seterror (lsp, ASE_LSP_EARGBAD, ASE_NULL, 0);
return ASE_NULL;
}
p2 = ase_lsp_eval (lsp, ASE_LSP_CAR(ASE_LSP_CDR(args)));
if (p2 == ASE_NULL)
{
ase_lsp_poptmp (lsp); /* p1 */
return ASE_NULL;
}
if (ase_lsp_pushtmp (lsp, p2) == ASE_NULL)
{
ase_lsp_poptmp (lsp); /* p1 */
return ASE_NULL;
}
if (ase_lsp_setvalue (lsp->mem, p1, p2) == ASE_NULL)
{
ase_lsp_poptmp (lsp); /* p2 */
ase_lsp_poptmp (lsp); /* p1 */
return ASE_NULL;
}
ase_lsp_poptmp (lsp); /* p2 */
ase_lsp_poptmp (lsp); /* p1 */
return p2;
}
ase_lsp_obj_t* ase_lsp_prim_setq (ase_lsp_t* lsp, ase_lsp_obj_t* args)
{
/*
* (setq x 10)
* (setq x "string")
*/
ase_lsp_obj_t* p = args, * p1, * p2 = lsp->mem->nil;
while (p != lsp->mem->nil)
{
ASE_ASSERT (ASE_LSP_TYPE(p) == ASE_LSP_OBJ_CONS);
p1 = ASE_LSP_CAR(p);
if (ASE_LSP_TYPE(p1) != ASE_LSP_OBJ_SYM)
{
ase_lsp_seterror (lsp, ASE_LSP_EARGBAD, ASE_NULL, 0);
return ASE_NULL;
}
if (ASE_LSP_TYPE(ASE_LSP_CDR(p)) != ASE_LSP_OBJ_CONS)
{
lsp->errnum = ASE_LSP_EARGFEW;
return ASE_NULL;
}
p2 = ase_lsp_eval (lsp, ASE_LSP_CAR(ASE_LSP_CDR(p)));
if (p2 == ASE_NULL) return ASE_NULL;
if (ase_lsp_pushtmp (lsp, p2) == ASE_NULL) return ASE_NULL;
if (ase_lsp_setvalue (lsp->mem, p1, p2) == ASE_NULL)
{
ase_lsp_poptmp (lsp);
return ASE_NULL;
}
ase_lsp_poptmp (lsp);
p = ASE_LSP_CDR(ASE_LSP_CDR(p));
}
return p2;
}
ase_lsp_obj_t* ase_lsp_prim_quote (ase_lsp_t* lsp, ase_lsp_obj_t* args)
{
/*
* (quote (10 20 30 50))
*/
ASE_ASSERT (ASE_LSP_TYPE(args) == ASE_LSP_OBJ_CONS);
return ASE_LSP_CAR(args);
}
ase_lsp_obj_t* ase_lsp_prim_defun (ase_lsp_t* lsp, ase_lsp_obj_t* args)
{
/*
* (defun x (a b) (+ a b 100))
* (x 40 50)
*
* (setq x (lambda (x y) (setq temp 10) (+ x y temp)))
* (x 40 50)
* temp
*/
ase_lsp_obj_t* name, * fun;
name = ASE_LSP_CAR(args);
if (ASE_LSP_TYPE(name) != ASE_LSP_OBJ_SYM)
{
ase_lsp_seterror (lsp, ASE_LSP_EARGBAD, ASE_NULL, 0);
return ASE_NULL;
}
fun = ase_lsp_makefunc (lsp->mem,
ASE_LSP_CAR(ASE_LSP_CDR(args)), ASE_LSP_CDR(ASE_LSP_CDR(args)));
if (fun == ASE_NULL) return ASE_NULL;
if (ase_lsp_pushtmp (lsp, fun) == ASE_NULL) return ASE_NULL;
if (ase_lsp_setfunc (lsp->mem, ASE_LSP_CAR(args), fun) == ASE_NULL)
{
ase_lsp_poptmp (lsp);
return ASE_NULL;
}
ase_lsp_poptmp (lsp);
return fun;
}
ase_lsp_obj_t* ase_lsp_prim_demac (ase_lsp_t* lsp, ase_lsp_obj_t* args)
{
/*
* (demac x (abc) x y z)
* (setq x (macro (abc) x y z))
*/
ase_lsp_obj_t* name, * mac;
name = ASE_LSP_CAR(args);
if (ASE_LSP_TYPE(name) != ASE_LSP_OBJ_SYM)
{
ase_lsp_seterror (lsp, ASE_LSP_EARGBAD, ASE_NULL, 0);
return ASE_NULL;
}
mac = ase_lsp_makemacro (lsp->mem,
ASE_LSP_CAR(ASE_LSP_CDR(args)), ASE_LSP_CDR(ASE_LSP_CDR(args)));
if (mac == ASE_NULL) return ASE_NULL;
if (ase_lsp_pushtmp (lsp, mac) == ASE_NULL) return ASE_NULL;
if (ase_lsp_setfunc (lsp->mem, ASE_LSP_CAR(args), mac) == ASE_NULL)
{
ase_lsp_poptmp (lsp);
return ASE_NULL;
}
ase_lsp_poptmp (lsp);
return mac;
}
ase_lsp_obj_t* ase_lsp_prim_or (ase_lsp_t* lsp, ase_lsp_obj_t* args)
{
/*
* (or 10 20 30 40)
* (or (= n 20) (= n 30))
*/
ase_lsp_obj_t* tmp;
/* TODO: this is wrong. redo the work */
while (ASE_LSP_TYPE(args) == ASE_LSP_OBJ_CONS)
{
tmp = ase_lsp_eval (lsp, ASE_LSP_CAR(args));
if (tmp == ASE_NULL) return ASE_NULL;
if (ASE_LSP_TYPE(args) == ASE_LSP_OBJ_INT)
if (tmp != lsp->mem->nil) return lsp->mem->t;
args = ASE_LSP_CDR(args);
}
return lsp->mem->nil;
}

69
ase/lib/lsp/prim.h Normal file
View File

@ -0,0 +1,69 @@
/*
* $Id: prim.h 117 2008-03-03 11:20:05Z baconevi $
*
* {License}
*/
#ifndef _ASE_LSP_PRIM_H_
#define _ASE_LSP_PRIM_H_
#ifndef _ASE_LSP_LSP_H_
#error Never include this file directly. Include <ase/lsp/lsp.h> instead
#endif
#ifdef __cplusplus
extern "C" {
#endif
ase_lsp_obj_t* ase_lsp_prim_exit (ase_lsp_t* lsp, ase_lsp_obj_t* args);
ase_lsp_obj_t* ase_lsp_prim_eval (ase_lsp_t* lsp, ase_lsp_obj_t* args);
ase_lsp_obj_t* ase_lsp_prim_prog1 (ase_lsp_t* lsp, ase_lsp_obj_t* args);
ase_lsp_obj_t* ase_lsp_prim_progn (ase_lsp_t* lsp, ase_lsp_obj_t* args);
ase_lsp_obj_t* ase_lsp_prim_gc (ase_lsp_t* lsp, ase_lsp_obj_t* args);
ase_lsp_obj_t* ase_lsp_prim_cond (ase_lsp_t* lsp, ase_lsp_obj_t* args);
ase_lsp_obj_t* ase_lsp_prim_if (ase_lsp_t* lsp, ase_lsp_obj_t* args);
ase_lsp_obj_t* ase_lsp_prim_while (ase_lsp_t* lsp, ase_lsp_obj_t* args);
ase_lsp_obj_t* ase_lsp_prim_car (ase_lsp_t* lsp, ase_lsp_obj_t* args);
ase_lsp_obj_t* ase_lsp_prim_cdr (ase_lsp_t* lsp, ase_lsp_obj_t* args);
ase_lsp_obj_t* ase_lsp_prim_cons (ase_lsp_t* lsp, ase_lsp_obj_t* args);
ase_lsp_obj_t* ase_lsp_prim_length (ase_lsp_t* lsp, ase_lsp_obj_t* args);
ase_lsp_obj_t* ase_lsp_prim_set (ase_lsp_t* lsp, ase_lsp_obj_t* args);
ase_lsp_obj_t* ase_lsp_prim_setq (ase_lsp_t* lsp, ase_lsp_obj_t* args);
ase_lsp_obj_t* ase_lsp_prim_quote (ase_lsp_t* lsp, ase_lsp_obj_t* args);
ase_lsp_obj_t* ase_lsp_prim_defun (ase_lsp_t* lsp, ase_lsp_obj_t* args);
ase_lsp_obj_t* ase_lsp_prim_demac (ase_lsp_t* lsp, ase_lsp_obj_t* args);
ase_lsp_obj_t* ase_lsp_prim_let (ase_lsp_t* lsp, ase_lsp_obj_t* args);
ase_lsp_obj_t* ase_lsp_prim_letx (ase_lsp_t* lsp, ase_lsp_obj_t* args);
ase_lsp_obj_t* ase_lsp_prim_or (ase_lsp_t* lsp, ase_lsp_obj_t* args);
/*---------------------
prim_compar.c
---------------------*/
ase_lsp_obj_t* ase_lsp_prim_eq (ase_lsp_t* lsp, ase_lsp_obj_t* args);
ase_lsp_obj_t* ase_lsp_prim_ne (ase_lsp_t* lsp, ase_lsp_obj_t* args);
ase_lsp_obj_t* ase_lsp_prim_gt (ase_lsp_t* lsp, ase_lsp_obj_t* args);
ase_lsp_obj_t* ase_lsp_prim_lt (ase_lsp_t* lsp, ase_lsp_obj_t* args);
ase_lsp_obj_t* ase_lsp_prim_ge (ase_lsp_t* lsp, ase_lsp_obj_t* args);
ase_lsp_obj_t* ase_lsp_prim_le (ase_lsp_t* lsp, ase_lsp_obj_t* args);
/*---------------------
prim_math.c
---------------------*/
ase_lsp_obj_t* ase_lsp_prim_plus (ase_lsp_t* lsp, ase_lsp_obj_t* args);
ase_lsp_obj_t* ase_lsp_prim_minus (ase_lsp_t* lsp, ase_lsp_obj_t* args);
ase_lsp_obj_t* ase_lsp_prim_mul (ase_lsp_t* lsp, ase_lsp_obj_t* args);
ase_lsp_obj_t* ase_lsp_prim_div (ase_lsp_t* lsp, ase_lsp_obj_t* args);
ase_lsp_obj_t* ase_lsp_prim_mod (ase_lsp_t* lsp, ase_lsp_obj_t* args);
/*---------------------
prim_fact.c
---------------------*/
ase_lsp_obj_t* ase_lsp_prim_fact (ase_lsp_t* lsp, ase_lsp_obj_t* args);
#ifdef __cplusplus
}
#endif
#endif

141
ase/lib/lsp/prim_compar.c Normal file
View File

@ -0,0 +1,141 @@
/*
* $Id: prim_compar.c 117 2008-03-03 11:20:05Z baconevi $
*
* {License}
*/
#include <ase/lsp/lsp_i.h>
#define PRIM_COMPAR(lsp,args,op) \
{ \
ase_lsp_obj_t* p1, * p2; \
int res; \
ASE_ASSERT (ASE_LSP_TYPE(args) == ASE_LSP_OBJ_CONS); \
\
p1 = ase_lsp_eval (lsp, ASE_LSP_CAR(args)); \
if (p1 == ASE_NULL) return ASE_NULL; \
if (ase_lsp_pushtmp (lsp, p1) == ASE_NULL) return ASE_NULL; \
\
p2 = ase_lsp_eval (lsp, ASE_LSP_CAR(ASE_LSP_CDR(args))); \
if (p2 == ASE_NULL) \
{ \
ase_lsp_poptmp (lsp); \
return ASE_NULL; \
} \
\
if (ase_lsp_pushtmp (lsp, p2) == ASE_NULL) \
{ \
ase_lsp_poptmp (lsp); \
return ASE_NULL; \
} \
\
if (ASE_LSP_TYPE(p1) == ASE_LSP_OBJ_INT) \
{ \
if (ASE_LSP_TYPE(p2) == ASE_LSP_OBJ_INT) \
{ \
res = ASE_LSP_IVAL(p1) op ASE_LSP_IVAL(p2); \
} \
else if (ASE_LSP_TYPE(p2) == ASE_LSP_OBJ_REAL) \
{ \
res = ASE_LSP_IVAL(p1) op ASE_LSP_RVAL(p2); \
} \
else \
{ \
ase_lsp_poptmp (lsp); \
ase_lsp_poptmp (lsp); \
ase_lsp_seterror (lsp, ASE_LSP_EVALBAD, ASE_NULL, 0); \
return ASE_NULL; \
} \
} \
else if (ASE_LSP_TYPE(p1) == ASE_LSP_OBJ_REAL) \
{ \
if (ASE_LSP_TYPE(p2) == ASE_LSP_OBJ_INT) \
{ \
res = ASE_LSP_RVAL(p1) op ASE_LSP_IVAL(p2); \
} \
else if (ASE_LSP_TYPE(p2) == ASE_LSP_OBJ_REAL) \
{ \
res = ASE_LSP_RVAL(p1) op ASE_LSP_RVAL(p2); \
} \
else \
{ \
ase_lsp_poptmp (lsp); \
ase_lsp_poptmp (lsp); \
ase_lsp_seterror (lsp, ASE_LSP_EVALBAD, ASE_NULL, 0); \
return ASE_NULL; \
} \
} \
else if (ASE_LSP_TYPE(p1) == ASE_LSP_OBJ_SYM) \
{ \
if (ASE_LSP_TYPE(p2) == ASE_LSP_OBJ_SYM) \
{ \
res = ase_strxncmp ( \
ASE_LSP_SYMPTR(p1), ASE_LSP_SYMLEN(p1), \
ASE_LSP_SYMPTR(p2), ASE_LSP_SYMLEN(p2)) op 0; \
} \
else \
{ \
ase_lsp_poptmp (lsp); \
ase_lsp_poptmp (lsp); \
ase_lsp_seterror (lsp, ASE_LSP_EVALBAD, ASE_NULL, 0); \
return ASE_NULL; \
} \
} \
else if (ASE_LSP_TYPE(p1) == ASE_LSP_OBJ_STR) \
{ \
if (ASE_LSP_TYPE(p2) == ASE_LSP_OBJ_STR) \
{ \
res = ase_strxncmp ( \
ASE_LSP_STRPTR(p1), ASE_LSP_STRLEN(p1), \
ASE_LSP_STRPTR(p2), ASE_LSP_STRLEN(p2)) op 0; \
} \
else \
{ \
ase_lsp_poptmp (lsp); \
ase_lsp_poptmp (lsp); \
ase_lsp_seterror (lsp, ASE_LSP_EVALBAD, ASE_NULL, 0); \
return ASE_NULL; \
} \
} \
else \
{ \
ase_lsp_poptmp (lsp); \
ase_lsp_poptmp (lsp); \
ase_lsp_seterror (lsp, ASE_LSP_EVALBAD, ASE_NULL, 0); \
return ASE_NULL; \
} \
\
ase_lsp_poptmp (lsp); \
ase_lsp_poptmp (lsp); \
return (res)? lsp->mem->t: lsp->mem->nil; \
}
ase_lsp_obj_t* ase_lsp_prim_eq (ase_lsp_t* lsp, ase_lsp_obj_t* args)
{
PRIM_COMPAR (lsp, args, ==);
}
ase_lsp_obj_t* ase_lsp_prim_ne (ase_lsp_t* lsp, ase_lsp_obj_t* args)
{
PRIM_COMPAR (lsp, args, !=);
}
ase_lsp_obj_t* ase_lsp_prim_gt (ase_lsp_t* lsp, ase_lsp_obj_t* args)
{
PRIM_COMPAR (lsp, args, >);
}
ase_lsp_obj_t* ase_lsp_prim_lt (ase_lsp_t* lsp, ase_lsp_obj_t* args)
{
PRIM_COMPAR (lsp, args, <);
}
ase_lsp_obj_t* ase_lsp_prim_ge (ase_lsp_t* lsp, ase_lsp_obj_t* args)
{
PRIM_COMPAR (lsp, args, >=);
}
ase_lsp_obj_t* ase_lsp_prim_le (ase_lsp_t* lsp, ase_lsp_obj_t* args)
{
PRIM_COMPAR (lsp, args, <=);
}

186
ase/lib/lsp/prim_let.c Normal file
View File

@ -0,0 +1,186 @@
/*
* $Id: prim_let.c 117 2008-03-03 11:20:05Z baconevi $
*
* {License}
*/
#include <ase/lsp/lsp_i.h>
/*
* (let ((variable value)
* (variable value)
* ...)
* body...)
*/
static ase_lsp_obj_t* __prim_let (
ase_lsp_t* lsp, ase_lsp_obj_t* args, int sequential)
{
ase_lsp_frame_t* frame;
ase_lsp_obj_t* assoc;
ase_lsp_obj_t* body;
ase_lsp_obj_t* value;
/* create a new frameq */
frame = ase_lsp_newframe (lsp);
if (frame == ASE_NULL) return ASE_NULL;
/*frame->link = lsp->mem->frame;*/
if (sequential)
{
frame->link = lsp->mem->frame;
lsp->mem->frame = frame;
}
else
{
frame->link = lsp->mem->brooding_frame;
lsp->mem->brooding_frame = frame;
}
assoc = ASE_LSP_CAR(args);
/*while (assoc != lsp->mem->nil) {*/
while (ASE_LSP_TYPE(assoc) == ASE_LSP_OBJ_CONS)
{
ase_lsp_obj_t* ass = ASE_LSP_CAR(assoc);
if (ASE_LSP_TYPE(ass) == ASE_LSP_OBJ_CONS)
{
ase_lsp_obj_t* n = ASE_LSP_CAR(ass);
ase_lsp_obj_t* v = ASE_LSP_CDR(ass);
if (ASE_LSP_TYPE(n) != ASE_LSP_OBJ_SYM)
{
if (sequential) lsp->mem->frame = frame->link;
else lsp->mem->brooding_frame = frame->link;
ase_lsp_freeframe (lsp, frame);
ase_lsp_seterror (lsp, ASE_LSP_EARGBAD, ASE_NULL, 0);
return ASE_NULL;
}
if (v != lsp->mem->nil)
{
if (ASE_LSP_CDR(v) != lsp->mem->nil)
{
if (sequential) lsp->mem->frame = frame->link;
else lsp->mem->brooding_frame = frame->link;
ase_lsp_freeframe (lsp, frame);
ase_lsp_seterror (lsp, ASE_LSP_EARGMANY, ASE_NULL, 0);
return ASE_NULL;
}
if ((v = ase_lsp_eval(lsp, ASE_LSP_CAR(v))) == ASE_NULL)
{
if (sequential) lsp->mem->frame = frame->link;
else lsp->mem->brooding_frame = frame->link;
ase_lsp_freeframe (lsp, frame);
return ASE_NULL;
}
}
if (ase_lsp_lookupinframe (lsp, frame, n) != ASE_NULL)
{
if (sequential) lsp->mem->frame = frame->link;
else lsp->mem->brooding_frame = frame->link;
ase_lsp_freeframe (lsp, frame);
ase_lsp_seterror (lsp, ASE_LSP_EDUPFML, ASE_NULL, 0);
return ASE_NULL;
}
if (ase_lsp_insvalueintoframe (lsp, frame, n, v) == ASE_NULL)
{
if (sequential) lsp->mem->frame = frame->link;
else lsp->mem->brooding_frame = frame->link;
ase_lsp_freeframe (lsp, frame);
return ASE_NULL;
}
}
else if (ASE_LSP_TYPE(ass) == ASE_LSP_OBJ_SYM)
{
if (ase_lsp_lookupinframe (lsp, frame, ass) != ASE_NULL)
{
if (sequential) lsp->mem->frame = frame->link;
else lsp->mem->brooding_frame = frame->link;
ase_lsp_freeframe (lsp, frame);
ase_lsp_seterror (lsp, ASE_LSP_EDUPFML, ASE_NULL, 0);
return ASE_NULL;
}
if (ase_lsp_insvalueintoframe (lsp, frame, ass, lsp->mem->nil) == ASE_NULL)
{
if (sequential) lsp->mem->frame = frame->link;
else lsp->mem->brooding_frame = frame->link;
ase_lsp_freeframe (lsp, frame);
return ASE_NULL;
}
}
else
{
if (sequential) lsp->mem->frame = frame->link;
else lsp->mem->brooding_frame = frame->link;
ase_lsp_freeframe (lsp, frame);
ase_lsp_seterror (lsp, ASE_LSP_EARGBAD, ASE_NULL, 0);
return ASE_NULL;
}
assoc = ASE_LSP_CDR(assoc);
}
if (assoc != lsp->mem->nil)
{
if (sequential) lsp->mem->frame = frame->link;
else lsp->mem->brooding_frame = frame->link;
ase_lsp_freeframe (lsp, frame);
ase_lsp_seterror (lsp, ASE_LSP_EARGBAD, ASE_NULL, 0);
return ASE_NULL;
}
/* push the frame */
if (!sequential)
{
lsp->mem->brooding_frame = frame->link;
frame->link = lsp->mem->frame;
lsp->mem->frame = frame;
}
/* evaluate forms in the body */
value = lsp->mem->nil;
body = ASE_LSP_CDR(args);
while (body != lsp->mem->nil)
{
value = ase_lsp_eval (lsp, ASE_LSP_CAR(body));
if (value == ASE_NULL)
{
lsp->mem->frame = frame->link;
ase_lsp_freeframe (lsp, frame);
return ASE_NULL;
}
body = ASE_LSP_CDR(body);
}
/* pop the frame */
lsp->mem->frame = frame->link;
/* destroy the frame */
ase_lsp_freeframe (lsp, frame);
return value;
}
ase_lsp_obj_t* ase_lsp_prim_let (ase_lsp_t* lsp, ase_lsp_obj_t* args)
{
/*
* (defun x (x y)
* (let ((temp1 10) (temp2 20))
* (+ x y temp1 temp2)))
* (x 40 50)
* temp1
*/
return __prim_let (lsp, args, 0);
}
ase_lsp_obj_t* ase_lsp_prim_letx (ase_lsp_t* lsp, ase_lsp_obj_t* args)
{
return __prim_let (lsp, args, 1);
}

351
ase/lib/lsp/prim_math.c Normal file
View File

@ -0,0 +1,351 @@
/*
* $Id: prim_math.c 117 2008-03-03 11:20:05Z baconevi $
*
* {License}
*/
#include <ase/lsp/lsp_i.h>
ase_lsp_obj_t* ase_lsp_prim_plus (ase_lsp_t* lsp, ase_lsp_obj_t* args)
{
ase_lsp_obj_t* body, * tmp;
ase_long_t ival = 0;
ase_real_t rval = .0;
ase_bool_t realnum = ase_false;
ASE_ASSERT (ASE_LSP_TYPE(args) == ASE_LSP_OBJ_CONS);
body = args;
while (ASE_LSP_TYPE(body) == ASE_LSP_OBJ_CONS)
{
tmp = ase_lsp_eval (lsp, ASE_LSP_CAR(body));
if (tmp == ASE_NULL) return ASE_NULL;
if (ASE_LSP_TYPE(tmp) == ASE_LSP_OBJ_INT)
{
if (body == args)
{
ASE_ASSERT (realnum == ase_false);
ival = ASE_LSP_IVAL(tmp);
}
else
{
if (!realnum)
ival = ival + ASE_LSP_IVAL(tmp);
else
rval = rval + ASE_LSP_IVAL(tmp);
}
}
else if (ASE_LSP_TYPE(tmp) == ASE_LSP_OBJ_REAL)
{
if (body == args)
{
ASE_ASSERT (realnum == ase_false);
realnum = ase_true;
rval = ASE_LSP_RVAL(tmp);
}
else
{
if (!realnum)
{
realnum = ase_true;
rval = (ase_real_t)ival;
}
rval = rval + ASE_LSP_RVAL(tmp);
}
}
else
{
ase_lsp_seterror (lsp, ASE_LSP_EVALBAD, ASE_NULL, 0);
return ASE_NULL;
}
body = ASE_LSP_CDR(body);
}
ASE_ASSERT (body == lsp->mem->nil);
tmp = (realnum)?
ase_lsp_makerealobj (lsp->mem, rval):
ase_lsp_makeintobj (lsp->mem, ival);
if (tmp == ASE_NULL) return ASE_NULL;
return tmp;
}
ase_lsp_obj_t* ase_lsp_prim_minus (ase_lsp_t* lsp, ase_lsp_obj_t* args)
{
ase_lsp_obj_t* body, * tmp;
ase_long_t ival = 0;
ase_real_t rval = .0;
ase_bool_t realnum = ase_false;
ASE_ASSERT (ASE_LSP_TYPE(args) == ASE_LSP_OBJ_CONS);
body = args;
while (ASE_LSP_TYPE(body) == ASE_LSP_OBJ_CONS)
{
tmp = ase_lsp_eval (lsp, ASE_LSP_CAR(body));
if (tmp == ASE_NULL) return ASE_NULL;
if (ASE_LSP_TYPE(tmp) == ASE_LSP_OBJ_INT)
{
if (body == args)
{
ASE_ASSERT (realnum == ase_false);
ival = ASE_LSP_IVAL(tmp);
}
else
{
if (!realnum)
ival = ival - ASE_LSP_IVAL(tmp);
else
rval = rval - ASE_LSP_IVAL(tmp);
}
}
else if (ASE_LSP_TYPE(tmp) == ASE_LSP_OBJ_REAL)
{
if (body == args)
{
ASE_ASSERT (realnum == ase_false);
realnum = ase_true;
rval = ASE_LSP_RVAL(tmp);
}
else
{
if (!realnum)
{
realnum = ase_true;
rval = (ase_real_t)ival;
}
rval = rval - ASE_LSP_RVAL(tmp);
}
}
else
{
ase_lsp_seterror (lsp, ASE_LSP_EVALBAD, ASE_NULL, 0);
return ASE_NULL;
}
body = ASE_LSP_CDR(body);
}
ASE_ASSERT (body == lsp->mem->nil);
tmp = (realnum)?
ase_lsp_makerealobj (lsp->mem, rval):
ase_lsp_makeintobj (lsp->mem, ival);
if (tmp == ASE_NULL) return ASE_NULL;
return tmp;
}
ase_lsp_obj_t* ase_lsp_prim_mul (ase_lsp_t* lsp, ase_lsp_obj_t* args)
{
ase_lsp_obj_t* body, * tmp;
ase_long_t ival = 0;
ase_real_t rval = .0;
ase_bool_t realnum = ase_false;
ASE_ASSERT (ASE_LSP_TYPE(args) == ASE_LSP_OBJ_CONS);
body = args;
while (ASE_LSP_TYPE(body) == ASE_LSP_OBJ_CONS)
{
tmp = ase_lsp_eval (lsp, ASE_LSP_CAR(body));
if (tmp == ASE_NULL) return ASE_NULL;
if (ASE_LSP_TYPE(tmp) == ASE_LSP_OBJ_INT)
{
if (body == args)
{
ASE_ASSERT (realnum == ase_false);
ival = ASE_LSP_IVAL(tmp);
}
else
{
if (!realnum)
ival = ival * ASE_LSP_IVAL(tmp);
else
rval = rval * ASE_LSP_IVAL(tmp);
}
}
else if (ASE_LSP_TYPE(tmp) == ASE_LSP_OBJ_REAL)
{
if (body == args)
{
ASE_ASSERT (realnum == ase_false);
realnum = ase_true;
rval = ASE_LSP_RVAL(tmp);
}
else
{
if (!realnum)
{
realnum = ase_true;
rval = (ase_real_t)ival;
}
rval = rval * ASE_LSP_RVAL(tmp);
}
}
else
{
ase_lsp_seterror (lsp, ASE_LSP_EVALBAD, ASE_NULL, 0);
return ASE_NULL;
}
body = ASE_LSP_CDR(body);
}
ASE_ASSERT (body == lsp->mem->nil);
tmp = (realnum)?
ase_lsp_makerealobj (lsp->mem, rval):
ase_lsp_makeintobj (lsp->mem, ival);
if (tmp == ASE_NULL) return ASE_NULL;
return tmp;
}
ase_lsp_obj_t* ase_lsp_prim_div (ase_lsp_t* lsp, ase_lsp_obj_t* args)
{
ase_lsp_obj_t* body, * tmp;
ase_long_t ival = 0;
ase_real_t rval = .0;
ase_bool_t realnum = ase_false;
ASE_ASSERT (ASE_LSP_TYPE(args) == ASE_LSP_OBJ_CONS);
body = args;
while (ASE_LSP_TYPE(body) == ASE_LSP_OBJ_CONS)
{
tmp = ase_lsp_eval (lsp, ASE_LSP_CAR(body));
if (tmp == ASE_NULL) return ASE_NULL;
if (ASE_LSP_TYPE(tmp) == ASE_LSP_OBJ_INT)
{
if (body == args)
{
ASE_ASSERT (realnum == ase_false);
ival = ASE_LSP_IVAL(tmp);
}
else
{
if (!realnum)
{
if (ASE_LSP_IVAL(tmp) == 0)
{
ase_lsp_seterror (lsp, ASE_LSP_EDIVBY0, ASE_NULL, 0);
return ASE_NULL;
}
ival = ival / ASE_LSP_IVAL(tmp);
}
else
rval = rval / ASE_LSP_IVAL(tmp);
}
}
else if (ASE_LSP_TYPE(tmp) == ASE_LSP_OBJ_REAL)
{
if (body == args)
{
ASE_ASSERT (realnum == ase_false);
realnum = ase_true;
rval = ASE_LSP_RVAL(tmp);
}
else
{
if (!realnum)
{
realnum = ase_true;
rval = (ase_real_t)ival;
}
rval = rval / ASE_LSP_RVAL(tmp);
}
}
else
{
ase_lsp_seterror (lsp, ASE_LSP_EVALBAD, ASE_NULL, 0);
return ASE_NULL;
}
body = ASE_LSP_CDR(body);
}
ASE_ASSERT (body == lsp->mem->nil);
tmp = (realnum)?
ase_lsp_makerealobj (lsp->mem, rval):
ase_lsp_makeintobj (lsp->mem, ival);
if (tmp == ASE_NULL) return ASE_NULL;
return tmp;
}
ase_lsp_obj_t* ase_lsp_prim_mod (ase_lsp_t* lsp, ase_lsp_obj_t* args)
{
ase_lsp_obj_t* body, * tmp;
ase_long_t ival = 0;
ASE_ASSERT (ASE_LSP_TYPE(args) == ASE_LSP_OBJ_CONS);
body = args;
while (ASE_LSP_TYPE(body) == ASE_LSP_OBJ_CONS)
{
tmp = ase_lsp_eval (lsp, ASE_LSP_CAR(body));
if (tmp == ASE_NULL) return ASE_NULL;
if (ASE_LSP_TYPE(tmp) == ASE_LSP_OBJ_INT)
{
if (body == args)
{
ival = ASE_LSP_IVAL(tmp);
}
else
{
if (ASE_LSP_IVAL(tmp) == 0)
{
ase_lsp_seterror (lsp, ASE_LSP_EDIVBY0, ASE_NULL, 0);
return ASE_NULL;
}
ival = ival % ASE_LSP_IVAL(tmp);
}
}
else if (ASE_LSP_TYPE(tmp) == ASE_LSP_OBJ_REAL)
{
if (body == args)
{
ival = (ase_long_t)ASE_LSP_RVAL(tmp);
}
else
{
ase_long_t tmpi = (ase_long_t)ASE_LSP_RVAL(tmp);
if (tmpi == 0)
{
ase_lsp_seterror (lsp, ASE_LSP_EDIVBY0, ASE_NULL, 0);
return ASE_NULL;
}
ival = ival % tmpi;
}
}
else
{
ase_lsp_seterror (lsp, ASE_LSP_EVALBAD, ASE_NULL, 0);
return ASE_NULL;
}
body = ASE_LSP_CDR(body);
}
ASE_ASSERT (body == lsp->mem->nil);
tmp = ase_lsp_makeintobj (lsp->mem, ival);
if (tmp == ASE_NULL) return ASE_NULL;
return tmp;
}

53
ase/lib/lsp/prim_prog.c Normal file
View File

@ -0,0 +1,53 @@
/*
* $Id: prim_prog.c 117 2008-03-03 11:20:05Z baconevi $
*
* {License}
*/
#include <ase/lsp/lsp_i.h>
ase_lsp_obj_t* ase_lsp_prim_prog1 (ase_lsp_t* lsp, ase_lsp_obj_t* args)
{
/* (prog1 1 2 3) returns 1 */
ase_lsp_obj_t* res = ASE_NULL, * tmp;
/*while (args != lsp->mem->nil) {*/
while (ASE_LSP_TYPE(args) == ASE_LSP_OBJ_CONS)
{
tmp = ase_lsp_eval (lsp, ASE_LSP_CAR(args));
if (tmp == ASE_NULL) return ASE_NULL;
if (res == ASE_NULL)
{
res = tmp;
if (ase_lsp_pushtmp (lsp, res) == ASE_NULL)
{
return ASE_NULL;
}
}
args = ASE_LSP_CDR(args);
}
if (res != ASE_NULL) ase_lsp_poptmp (lsp);
return res;
}
ase_lsp_obj_t* ase_lsp_prim_progn (ase_lsp_t* lsp, ase_lsp_obj_t* args)
{
/* (progn 1 2 3) returns 3 */
ase_lsp_obj_t* res, * tmp;
res = lsp->mem->nil;
/*while (args != lsp->mem->nil) {*/
while (ASE_LSP_TYPE(args) == ASE_LSP_OBJ_CONS)
{
tmp = ase_lsp_eval (lsp, ASE_LSP_CAR(args));
if (tmp == ASE_NULL) return ASE_NULL;
res = tmp;
args = ASE_LSP_CDR(args);
}
return res;
}

150
ase/lib/lsp/print.c Normal file
View File

@ -0,0 +1,150 @@
/*
* $Id: print.c 117 2008-03-03 11:20:05Z baconevi $
*
* {License}
*/
#include <ase/lsp/lsp_i.h>
#define OUTPUT_STR(lsp,str) \
do { \
if (lsp->output_func(ASE_LSP_IO_WRITE, lsp->output_arg, (ase_char_t*)str, ase_strlen(str)) == -1) { \
ase_lsp_seterror (lsp, ASE_LSP_EOUTPUT, ASE_NULL, 0); \
return -1; \
} \
} while (0)
#define OUTPUT_STRX(lsp,str,len) \
do { \
if (lsp->output_func(ASE_LSP_IO_WRITE, lsp->output_arg, (ase_char_t*)str, len) == -1) { \
ase_lsp_seterror (lsp, ASE_LSP_EOUTPUT, ASE_NULL, 0); \
return -1; \
} \
} while (0)
static int __print (ase_lsp_t* lsp, const ase_lsp_obj_t* obj, ase_bool_t prt_cons_par)
{
ase_char_t buf[256];
if (lsp->output_func == ASE_NULL)
{
ase_lsp_seterror (lsp, ASE_LSP_ENOOUTP, ASE_NULL, 0);
return -1;
}
switch (ASE_LSP_TYPE(obj))
{
case ASE_LSP_OBJ_NIL:
OUTPUT_STR (lsp, ASE_T("nil"));
break;
case ASE_LSP_OBJ_TRUE:
OUTPUT_STR (lsp, ASE_T("t"));
break;
case ASE_LSP_OBJ_INT:
#if ASE_SIZEOF_LONG_LONG > 0
lsp->prmfns.misc.sprintf (
lsp->prmfns.misc.custom_data,
buf, ASE_COUNTOF(buf),
ASE_T("%lld"), (long long)ASE_LSP_IVAL(obj));
#elif ASE_SIZEOF___INT64 > 0
lsp->prmfns.misc.sprintf (
lsp->prmfns.misc.custom_data,
buf, ASE_COUNTOF(buf),
ASE_T("%I64d"), (__int64)ASE_LSP_IVAL(obj));
#elif ASE_SIZEOF_LONG > 0
lsp->prmfns.misc.sprintf (
lsp->prmfns.misc.custom_data,
buf, ASE_COUNTOF(buf),
ASE_T("%ld"), (long)ASE_LSP_IVAL(obj));
#elif ASE_SIZEOF_INT > 0
lsp->prmfns.misc.sprintf (
lsp->prmfns.misc.custom_data,
buf, ASE_COUNTOF(buf),
ASE_T("%d"), (int)ASE_LSP_IVAL(obj));
#else
#error unsupported size
#endif
OUTPUT_STR (lsp, buf);
break;
case ASE_LSP_OBJ_REAL:
lsp->prmfns.misc.sprintf (
lsp->prmfns.misc.custom_data,
buf, ASE_COUNTOF(buf),
ASE_T("%Lf"), (long double)ASE_LSP_RVAL(obj));
OUTPUT_STR (lsp, buf);
break;
case ASE_LSP_OBJ_SYM:
OUTPUT_STRX (lsp, ASE_LSP_SYMPTR(obj), ASE_LSP_SYMLEN(obj));
break;
case ASE_LSP_OBJ_STR:
OUTPUT_STR (lsp, ASE_T("\""));
/* TODO: deescaping */
OUTPUT_STRX (lsp, ASE_LSP_STRPTR(obj), ASE_LSP_STRLEN(obj));
OUTPUT_STR (lsp, ASE_T("\""));
break;
case ASE_LSP_OBJ_CONS:
{
const ase_lsp_obj_t* p = obj;
if (prt_cons_par) OUTPUT_STR (lsp, ASE_T("("));
do
{
ase_lsp_print (lsp, ASE_LSP_CAR(p));
p = ASE_LSP_CDR(p);
if (p != lsp->mem->nil)
{
OUTPUT_STR (lsp, ASE_T(" "));
if (ASE_LSP_TYPE(p) != ASE_LSP_OBJ_CONS)
{
OUTPUT_STR (lsp, ASE_T(". "));
ase_lsp_print (lsp, p);
}
}
}
while (p != lsp->mem->nil && ASE_LSP_TYPE(p) == ASE_LSP_OBJ_CONS);
if (prt_cons_par) OUTPUT_STR (lsp, ASE_T(")"));
break;
}
case ASE_LSP_OBJ_FUNC:
/*OUTPUT_STR (lsp, ASE_T("func"));*/
OUTPUT_STR (lsp, ASE_T("(lambda "));
if (__print (lsp, ASE_LSP_FFORMAL(obj), ase_true) == -1) return -1;
OUTPUT_STR (lsp, ASE_T(" "));
if (__print (lsp, ASE_LSP_FBODY(obj), ase_false) == -1) return -1;
OUTPUT_STR (lsp, ASE_T(")"));
break;
case ASE_LSP_OBJ_MACRO:
OUTPUT_STR (lsp, ASE_T("(macro "));
if (__print (lsp, ASE_LSP_FFORMAL(obj), ase_true) == -1) return -1;
OUTPUT_STR (lsp, ASE_T(" "));
if (__print (lsp, ASE_LSP_FBODY(obj), ase_false) == -1) return -1;
OUTPUT_STR (lsp, ASE_T(")"));
break;
case ASE_LSP_OBJ_PRIM:
OUTPUT_STR (lsp, ASE_T("prim"));
break;
default:
lsp->prmfns.misc.sprintf (
lsp->prmfns.misc.custom_data,
buf, ASE_COUNTOF(buf),
ASE_T("unknown object type: %d"), ASE_LSP_TYPE(obj));
OUTPUT_STR (lsp, buf);
}
return 0;
}
int ase_lsp_print (ase_lsp_t* lsp, const ase_lsp_obj_t* obj)
{
return __print (lsp, obj, ase_true);
}

567
ase/lib/lsp/read.c Normal file
View File

@ -0,0 +1,567 @@
/*
* $Id: read.c 117 2008-03-03 11:20:05Z baconevi $
*
* {License}
*/
#include <ase/lsp/lsp_i.h>
#define IS_IDENT(c) \
((c) == ASE_T('+') || (c) == ASE_T('-') || \
(c) == ASE_T('*') || (c) == ASE_T('/') || \
(c) == ASE_T('%') || (c) == ASE_T('&') || \
(c) == ASE_T('<') || (c) == ASE_T('>') || \
(c) == ASE_T('=') || (c) == ASE_T('_') || \
(c) == ASE_T('?'))
#define TOKEN_CLEAR(lsp) ase_lsp_name_clear (&(lsp)->token.name)
#define TOKEN_TYPE(lsp) (lsp)->token.type
#define TOKEN_IVAL(lsp) (lsp)->token.ival
#define TOKEN_RVAL(lsp) (lsp)->token.rval
#define TOKEN_SPTR(lsp) (lsp)->token.name.buf
#define TOKEN_SLEN(lsp) (lsp)->token.name.size
#define TOKEN_ADD_CHAR(lsp,ch) \
do { \
if (ase_lsp_name_addc(&(lsp)->token.name, ch) == -1) { \
ase_lsp_seterror (lsp, ASE_LSP_ENOMEM, ASE_NULL, 0); \
return -1; \
} \
} while (0)
#define TOKEN_COMPARE(lsp,str) \
ase_lsp_name_compare (&(lsp)->token.name, str)
#define TOKEN_END 0
#define TOKEN_INT 1
#define TOKEN_REAL 2
#define TOKEN_STRING 3
#define TOKEN_LPAREN 4
#define TOKEN_RPAREN 5
#define TOKEN_IDENT 6
#define TOKEN_QUOTE 7
#define TOKEN_DOT 8
#define TOKEN_INVALID 50
#define TOKEN_UNTERM_STRING 51
#define NEXT_CHAR(lsp) \
do { if (read_char(lsp) == -1) return -1;} while (0)
#define NEXT_CHAR_TO(lsp,c) \
do { \
if (read_char(lsp) == -1) return -1;\
c = (lsp)->curc; \
} while (0)
#define NEXT_TOKEN(lsp) \
do { if (read_token(lsp) == -1) return ASE_NULL; } while (0)
static ase_lsp_obj_t* read_obj (ase_lsp_t* lsp);
static ase_lsp_obj_t* read_list (ase_lsp_t* lsp);
static ase_lsp_obj_t* read_quote (ase_lsp_t* lsp);
static int read_char (ase_lsp_t* lsp);
static int read_token (ase_lsp_t* lsp);
static int read_number (ase_lsp_t* lsp, int negative);
static int read_ident (ase_lsp_t* lsp);
static int read_string (ase_lsp_t* lsp);
ase_lsp_obj_t* ase_lsp_read (ase_lsp_t* lsp)
{
if (lsp->curc == ASE_CHAR_EOF &&
read_char(lsp) == -1) return ASE_NULL;
NEXT_TOKEN (lsp);
lsp->mem->read = read_obj (lsp);
if (lsp->mem->read != ASE_NULL)
ase_lsp_deepunlockobj (lsp, lsp->mem->read);
return lsp->mem->read;
}
static ase_lsp_obj_t* read_obj (ase_lsp_t* lsp)
{
ase_lsp_obj_t* obj;
switch (TOKEN_TYPE(lsp))
{
case TOKEN_END:
ase_lsp_seterror (lsp, ASE_LSP_EEND, ASE_NULL, 0);
return ASE_NULL;
case TOKEN_LPAREN:
NEXT_TOKEN (lsp);
return read_list (lsp);
case TOKEN_QUOTE:
NEXT_TOKEN (lsp);
return read_quote (lsp);
case TOKEN_INT:
obj = ase_lsp_makeintobj (lsp->mem, TOKEN_IVAL(lsp));
if (obj == ASE_NULL) return ASE_NULL;
ase_lsp_lockobj (lsp, obj);
return obj;
case TOKEN_REAL:
obj = ase_lsp_makerealobj (lsp->mem, TOKEN_RVAL(lsp));
if (obj == ASE_NULL) return ASE_NULL;
ase_lsp_lockobj (lsp, obj);
return obj;
case TOKEN_STRING:
obj = ase_lsp_makestr (
lsp->mem, TOKEN_SPTR(lsp), TOKEN_SLEN(lsp));
if (obj == ASE_NULL) return ASE_NULL;
ase_lsp_lockobj (lsp, obj);
return obj;
case TOKEN_IDENT:
ASE_ASSERT (
lsp->mem->nil != ASE_NULL &&
lsp->mem->t != ASE_NULL);
if (TOKEN_COMPARE(lsp,ASE_T("nil")) == 0)
{
obj = lsp->mem->nil;
}
else if (TOKEN_COMPARE(lsp,ASE_T("t")) == 0)
{
obj = lsp->mem->t;
}
else
{
obj = ase_lsp_makesym (
lsp->mem,
TOKEN_SPTR(lsp),
TOKEN_SLEN(lsp));
if (obj == ASE_NULL) return ASE_NULL;
ase_lsp_lockobj (lsp, obj);
}
return obj;
}
ase_lsp_seterror (lsp, ASE_LSP_ESYNTAX, ASE_NULL, 0);
return ASE_NULL;
}
static ase_lsp_obj_t* read_list (ase_lsp_t* lsp)
{
ase_lsp_obj_t* obj;
ase_lsp_obj_cons_t* p, * first = ASE_NULL, * prev = ASE_NULL;
while (TOKEN_TYPE(lsp) != TOKEN_RPAREN)
{
if (TOKEN_TYPE(lsp) == TOKEN_END)
{
/* unexpected end of input */
ase_lsp_seterror (lsp, ASE_LSP_ESYNTAX, ASE_NULL, 0);
return ASE_NULL;
}
if (TOKEN_TYPE(lsp) == TOKEN_DOT)
{
if (prev == ASE_NULL)
{
/* unexpected dot */
ase_lsp_seterror (lsp, ASE_LSP_ESYNTAX, ASE_NULL, 0);
return ASE_NULL;
}
NEXT_TOKEN (lsp);
obj = read_obj (lsp);
if (obj == ASE_NULL)
{
if (lsp->errnum == ASE_LSP_EEND)
{
/* unexpected end of input */
ase_lsp_seterror (lsp, ASE_LSP_ESYNTAX, ASE_NULL, 0);
}
return ASE_NULL;
}
prev->cdr = obj;
NEXT_TOKEN (lsp);
if (TOKEN_TYPE(lsp) != TOKEN_RPAREN)
{
/* ) expected */
ase_lsp_seterror (lsp, ASE_LSP_ERPAREN, ASE_NULL, 0);
return ASE_NULL;
}
break;
}
obj = read_obj (lsp);
if (obj == ASE_NULL)
{
if (lsp->errnum == ASE_LSP_EEND)
{
/* unexpected end of input */
ase_lsp_seterror (lsp, ASE_LSP_ESYNTAX, ASE_NULL, 0);
}
return ASE_NULL;
}
p = (ase_lsp_obj_cons_t*)ase_lsp_makecons (
lsp->mem, lsp->mem->nil, lsp->mem->nil);
if (p == ASE_NULL) return ASE_NULL;
ase_lsp_lockobj (lsp, (ase_lsp_obj_t*)p);
if (first == ASE_NULL) first = p;
if (prev != ASE_NULL) prev->cdr = (ase_lsp_obj_t*)p;
p->car = obj;
prev = p;
NEXT_TOKEN (lsp);
}
return (first == ASE_NULL)? lsp->mem->nil: (ase_lsp_obj_t*)first;
}
static ase_lsp_obj_t* read_quote (ase_lsp_t* lsp)
{
ase_lsp_obj_t* cons, * tmp;
tmp = read_obj (lsp);
if (tmp == ASE_NULL)
{
if (lsp->errnum == ASE_LSP_EEND)
{
/* unexpected end of input */
ase_lsp_seterror (lsp, ASE_LSP_ESYNTAX, ASE_NULL, 0);
}
return ASE_NULL;
}
cons = ase_lsp_makecons (lsp->mem, tmp, lsp->mem->nil);
if (cons == ASE_NULL) return ASE_NULL;
ase_lsp_lockobj (lsp, cons);
cons = ase_lsp_makecons (lsp->mem, lsp->mem->quote, cons);
if (cons == ASE_NULL) return ASE_NULL;
ase_lsp_lockobj (lsp, cons);
return cons;
}
static int read_char (ase_lsp_t* lsp)
{
ase_ssize_t n;
ase_char_t c;
if (lsp->input_func == ASE_NULL)
{
ase_lsp_seterror (lsp, ASE_LSP_ENOINP, ASE_NULL, 0);
return -1;
}
n = lsp->input_func(ASE_LSP_IO_READ, lsp->input_arg, &c, 1);
if (n == -1)
{
ase_lsp_seterror (lsp, ASE_LSP_EINPUT, ASE_NULL, 0);
return -1;
}
if (n == 0) lsp->curc = ASE_CHAR_EOF;
else lsp->curc = c;
return 0;
}
static int read_token (ase_lsp_t* lsp)
{
ASE_ASSERT (lsp->input_func != ASE_NULL);
TOKEN_CLEAR (lsp);
while (1)
{
/* skip white spaces */
while (ASE_LSP_ISSPACE(lsp, lsp->curc)) NEXT_CHAR (lsp);
/* skip the comments here */
if (lsp->curc == ASE_T(';'))
{
do
{
NEXT_CHAR (lsp);
}
while (lsp->curc != ASE_T('\n') &&
lsp->curc != ASE_CHAR_EOF);
}
else break;
}
if (lsp->curc == ASE_CHAR_EOF)
{
TOKEN_TYPE(lsp) = TOKEN_END;
return 0;
}
else if (lsp->curc == ASE_T('('))
{
TOKEN_ADD_CHAR (lsp, lsp->curc);
TOKEN_TYPE(lsp) = TOKEN_LPAREN;
NEXT_CHAR (lsp);
return 0;
}
else if (lsp->curc == ASE_T(')'))
{
TOKEN_ADD_CHAR (lsp, lsp->curc);
TOKEN_TYPE(lsp) = TOKEN_RPAREN;
NEXT_CHAR (lsp);
return 0;
}
else if (lsp->curc == ASE_T('\''))
{
TOKEN_ADD_CHAR (lsp, lsp->curc);
TOKEN_TYPE(lsp) = TOKEN_QUOTE;
NEXT_CHAR (lsp);
return 0;
}
else if (lsp->curc == ASE_T('.'))
{
TOKEN_ADD_CHAR (lsp, lsp->curc);
TOKEN_TYPE(lsp) = TOKEN_DOT;
NEXT_CHAR (lsp);
return 0;
}
else if (lsp->curc == ASE_T('-'))
{
TOKEN_ADD_CHAR (lsp, lsp->curc);
NEXT_CHAR (lsp);
if (ASE_LSP_ISDIGIT(lsp,lsp->curc))
{
return read_number (lsp, 1);
}
else if (IS_IDENT(lsp->curc))
{
return read_ident (lsp);
}
else
{
TOKEN_TYPE(lsp) = TOKEN_IDENT;
return 0;
}
}
else if (ASE_LSP_ISDIGIT(lsp,lsp->curc))
{
return read_number (lsp, 0);
}
else if (ASE_LSP_ISALPHA(lsp,lsp->curc) || IS_IDENT(lsp->curc))
{
return read_ident (lsp);
}
else if (lsp->curc == ASE_T('\"'))
{
return read_string (lsp);
}
TOKEN_TYPE(lsp) = TOKEN_INVALID;
NEXT_CHAR (lsp); /* consume */
return 0;
}
static int read_number (ase_lsp_t* lsp, int negative)
{
ase_long_t ival = 0;
ase_real_t rval = .0;
do
{
ival = ival * 10 + (lsp->curc - ASE_T('0'));
TOKEN_ADD_CHAR (lsp, lsp->curc);
NEXT_CHAR (lsp);
}
while (ASE_LSP_ISDIGIT(lsp, lsp->curc));
/* TODO: extend parsing floating point number */
if (lsp->curc == ASE_T('.'))
{
ase_real_t fraction = 0.1;
NEXT_CHAR (lsp);
rval = (ase_real_t)ival;
while (ASE_LSP_ISDIGIT(lsp, lsp->curc))
{
rval += (ase_real_t)(lsp->curc - ASE_T('0')) * fraction;
fraction *= 0.1;
NEXT_CHAR (lsp);
}
TOKEN_RVAL(lsp) = rval;
TOKEN_TYPE(lsp) = TOKEN_REAL;
if (negative) rval *= -1;
}
else
{
TOKEN_IVAL(lsp) = ival;
TOKEN_TYPE(lsp) = TOKEN_INT;
if (negative) ival *= -1;
}
return 0;
}
static int read_ident (ase_lsp_t* lsp)
{
do
{
TOKEN_ADD_CHAR (lsp, lsp->curc);
NEXT_CHAR (lsp);
}
while (ASE_LSP_ISALNUM(lsp,lsp->curc) || IS_IDENT(lsp->curc));
TOKEN_TYPE(lsp) = TOKEN_IDENT;
return 0;
}
static int read_string (ase_lsp_t* lsp)
{
ase_cint_t c;
int escaped = 0;
int digit_count = 0;
ase_cint_t c_acc = 0;
while (1)
{
NEXT_CHAR_TO (lsp, c);
if (c == ASE_CHAR_EOF)
{
ase_lsp_seterror (lsp, ASE_LSP_EENDSTR, ASE_NULL, 0);
return -1;
}
if (escaped == 3)
{
if (c >= ASE_T('0') && c <= ASE_T('7'))
{
c_acc = c_acc * 8 + c - ASE_T('0');
digit_count++;
if (digit_count >= escaped)
{
TOKEN_ADD_CHAR (lsp, c_acc);
escaped = 0;
}
continue;
}
else
{
TOKEN_ADD_CHAR (lsp, c_acc);
escaped = 0;
}
}
else if (escaped == 2 || escaped == 4 || escaped == 8)
{
if (c >= ASE_T('0') && c <= ASE_T('9'))
{
c_acc = c_acc * 16 + c - ASE_T('0');
digit_count++;
if (digit_count >= escaped)
{
TOKEN_ADD_CHAR (lsp, c_acc);
escaped = 0;
}
continue;
}
else if (c >= ASE_T('A') && c <= ASE_T('F'))
{
c_acc = c_acc * 16 + c - ASE_T('A') + 10;
digit_count++;
if (digit_count >= escaped)
{
TOKEN_ADD_CHAR (lsp, c_acc);
escaped = 0;
}
continue;
}
else if (c >= ASE_T('a') && c <= ASE_T('f'))
{
c_acc = c_acc * 16 + c - ASE_T('a') + 10;
digit_count++;
if (digit_count >= escaped)
{
TOKEN_ADD_CHAR (lsp, c_acc);
escaped = 0;
}
continue;
}
else
{
ase_char_t rc;
rc = (escaped == 2)? ASE_T('x'):
(escaped == 4)? ASE_T('u'): ASE_T('U');
if (digit_count == 0) TOKEN_ADD_CHAR (lsp, rc);
else TOKEN_ADD_CHAR (lsp, c_acc);
escaped = 0;
}
}
if (escaped == 0 && c == ASE_T('\"'))
{
/* terminating quote */
/*NEXT_CHAR_TO (lsp, c);*/
NEXT_CHAR (lsp);
break;
}
if (escaped == 0 && c == ASE_T('\\'))
{
escaped = 1;
continue;
}
if (escaped == 1)
{
if (c == ASE_T('n')) c = ASE_T('\n');
else if (c == ASE_T('r')) c = ASE_T('\r');
else if (c == ASE_T('t')) c = ASE_T('\t');
else if (c == ASE_T('f')) c = ASE_T('\f');
else if (c == ASE_T('b')) c = ASE_T('\b');
else if (c == ASE_T('v')) c = ASE_T('\v');
else if (c == ASE_T('a')) c = ASE_T('\a');
else if (c >= ASE_T('0') && c <= ASE_T('7'))
{
escaped = 3;
digit_count = 1;
c_acc = c - ASE_T('0');
continue;
}
else if (c == ASE_T('x'))
{
escaped = 2;
digit_count = 0;
c_acc = 0;
continue;
}
#ifdef ASE_CHAR_IS_WCHAR
else if (c == ASE_T('u') && ASE_SIZEOF(ase_char_t) >= 2)
{
escaped = 4;
digit_count = 0;
c_acc = 0;
continue;
}
else if (c == ASE_T('U') && ASE_SIZEOF(ase_char_t) >= 4)
{
escaped = 8;
digit_count = 0;
c_acc = 0;
continue;
}
#endif
escaped = 0;
}
TOKEN_ADD_CHAR (lsp, c);
}
TOKEN_TYPE(lsp) = TOKEN_STRING;
return 0;
}