├── cmake ├── cpack │ ├── WELCOME.txt │ ├── LICENSE.txt │ └── README.txt ├── options.cmake ├── config.cmake ├── parse-core-ext-files.cmake ├── sac-core-ext.txt └── cpack.cmake ├── .gitignore ├── src ├── auxiliary │ └── Interval.sac ├── structures │ ├── src │ │ ├── Format │ │ │ └── wordsize.c │ │ ├── Constants │ │ │ ├── randmax.c │ │ │ ├── maxint.c │ │ │ ├── minint.c │ │ │ ├── epidouble.c │ │ │ ├── maxdouble.c │ │ │ ├── maxfloat.c │ │ │ ├── minfloat.c │ │ │ ├── tinydouble.c │ │ │ ├── mindouble.c │ │ │ └── minmax.c │ │ ├── String │ │ │ ├── strlen.c │ │ │ ├── freestr.c │ │ │ ├── copystr.c │ │ │ ├── strsel.c │ │ │ ├── strcmp.c │ │ │ ├── strcspn.c │ │ │ ├── strspn.c │ │ │ ├── strcasecmp.c │ │ │ ├── strncmp.c │ │ │ ├── itos.c │ │ │ ├── strstr.c │ │ │ ├── dtos.c │ │ │ ├── ftos.c │ │ │ ├── strncasecmp.c │ │ │ ├── ctos.c │ │ │ ├── sscanf.c │ │ │ ├── sscanfstr.c │ │ │ ├── strchr.c │ │ │ ├── strrchr.c │ │ │ ├── btos.c │ │ │ ├── strdrop.c │ │ │ ├── strncat.c │ │ │ ├── strcat.c │ │ │ ├── strins.c │ │ │ ├── strtod.c │ │ │ ├── strtof.c │ │ │ ├── strtoi.c │ │ │ ├── strext.c │ │ │ ├── StringC.h │ │ │ ├── tostring.c │ │ │ ├── strtok.c │ │ │ ├── sprintf.c │ │ │ ├── strmod.c │ │ │ ├── strtake.c │ │ │ ├── strovwt.c │ │ │ └── trim.c │ │ ├── StringArray │ │ │ ├── index2offset.c │ │ │ ├── alloc.c │ │ │ ├── dim.c │ │ │ ├── free.c │ │ │ ├── StringArray.h │ │ │ ├── copy.c │ │ │ ├── shape.c │ │ │ ├── sel.c │ │ │ ├── genarray.c │ │ │ └── modarray.c │ │ ├── List │ │ │ ├── List.h │ │ │ ├── free.c │ │ │ ├── empty.c │ │ │ ├── length.c │ │ │ ├── hd.c │ │ │ ├── nil.c │ │ │ ├── nth.c │ │ │ ├── tl.c │ │ │ ├── cons.c │ │ │ ├── drop.c │ │ │ └── append.c │ │ └── Char │ │ │ └── ctype.c │ ├── Vector3d.xsac │ ├── Vector3f.xsac │ ├── Array.sac │ ├── Complex.sac │ ├── Structures.sac │ ├── ArrayBasics.xsac │ ├── ComplexArrayTransform.xsac │ ├── List.sac │ ├── ArrayReduce.xsac │ ├── Constants.sac │ └── Quaternion.xsac ├── stdio │ ├── src │ │ ├── File │ │ │ ├── rm.c │ │ │ ├── File.h │ │ │ ├── fclose.c │ │ │ ├── feof.c │ │ │ ├── fflush.c │ │ │ ├── rewind.c │ │ │ ├── ftell.c │ │ │ ├── fgetc.c │ │ │ ├── fputs.c │ │ │ ├── ungetc.c │ │ │ ├── fputc.c │ │ │ ├── fseek.c │ │ │ ├── fprintf.c │ │ │ ├── fscanf.c │ │ │ ├── fopen.c │ │ │ ├── fscanl.c │ │ │ ├── fscans.c │ │ │ ├── fgets.c │ │ │ └── mkstemp.c │ │ ├── TermFile │ │ │ ├── TermFile.h │ │ │ ├── puts.c │ │ │ ├── feof.c │ │ │ ├── fflush.c │ │ │ ├── fgetc.c │ │ │ ├── fputs.c │ │ │ ├── ungetc.c │ │ │ ├── fputc.c │ │ │ ├── printf.c │ │ │ ├── fprintf.c │ │ │ ├── scanf.c │ │ │ ├── fscanf.c │ │ │ ├── stdstreams.c │ │ │ ├── fscanl.c │ │ │ ├── fscans.c │ │ │ └── fgets.c │ │ ├── BinFile │ │ │ ├── BinFile.h │ │ │ ├── binfclose.c │ │ │ ├── binfopen.c │ │ │ ├── binfflags.c │ │ │ ├── binfWriteDblArr.c │ │ │ └── binfReadDblArr.c │ │ ├── FibreIO │ │ │ ├── ScanInt.c │ │ │ ├── ScanFlt.c │ │ │ ├── ScanDbl.c │ │ │ ├── ScanString.c │ │ │ ├── ScanOthers.c │ │ │ ├── ScanIntArr.c │ │ │ ├── ScanFltArr.c │ │ │ ├── ScanDblArr.c │ │ │ ├── ScanOthersArr.c │ │ │ ├── FibreScan.h │ │ │ └── ScanStringArr.c │ │ ├── ArrayIO │ │ │ └── ShowArray.c │ │ └── ComplexIO │ │ │ └── PrintComplexArray.c │ ├── IOresources.sac │ └── StdIO.sac ├── system │ ├── src │ │ ├── Process │ │ │ ├── pclose.c │ │ │ ├── system.c │ │ │ ├── Process.h │ │ │ └── process.c │ │ ├── Environment │ │ │ ├── Env.h │ │ │ ├── Env.c │ │ │ ├── ExistEnv.c │ │ │ ├── UnsetEnv.c │ │ │ ├── GetEnv.c │ │ │ ├── SetEnv.c │ │ │ └── Environ.c │ │ ├── World │ │ │ └── World.c │ │ ├── Clock │ │ │ ├── clock.c │ │ │ ├── Clock.h │ │ │ ├── to_time.c │ │ │ ├── sleep.c │ │ │ ├── difftime.c │ │ │ ├── isdst.c │ │ │ ├── gettime.c │ │ │ ├── copytime.c │ │ │ ├── ctime.c │ │ │ ├── strftime.c │ │ │ ├── isleap.c │ │ │ ├── date.c │ │ │ ├── mktime.c │ │ │ ├── strptime.c │ │ │ └── extracttime.c │ │ ├── FileSystem │ │ │ ├── filesys.c │ │ │ ├── mktemp.c │ │ │ ├── FileSystem.h │ │ │ ├── pltmp.c │ │ │ ├── remove.c │ │ │ ├── rename.c │ │ │ ├── symlink.c │ │ │ ├── access.c │ │ │ ├── dir.c │ │ │ └── testfile.c │ │ ├── Terminal │ │ │ └── terminal.c │ │ ├── Dir │ │ │ ├── Dir.h │ │ │ ├── closedir.c │ │ │ ├── rewinddir.c │ │ │ ├── telldir.c │ │ │ ├── seekdir.c │ │ │ ├── opendir.c │ │ │ └── readdir.c │ │ ├── TimeStamp │ │ │ └── TimeStamp.c │ │ ├── RuntimeError │ │ │ └── error.c │ │ ├── SysErr │ │ │ ├── failsucc.c │ │ │ └── strerror.c │ │ ├── RTClock │ │ │ └── rtclock.c │ │ ├── MTClock │ │ │ └── mtclock.c │ │ ├── CommandLine │ │ │ └── CommandLine.c │ │ └── RTimer │ │ │ └── rtimer.c │ ├── TimeStamp.sac │ ├── System.sac │ ├── RuntimeError.sac │ ├── RTClock.sac │ ├── Terminal.sac │ ├── World.sac │ ├── MTClock.sac │ ├── RTimer.sac │ ├── Process.sac │ ├── CommandLine.sac │ ├── Dir.sac │ ├── Environment.sac │ └── GetOpt.sac ├── numerical │ ├── src │ │ └── Math │ │ │ ├── isinf.c │ │ │ ├── isnan.c │ │ │ ├── isfinite.c │ │ │ ├── sign.c │ │ │ └── int_log.c │ ├── Numerical.sac │ └── MathArray.sac ├── random │ ├── src │ │ └── Xoshiro.c │ ├── xoshiro128p.sage │ └── xoshiro256p.sage └── utrace │ └── Indent.sac ├── .gitmodules ├── Makefile ├── CONTRIBUTORS.md ├── LICENSE.md ├── ci └── fail-on-warning.sh ├── test └── xoshiro-advance.sac ├── scripts └── debug.sh ├── CMakeLists.txt ├── README.md └── include └── builtin.mac /cmake/cpack/WELCOME.txt: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /cmake/cpack/LICENSE.txt: -------------------------------------------------------------------------------- 1 | ../../LICENSE.md -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # IDE generated files 2 | .vscode/ 3 | 4 | # CMake 5 | build/ 6 | -------------------------------------------------------------------------------- /src/auxiliary/Interval.sac: -------------------------------------------------------------------------------- 1 | class Interval; 2 | external classtype; 3 | 4 | export {Interval}; 5 | -------------------------------------------------------------------------------- /src/structures/src/Format/wordsize.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | int wordsize(){ 4 | return __WORDSIZE; 5 | } 6 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "cmake-common"] 2 | path = cmake-common 3 | url = https://github.com/SacBase/cmake-common.git 4 | -------------------------------------------------------------------------------- /src/stdio/src/File/rm.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | void fremove( char* fname) 4 | { 5 | remove( fname); 6 | } 7 | 8 | -------------------------------------------------------------------------------- /src/structures/src/Constants/randmax.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | int randmax( void) 4 | { 5 | return RAND_MAX; 6 | } 7 | -------------------------------------------------------------------------------- /src/system/src/Process/pclose.c: -------------------------------------------------------------------------------- 1 | #include "Process.h" 2 | 3 | void SACpclose (FILE *f) 4 | { 5 | pclose( f); 6 | } 7 | 8 | -------------------------------------------------------------------------------- /src/structures/src/Constants/maxint.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | 4 | int maxint( void) 5 | { 6 | return( INT_MAX); 7 | } 8 | -------------------------------------------------------------------------------- /src/structures/src/Constants/minint.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | 4 | int minint( void) 5 | { 6 | return( INT_MIN ); 7 | } 8 | -------------------------------------------------------------------------------- /src/structures/src/Constants/epidouble.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | double epidouble( void) 4 | { 5 | return( DBL_EPSILON); 6 | } 7 | -------------------------------------------------------------------------------- /src/structures/src/Constants/maxdouble.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | 4 | double maxdouble( void) 5 | { 6 | return( DBL_MAX); 7 | } 8 | -------------------------------------------------------------------------------- /src/structures/src/Constants/maxfloat.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | 4 | float maxfloat( void) 5 | { 6 | return( FLT_MAX); 7 | } 8 | -------------------------------------------------------------------------------- /src/structures/Vector3d.xsac: -------------------------------------------------------------------------------- 1 | #define REAL double 2 | #define VECTOR3 Vector3d 3 | #define VX xd 4 | #define VY yd 5 | #define VZ zd 6 | 7 | #include "Vector3.mac" 8 | -------------------------------------------------------------------------------- /src/structures/Vector3f.xsac: -------------------------------------------------------------------------------- 1 | #define REAL float 2 | #define VECTOR3 Vector3f 3 | #define VX xf 4 | #define VY yf 5 | #define VZ zf 6 | 7 | #include "Vector3.mac" 8 | -------------------------------------------------------------------------------- /src/structures/src/Constants/minfloat.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | 4 | float minfloat( void) 5 | { 6 | return( -FLT_MAX); /* do not use FLT_MIN here!!! */ 7 | } 8 | -------------------------------------------------------------------------------- /src/system/src/Process/system.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | int SACsystem (char *command) 4 | { 5 | const char * cmd = command; 6 | return system (cmd); 7 | } 8 | 9 | -------------------------------------------------------------------------------- /cmake/cpack/README.txt: -------------------------------------------------------------------------------- 1 | This package provides the standard library for the SAC array 2 | programming language. To use it, please install the SAC compile 3 | as well, called `sac2c'. 4 | -------------------------------------------------------------------------------- /src/system/src/Environment/Env.h: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of standard module Env 3 | */ 4 | 5 | 6 | #include 7 | #include 8 | 9 | #include "sac.h" 10 | -------------------------------------------------------------------------------- /src/system/src/Process/Process.h: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of Process 3 | */ 4 | 5 | 6 | #include 7 | #include 8 | 9 | #include "sac.h" 10 | 11 | 12 | -------------------------------------------------------------------------------- /src/system/src/World/World.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of class World 3 | */ 4 | 5 | 6 | 7 | void *create_TheWorld( void) 8 | { 9 | return(0); 10 | } 11 | 12 | 13 | 14 | -------------------------------------------------------------------------------- /src/system/src/Clock/clock.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of standard class Clock 3 | */ 4 | 5 | 6 | void *create_TheClock( void) 7 | { 8 | return(0); 9 | } 10 | 11 | 12 | 13 | 14 | -------------------------------------------------------------------------------- /src/system/src/Environment/Env.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of class Environment 3 | */ 4 | 5 | 6 | void *create_TheEnvironment( void) 7 | { 8 | return(0); 9 | } 10 | 11 | 12 | 13 | 14 | -------------------------------------------------------------------------------- /src/numerical/src/Math/isinf.c: -------------------------------------------------------------------------------- 1 | /** 2 | * Proper C function wrappers around MACROS. 3 | */ 4 | #include 5 | 6 | int SAC_MATH_isinf( double X) 7 | { 8 | return( isinf( X)); 9 | } 10 | -------------------------------------------------------------------------------- /src/numerical/src/Math/isnan.c: -------------------------------------------------------------------------------- 1 | /** 2 | * Proper C function wrappers around MACROS. 3 | */ 4 | #include 5 | 6 | int SAC_MATH_isnan( double X) 7 | { 8 | return( isnan( X)); 9 | } 10 | -------------------------------------------------------------------------------- /src/system/src/FileSystem/filesys.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of class FileSystem 3 | */ 4 | 5 | 6 | void *create_TheFileSystem( void ) 7 | { 8 | return(0); 9 | } 10 | 11 | 12 | 13 | 14 | -------------------------------------------------------------------------------- /src/system/src/Terminal/terminal.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of class Terminal 3 | */ 4 | 5 | 6 | 7 | void *create_TheTerminal( void) 8 | { 9 | return(0); 10 | } 11 | 12 | 13 | 14 | 15 | -------------------------------------------------------------------------------- /src/numerical/src/Math/isfinite.c: -------------------------------------------------------------------------------- 1 | /** 2 | * Proper C function wrappers around MACROS. 3 | */ 4 | #include 5 | 6 | int SAC_MATH_isfinite( double X) 7 | { 8 | return( isfinite( X)); 9 | } 10 | -------------------------------------------------------------------------------- /src/system/TimeStamp.sac: -------------------------------------------------------------------------------- 1 | #pragma safe 2 | module TimeStamp; 3 | 4 | export all; 5 | 6 | external void timeStamp(); 7 | #pragma effect World::TheWorld 8 | #pragma linkobj "src/TimeStamp/TimeStamp.o" 9 | -------------------------------------------------------------------------------- /src/numerical/Numerical.sac: -------------------------------------------------------------------------------- 1 | #pragma safe 2 | module Numerical; 3 | 4 | import Math: all; 5 | import MathArray: all; 6 | #ifdef EXT_STDLIB 7 | import ComplexMath: all; 8 | #endif /* EXT_STDLIB */ 9 | 10 | export all; 11 | -------------------------------------------------------------------------------- /src/numerical/src/Math/sign.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | int SAC_MATH_sign(double X) 4 | { 5 | return copysign(1.0, X); 6 | } 7 | 8 | int SAC_MATH_signf(float X) 9 | { 10 | return copysign(1.0, (double)X); 11 | } 12 | -------------------------------------------------------------------------------- /src/system/src/Clock/Clock.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of standard module Time 3 | */ 4 | 5 | 6 | #include 7 | #include 8 | 9 | 10 | #include "sac.h" 11 | 12 | typedef char* string; 13 | 14 | 15 | -------------------------------------------------------------------------------- /src/system/src/FileSystem/mktemp.c: -------------------------------------------------------------------------------- 1 | #include // needed on OSX 2 | #include // needed on linux 3 | 4 | char * 5 | SACmkdtemp (char * template) 6 | { 7 | return mkdtemp (template); 8 | } 9 | 10 | -------------------------------------------------------------------------------- /src/system/src/Environment/ExistEnv.c: -------------------------------------------------------------------------------- 1 | #include "Env.h" 2 | 3 | /******************************************************************/ 4 | 5 | 6 | int ExistEnv(char *envvar) 7 | { 8 | return (getenv(envvar) != NULL); 9 | } 10 | -------------------------------------------------------------------------------- /src/structures/src/Constants/tinydouble.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | /* DBL_MIN represents the smallest normilised 4 | * value that can be represented. 5 | */ 6 | double tinydouble( void) 7 | { 8 | return( DBL_MIN); 9 | } 10 | -------------------------------------------------------------------------------- /src/system/src/Clock/to_time.c: -------------------------------------------------------------------------------- 1 | /* $Id$ */ 2 | 3 | #include "Clock.h" 4 | 5 | time_t *SACto_time( int secs) 6 | { 7 | time_t *res = (time_t *) SAC_MALLOC( sizeof( time_t)); 8 | 9 | *res = (time_t) secs; 10 | 11 | return( res); 12 | } 13 | -------------------------------------------------------------------------------- /src/system/src/Dir/Dir.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of standard module Dir 3 | */ 4 | 5 | 6 | #include 7 | #include 8 | #include 9 | #include 10 | 11 | #include "sac.h" 12 | 13 | typedef char* string; 14 | 15 | 16 | -------------------------------------------------------------------------------- /src/stdio/src/TermFile/TermFile.h: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of standard class TermFile 3 | */ 4 | 5 | 6 | #include 7 | #include 8 | #include 9 | #include 10 | 11 | #include "sac.h" 12 | #include "sacinterface.h" 13 | 14 | 15 | -------------------------------------------------------------------------------- /src/random/src/Xoshiro.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | unsigned long SAC_srand_time(void) 5 | { 6 | unsigned long low_bits = (unsigned long)time(NULL); 7 | unsigned long high_bits = (unsigned long)rand(); 8 | return ((high_bits << 32) | low_bits); 9 | } 10 | -------------------------------------------------------------------------------- /src/stdio/IOresources.sac: -------------------------------------------------------------------------------- 1 | #pragma safe 2 | module IOresources; 3 | 4 | import File: { File }; 5 | import TermFile: { TermFile, stdin, stdout, stderr }; 6 | import Terminal: { TheTerminal }; 7 | import FileSystem: { TheFileSystem }; 8 | import World: { TheWorld }; 9 | 10 | export all; 11 | -------------------------------------------------------------------------------- /src/system/src/TimeStamp/TimeStamp.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | void timeStamp( void){ 5 | struct timeval time; 6 | if ( gettimeofday(&time, (struct timezone *)NULL) == 0){ 7 | printf( "%09d.%06d\n", (int)(time.tv_sec), (int)(time.tv_usec)); 8 | } 9 | } 10 | -------------------------------------------------------------------------------- /src/system/System.sac: -------------------------------------------------------------------------------- 1 | #pragma safe 2 | module System; 3 | 4 | import Clock: all; 5 | import CommandLine: all; 6 | import Environment: all; 7 | import FileSystem: all; 8 | import RuntimeError: all; 9 | import SysErr: all; 10 | import Terminal: all; 11 | import World: all; 12 | 13 | export all; 14 | -------------------------------------------------------------------------------- /src/system/RuntimeError.sac: -------------------------------------------------------------------------------- 1 | #pragma safe 2 | module RuntimeError; 3 | 4 | export all; 5 | 6 | external void error(int result, String::string message, ...); 7 | #pragma effect Terminal::TheTerminal 8 | #pragma linkobj "src/RuntimeError/error.o" 9 | #pragma linkname "SAC__RUNTIMEERROR_error" 10 | -------------------------------------------------------------------------------- /src/stdio/src/BinFile/BinFile.h: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class File 3 | */ 4 | 5 | 6 | #include 7 | #include 8 | #include 9 | #include 10 | #include 11 | #include 12 | #include 13 | 14 | 15 | #include "sac.h" 16 | 17 | 18 | -------------------------------------------------------------------------------- /src/stdio/StdIO.sac: -------------------------------------------------------------------------------- 1 | #pragma safe 2 | module StdIO; 3 | 4 | import ArrayIO: all; 5 | import BinFile: all; 6 | import File: all; 7 | import ScalarIO: all; 8 | import TermFile: all; 9 | 10 | #ifdef EXT_STDLIB 11 | import ComplexIO: all; 12 | import FibreIO: all; 13 | import ListIO: all; 14 | #endif 15 | 16 | export all; 17 | -------------------------------------------------------------------------------- /src/stdio/src/FibreIO/ScanInt.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of standard module FibreScan 3 | */ 4 | 5 | 6 | #include "FibreScan.h" 7 | #include "FibreScan.tab.h" 8 | 9 | 10 | int FibreScanInt( FILE *stream) 11 | { 12 | start_token = PARSE_INT; 13 | doScan( stream); 14 | return( intval); 15 | } 16 | 17 | 18 | 19 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | BUILD_DIR ?= build 2 | TARGETS ?= seq;mt_pth;seq_checks 3 | 4 | .PHONY: all build clean 5 | 6 | all: build 7 | 8 | build: 9 | git submodule update --init --recursive 10 | mkdir -p $(BUILD_DIR) && cd $(BUILD_DIR) && \ 11 | cmake -DTARGETS="$(TARGETS)" .. && $(MAKE) 12 | 13 | clean: 14 | $(RM) -r $(BUILD_DIR) 15 | -------------------------------------------------------------------------------- /src/stdio/src/FibreIO/ScanFlt.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of standard module FibreScan 3 | */ 4 | 5 | 6 | #include "FibreScan.h" 7 | #include "FibreScan.tab.h" 8 | 9 | 10 | float FibreScanFloat( FILE *stream) 11 | { 12 | start_token = PARSE_FLOAT; 13 | doScan( stream); 14 | return( floatval); 15 | } 16 | 17 | 18 | 19 | -------------------------------------------------------------------------------- /src/structures/Array.sac: -------------------------------------------------------------------------------- 1 | #pragma safe 2 | 3 | module Array; 4 | 5 | import ScalarArith: all; 6 | import ArrayArith: all; 7 | import ArrayBasics: all; 8 | import ArrayReduce: all; 9 | import ArrayTransform: all; 10 | 11 | #ifdef EXT_STDLIB 12 | import ArrayTransformApl: all; 13 | #endif /* EXT_STDLIB */ 14 | 15 | export all; 16 | -------------------------------------------------------------------------------- /src/stdio/src/FibreIO/ScanDbl.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of standard module FibreScan 3 | */ 4 | 5 | 6 | #include "FibreScan.h" 7 | #include "FibreScan.tab.h" 8 | 9 | 10 | double FibreScanDouble( FILE *stream) 11 | { 12 | start_token = PARSE_DOUBLE; 13 | doScan( stream); 14 | return( doubleval); 15 | } 16 | 17 | 18 | 19 | -------------------------------------------------------------------------------- /src/stdio/src/File/File.h: -------------------------------------------------------------------------------- 1 | #ifndef _STDLIB_FILE_H_ 2 | #define _STDLIB_FILE_H_ 3 | /* 4 | * implementation of class File 5 | */ 6 | 7 | 8 | #include 9 | #include 10 | #include 11 | #include 12 | #include 13 | 14 | #include "sac.h" 15 | 16 | #endif /* _STDLIB_FILE_H_ */ 17 | -------------------------------------------------------------------------------- /src/stdio/src/FibreIO/ScanString.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of standard module FibreScan 3 | */ 4 | 5 | 6 | #include "FibreScan.h" 7 | #include "FibreScan.tab.h" 8 | 9 | 10 | char *FibreScanString( FILE *stream) 11 | { 12 | start_token = PARSE_STRING; 13 | doScan( stream); 14 | return( stringval); 15 | } 16 | 17 | 18 | 19 | -------------------------------------------------------------------------------- /cmake/options.cmake: -------------------------------------------------------------------------------- 1 | # You can choose to build less or more of the compiler to decrease compilation time. 2 | OPTION (BUILD_EXT "Build extended standard library." ON) 3 | OPTION (FULLTYPES "Compile for all supported types." OFF) 4 | OPTION (BUILDGENERIC "Do not use -march=native -mtune=native" OFF) 5 | -------------------------------------------------------------------------------- /src/structures/Complex.sac: -------------------------------------------------------------------------------- 1 | #pragma safe 2 | 3 | module Complex; 4 | 5 | import ComplexBasics: all; 6 | import ComplexArrayBasics: all; 7 | import ComplexArrayArith: all; 8 | import ComplexArrayTransform: all; 9 | 10 | // Do not import ScalarArith again; it is already imported through ArrayArith 11 | // import ComplexScalarArith: all; 12 | 13 | export all; 14 | -------------------------------------------------------------------------------- /src/stdio/src/File/fclose.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class File 3 | */ 4 | 5 | 6 | 7 | #include "File.h" 8 | 9 | 10 | 11 | /*****************************************************************/ 12 | 13 | 14 | void SACfclose(FILE *stream) 15 | { 16 | fclose(stream); 17 | } 18 | 19 | 20 | /*****************************************************************/ 21 | -------------------------------------------------------------------------------- /src/structures/src/String/strlen.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of standard module StringC 3 | */ 4 | 5 | 6 | #include "StringC.h" 7 | 8 | 9 | /*****************************************************************/ 10 | 11 | int SACstrlen(string s) 12 | { 13 | return( strlen( s)); 14 | } 15 | 16 | /*****************************************************************/ 17 | -------------------------------------------------------------------------------- /src/stdio/src/File/feof.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class File 3 | */ 4 | 5 | 6 | 7 | #include "File.h" 8 | 9 | 10 | /*****************************************************************/ 11 | 12 | 13 | bool SACfeof(FILE *f) 14 | { 15 | return feof( f); 16 | } 17 | 18 | 19 | /*****************************************************************/ 20 | 21 | 22 | 23 | -------------------------------------------------------------------------------- /src/stdio/src/File/fflush.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class File 3 | */ 4 | 5 | 6 | 7 | #include "File.h" 8 | 9 | 10 | /*****************************************************************/ 11 | 12 | 13 | void SACfflush(FILE *f) 14 | { 15 | fflush( f); 16 | } 17 | 18 | 19 | /*****************************************************************/ 20 | 21 | 22 | 23 | -------------------------------------------------------------------------------- /src/stdio/src/File/rewind.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class File 3 | */ 4 | 5 | 6 | 7 | #include "File.h" 8 | 9 | 10 | /*****************************************************************/ 11 | 12 | 13 | void SACrewind(FILE *f) 14 | { 15 | rewind( f); 16 | } 17 | 18 | 19 | /*****************************************************************/ 20 | 21 | 22 | 23 | -------------------------------------------------------------------------------- /src/structures/src/String/freestr.c: -------------------------------------------------------------------------------- 1 | 2 | /* 3 | * implementation of standard module StringC 4 | */ 5 | 6 | 7 | #include "StringC.h" 8 | 9 | 10 | /*****************************************************************/ 11 | 12 | void free_string( string s) 13 | { 14 | STRFREE( s); 15 | } 16 | 17 | /*****************************************************************/ 18 | -------------------------------------------------------------------------------- /src/stdio/src/File/ftell.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class File 3 | */ 4 | 5 | 6 | 7 | #include "File.h" 8 | 9 | 10 | /*****************************************************************/ 11 | 12 | 13 | int SACftell(FILE *f) 14 | { 15 | return ftell( f); 16 | } 17 | 18 | 19 | /*****************************************************************/ 20 | 21 | 22 | 23 | -------------------------------------------------------------------------------- /src/stdio/src/TermFile/puts.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class File 3 | */ 4 | 5 | 6 | 7 | #include "TermFile.h" 8 | 9 | 10 | /*****************************************************************/ 11 | 12 | 13 | void SACputs_TF(char *s) 14 | { 15 | puts( s); 16 | } 17 | 18 | 19 | /*****************************************************************/ 20 | 21 | 22 | 23 | -------------------------------------------------------------------------------- /src/system/src/Dir/closedir.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of directory functions. 3 | */ 4 | 5 | 6 | 7 | #include "Dir.h" 8 | 9 | 10 | 11 | /*****************************************************************/ 12 | 13 | void SACclosedir( DIR* stream) 14 | { 15 | closedir( stream); 16 | } 17 | 18 | 19 | /*****************************************************************/ 20 | -------------------------------------------------------------------------------- /src/system/src/Environment/UnsetEnv.c: -------------------------------------------------------------------------------- 1 | #include "Env.h" 2 | 3 | /******************************************************************/ 4 | 5 | 6 | void UnsetEnv(char *envvar) 7 | { 8 | #if HAVE_UNSETENV 9 | unsetenv(envvar); 10 | #else 11 | putenv(envvar); 12 | #endif 13 | } 14 | 15 | 16 | /******************************************************************/ 17 | 18 | 19 | -------------------------------------------------------------------------------- /src/stdio/src/TermFile/feof.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class File 3 | */ 4 | 5 | 6 | 7 | #include "TermFile.h" 8 | 9 | 10 | /*****************************************************************/ 11 | 12 | 13 | bool SACfeof_TF(FILE *f) 14 | { 15 | return feof( f); 16 | } 17 | 18 | 19 | /*****************************************************************/ 20 | 21 | 22 | 23 | -------------------------------------------------------------------------------- /src/stdio/src/TermFile/fflush.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class File 3 | */ 4 | 5 | 6 | 7 | #include "TermFile.h" 8 | 9 | 10 | /*****************************************************************/ 11 | 12 | 13 | void SACfflush_TF(FILE *f) 14 | { 15 | fflush( f); 16 | } 17 | 18 | 19 | /*****************************************************************/ 20 | 21 | 22 | 23 | -------------------------------------------------------------------------------- /src/system/src/Dir/rewinddir.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of directory functions. 3 | */ 4 | 5 | 6 | 7 | #include "Dir.h" 8 | 9 | 10 | 11 | /*****************************************************************/ 12 | 13 | void SACrewinddir( DIR* stream) 14 | { 15 | rewinddir( stream); 16 | } 17 | 18 | 19 | /*****************************************************************/ 20 | -------------------------------------------------------------------------------- /src/stdio/src/File/fgetc.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class File 3 | */ 4 | 5 | 6 | 7 | #include "File.h" 8 | 9 | 10 | /*****************************************************************/ 11 | 12 | 13 | char SACfgetc(FILE *stream) 14 | { 15 | return fgetc( stream); 16 | } 17 | 18 | 19 | /*****************************************************************/ 20 | 21 | 22 | 23 | -------------------------------------------------------------------------------- /src/system/src/Dir/telldir.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of directory functions. 3 | */ 4 | 5 | 6 | 7 | #include "Dir.h" 8 | 9 | 10 | 11 | /*****************************************************************/ 12 | 13 | long SACtelldir( DIR* stream) 14 | { 15 | return( telldir( stream)); 16 | } 17 | 18 | 19 | /*****************************************************************/ 20 | -------------------------------------------------------------------------------- /src/stdio/src/File/fputs.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class File 3 | */ 4 | 5 | 6 | 7 | #include "File.h" 8 | 9 | 10 | /*****************************************************************/ 11 | 12 | 13 | void SACfputs(char *s, FILE *stream) 14 | { 15 | fputs( s, stream); 16 | } 17 | 18 | 19 | /*****************************************************************/ 20 | 21 | 22 | 23 | -------------------------------------------------------------------------------- /src/stdio/src/File/ungetc.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class File 3 | */ 4 | 5 | 6 | 7 | #include "File.h" 8 | 9 | 10 | /*****************************************************************/ 11 | 12 | 13 | void SACungetc(char c, FILE *stream) 14 | { 15 | ungetc( c, stream); 16 | } 17 | 18 | 19 | /*****************************************************************/ 20 | 21 | 22 | 23 | -------------------------------------------------------------------------------- /src/system/src/Dir/seekdir.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of directory functions. 3 | */ 4 | 5 | 6 | 7 | #include "Dir.h" 8 | 9 | 10 | 11 | /*****************************************************************/ 12 | 13 | void SACseekdir( DIR* stream, long pos) 14 | { 15 | seekdir( stream, pos); 16 | } 17 | 18 | 19 | /*****************************************************************/ 20 | -------------------------------------------------------------------------------- /src/stdio/src/File/fputc.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class File 3 | */ 4 | 5 | 6 | 7 | #include "File.h" 8 | 9 | 10 | /*****************************************************************/ 11 | 12 | 13 | int SACfputc(char c, FILE *stream) 14 | { 15 | return fputc( c, stream); 16 | } 17 | 18 | 19 | /*****************************************************************/ 20 | 21 | 22 | 23 | -------------------------------------------------------------------------------- /src/stdio/src/File/fseek.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class File 3 | */ 4 | 5 | 6 | 7 | #include "File.h" 8 | 9 | 10 | /*****************************************************************/ 11 | 12 | 13 | void SACfseek(FILE *f, int off, int base) 14 | { 15 | fseek( f, off, base); 16 | } 17 | 18 | 19 | /*****************************************************************/ 20 | 21 | 22 | 23 | -------------------------------------------------------------------------------- /src/stdio/src/TermFile/fgetc.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class File 3 | */ 4 | 5 | 6 | 7 | #include "TermFile.h" 8 | 9 | 10 | /*****************************************************************/ 11 | 12 | 13 | char SACfgetc_TF(FILE *stream) 14 | { 15 | return fgetc( stream); 16 | } 17 | 18 | 19 | /*****************************************************************/ 20 | 21 | 22 | 23 | -------------------------------------------------------------------------------- /src/stdio/src/TermFile/fputs.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class File 3 | */ 4 | 5 | 6 | 7 | #include "TermFile.h" 8 | 9 | 10 | /*****************************************************************/ 11 | 12 | 13 | void SACfputs_TF(char *s, FILE *stream) 14 | { 15 | fputs( s, stream); 16 | } 17 | 18 | 19 | /*****************************************************************/ 20 | 21 | 22 | 23 | -------------------------------------------------------------------------------- /src/stdio/src/TermFile/ungetc.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class File 3 | */ 4 | 5 | 6 | 7 | #include "TermFile.h" 8 | 9 | 10 | /*****************************************************************/ 11 | 12 | 13 | void SACungetc_TF(char c, FILE *stream) 14 | { 15 | ungetc( c, stream); 16 | } 17 | 18 | 19 | /*****************************************************************/ 20 | 21 | 22 | 23 | -------------------------------------------------------------------------------- /src/stdio/src/TermFile/fputc.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class File 3 | */ 4 | 5 | 6 | 7 | #include "TermFile.h" 8 | 9 | 10 | /*****************************************************************/ 11 | 12 | 13 | int SACfputc_TF(char c, FILE *stream) 14 | { 15 | return fputc( c, stream); 16 | } 17 | 18 | 19 | /*****************************************************************/ 20 | 21 | 22 | 23 | -------------------------------------------------------------------------------- /src/system/src/Clock/sleep.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of standard module Time 3 | */ 4 | 5 | 6 | 7 | #include 8 | 9 | /******************************************************************/ 10 | 11 | void SACsleep(int sec) 12 | { 13 | if (sec > 0) { 14 | sleep( (unsigned) sec); 15 | } 16 | } 17 | 18 | 19 | 20 | /******************************************************************/ 21 | -------------------------------------------------------------------------------- /src/structures/src/StringArray/index2offset.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #include "StringArray.h" 5 | 6 | int SAC_StringArray_index2offset( int dim, int *idx, int *shp) 7 | { 8 | int i, offset, size; 9 | 10 | offset = 0; 11 | size = 1; 12 | for( i=dim - 1; i >= 0; i--) { 13 | offset += size * idx[i]; 14 | size *= shp[i]; 15 | } 16 | 17 | return( offset); 18 | } 19 | 20 | -------------------------------------------------------------------------------- /src/system/src/Clock/difftime.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of standard module Time 3 | */ 4 | 5 | 6 | 7 | #include "Clock.h" 8 | 9 | /******************************************************************/ 10 | 11 | 12 | double SACdifftime(time_t *t1, time_t *t2) 13 | { 14 | return(difftime(*t1, *t2)); 15 | } 16 | 17 | 18 | /******************************************************************/ 19 | 20 | 21 | 22 | -------------------------------------------------------------------------------- /src/structures/src/String/copystr.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of standard module StringC 3 | */ 4 | 5 | 6 | #include "StringC.h" 7 | 8 | 9 | /*****************************************************************/ 10 | 11 | string copy_string( string s) 12 | { 13 | string new; 14 | 15 | STRDUP( new, s); 16 | 17 | return( new); 18 | } 19 | 20 | /*****************************************************************/ 21 | -------------------------------------------------------------------------------- /src/structures/src/List/List.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of SAC standard module List 3 | */ 4 | 5 | 6 | #include 7 | #include 8 | 9 | #include "sac.h" 10 | 11 | 12 | #define TRACE 0 13 | 14 | 15 | typedef struct LIST { 16 | int elem; 17 | struct LIST *rest; 18 | SAC_array_descriptor_t desc; 19 | } list; 20 | 21 | 22 | extern void SAC_List_free_list( list *elems); 23 | -------------------------------------------------------------------------------- /src/structures/src/String/strsel.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of standard module StringC 3 | */ 4 | 5 | 6 | #include "StringC.h" 7 | 8 | 9 | /*****************************************************************/ 10 | 11 | char strsel( string s, int pos) 12 | { 13 | RANGECHECK( (size_t) pos, 0, strlen( s) - 1, s); 14 | 15 | return( s[pos]); 16 | } 17 | 18 | /*****************************************************************/ 19 | -------------------------------------------------------------------------------- /src/structures/src/String/strcmp.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of standard module StringC 3 | */ 4 | 5 | 6 | #include "StringC.h" 7 | 8 | 9 | /*****************************************************************/ 10 | 11 | int SACstrcmp( string first, string second) 12 | { 13 | int res; 14 | 15 | res = strcmp( first, second); 16 | 17 | return( res); 18 | } 19 | 20 | /*****************************************************************/ 21 | -------------------------------------------------------------------------------- /src/structures/src/String/strcspn.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of standard module StringC 3 | */ 4 | 5 | 6 | #include "StringC.h" 7 | 8 | 9 | /*****************************************************************/ 10 | 11 | int SACstrcspn( string first, string second) 12 | { 13 | int res; 14 | 15 | res = strcspn( first, second); 16 | 17 | return( res); 18 | } 19 | 20 | /*****************************************************************/ 21 | -------------------------------------------------------------------------------- /src/structures/src/String/strspn.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of standard module StringC 3 | */ 4 | 5 | 6 | #include "StringC.h" 7 | 8 | 9 | /*****************************************************************/ 10 | 11 | int SACstrspn( string first, string second) 12 | { 13 | int res; 14 | 15 | res = strspn( first, second); 16 | 17 | return( res); 18 | } 19 | 20 | /*****************************************************************/ 21 | -------------------------------------------------------------------------------- /src/system/src/Clock/isdst.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of standard module Time 3 | */ 4 | 5 | 6 | 7 | #include "Clock.h" 8 | 9 | /******************************************************************/ 10 | 11 | 12 | int SACisdst(time_t *t) 13 | { 14 | struct tm *tt; 15 | 16 | tt=localtime(t); 17 | 18 | return(tt->tm_isdst); 19 | } 20 | 21 | 22 | /******************************************************************/ 23 | 24 | 25 | -------------------------------------------------------------------------------- /src/structures/src/String/strcasecmp.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of standard module StringC 3 | */ 4 | 5 | 6 | #include "StringC.h" 7 | 8 | 9 | /*****************************************************************/ 10 | 11 | int SACstrcasecmp( string first, string second) 12 | { 13 | int res; 14 | 15 | res = strcasecmp( first, second); 16 | 17 | return( res); 18 | } 19 | 20 | /*****************************************************************/ 21 | -------------------------------------------------------------------------------- /src/structures/src/String/strncmp.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of standard module StringC 3 | */ 4 | 5 | 6 | #include "StringC.h" 7 | 8 | 9 | /*****************************************************************/ 10 | 11 | int SACstrncmp( string first, string second, int n) 12 | { 13 | int res; 14 | 15 | res = strncmp( first, second, n); 16 | 17 | return( res); 18 | } 19 | 20 | /*****************************************************************/ 21 | -------------------------------------------------------------------------------- /src/structures/src/String/itos.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of standard module StringC 3 | */ 4 | 5 | 6 | #include "StringC.h" 7 | 8 | 9 | /*****************************************************************/ 10 | 11 | string SACitos( int n) 12 | { 13 | char *res; 14 | 15 | res = (char *) SAC_MALLOC( 40); 16 | 17 | sprintf( res, "%d", n); 18 | 19 | return( res); 20 | } 21 | 22 | /*****************************************************************/ 23 | -------------------------------------------------------------------------------- /src/structures/src/String/strstr.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of standard module StringC 3 | */ 4 | 5 | 6 | #include "StringC.h" 7 | 8 | 9 | /*****************************************************************/ 10 | 11 | int SACstrstr( string haystack, string needle) 12 | { 13 | string found = strstr( haystack, needle); 14 | return (found) ? (found - haystack) : -1; 15 | } 16 | 17 | /*****************************************************************/ 18 | -------------------------------------------------------------------------------- /src/structures/src/String/dtos.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of standard module StringC 3 | */ 4 | 5 | 6 | #include "StringC.h" 7 | 8 | 9 | /*****************************************************************/ 10 | 11 | string SACdtos( double n) 12 | { 13 | char *res; 14 | 15 | res = (char *) SAC_MALLOC( 60); 16 | 17 | sprintf( res, "%g", n); 18 | 19 | return( res); 20 | } 21 | 22 | /*****************************************************************/ 23 | -------------------------------------------------------------------------------- /src/structures/src/String/ftos.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of standard module StringC 3 | */ 4 | 5 | 6 | #include "StringC.h" 7 | 8 | 9 | /*****************************************************************/ 10 | 11 | string SACftos( float n) 12 | { 13 | char *res; 14 | 15 | res = (char *) SAC_MALLOC( 60); 16 | 17 | sprintf( res, "%g", n); 18 | 19 | return( res); 20 | } 21 | 22 | /*****************************************************************/ 23 | -------------------------------------------------------------------------------- /src/structures/src/List/free.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of SAC standard module List 3 | */ 4 | 5 | 6 | #include "List.h" 7 | 8 | 9 | void SAC_List_free_list( list *elems) 10 | { 11 | list *next; 12 | 13 | do { 14 | next = elems->rest; 15 | 16 | #if TRACE 17 | fprintf( stderr, "freeing (%p)\n", elems); 18 | #endif 19 | 20 | SAC_FREE( elems); 21 | elems = next; 22 | } 23 | while ((elems != NULL) && (--(DESC_RC( elems->desc)) == 0)); 24 | } 25 | -------------------------------------------------------------------------------- /src/structures/src/String/strncasecmp.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of standard module StringC 3 | */ 4 | 5 | 6 | #include "StringC.h" 7 | 8 | 9 | /*****************************************************************/ 10 | 11 | int SACstrncasecmp( string first, string second, int n) 12 | { 13 | int res; 14 | 15 | res = strncasecmp( first, second, n); 16 | 17 | return( res); 18 | } 19 | 20 | /*****************************************************************/ 21 | -------------------------------------------------------------------------------- /src/system/src/Clock/gettime.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of standard module Time 3 | */ 4 | 5 | 6 | 7 | #include "Clock.h" 8 | 9 | /******************************************************************/ 10 | 11 | 12 | time_t *SACgettime( void) 13 | { 14 | time_t *res; 15 | 16 | res=(time_t*)SAC_MALLOC(sizeof(time_t)); 17 | time(res); 18 | return(res); 19 | } 20 | 21 | 22 | /******************************************************************/ 23 | 24 | 25 | -------------------------------------------------------------------------------- /src/structures/src/List/empty.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of SAC standard module List 3 | */ 4 | 5 | 6 | #include "List.h" 7 | 8 | 9 | #define elems_nt (elems, T_OLD((SCL, (HID, (NUQ,))))) 10 | 11 | int SAC_List_empty( SAC_ND_PARAM_in( elems_nt, list *)) 12 | { 13 | int res; 14 | 15 | res = (elems->rest == NULL); 16 | 17 | if (--(DESC_RC( elems->desc)) == 0) { 18 | SAC_List_free_list( elems); 19 | } 20 | 21 | return( res); 22 | } 23 | 24 | #undef elems_nt 25 | -------------------------------------------------------------------------------- /src/structures/src/String/ctos.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of standard module StringC 3 | */ 4 | 5 | 6 | #include "StringC.h" 7 | 8 | 9 | /*****************************************************************/ 10 | 11 | string SACctos( double *n) 12 | { 13 | char *res; 14 | 15 | res = (char *) SAC_MALLOC( 120); 16 | 17 | sprintf( res, "(%g,%g)", n[0], n[1]); 18 | 19 | return( res); 20 | } 21 | 22 | /*****************************************************************/ 23 | -------------------------------------------------------------------------------- /src/system/src/Clock/copytime.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of standard module Time 3 | */ 4 | 5 | 6 | 7 | #include "Clock.h" 8 | 9 | 10 | /******************************************************************/ 11 | 12 | 13 | time_t *copy_time(time_t *t) 14 | { 15 | time_t *res; 16 | 17 | res=(time_t*)SAC_MALLOC(sizeof(time_t)); 18 | *res=*t; 19 | return(res); 20 | } 21 | 22 | 23 | /******************************************************************/ 24 | 25 | 26 | -------------------------------------------------------------------------------- /src/stdio/src/TermFile/printf.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class TermFile 3 | */ 4 | 5 | 6 | 7 | #include "TermFile.h" 8 | 9 | 10 | /*****************************************************************/ 11 | 12 | 13 | void SACprintf_TF(char *format, ...) 14 | { 15 | va_list args; 16 | 17 | va_start(args, format); 18 | vprintf(format, args); 19 | va_end(args); 20 | } 21 | 22 | 23 | /*****************************************************************/ 24 | 25 | 26 | 27 | -------------------------------------------------------------------------------- /src/stdio/src/File/fprintf.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class File 3 | */ 4 | 5 | 6 | 7 | #include "File.h" 8 | 9 | 10 | /*****************************************************************/ 11 | 12 | 13 | void SACfprintf(FILE *stream, char *format, ...) 14 | { 15 | va_list args; 16 | 17 | va_start(args, format); 18 | vfprintf( stream, format, args); 19 | va_end(args); 20 | } 21 | 22 | 23 | /*****************************************************************/ 24 | 25 | 26 | 27 | -------------------------------------------------------------------------------- /src/system/src/RuntimeError/error.c: -------------------------------------------------------------------------------- 1 | #include "sac.h" 2 | 3 | #include 4 | #include 5 | #include 6 | 7 | void SAC__RUNTIMEERROR_error( int result, const char *message, ...) 8 | { 9 | va_list arg_p; 10 | 11 | fprintf(stderr, "\n\n*** USER runtime error\n"); 12 | fprintf(stderr, "*** "); 13 | 14 | va_start(arg_p, message); 15 | vfprintf(stderr, message, arg_p); 16 | va_end(arg_p); 17 | 18 | fprintf(stderr, "\n\n"); 19 | 20 | exit(result); 21 | } 22 | -------------------------------------------------------------------------------- /src/stdio/src/BinFile/binfclose.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class BinFile 3 | */ 4 | 5 | 6 | 7 | #include "BinFile.h" 8 | 9 | 10 | 11 | /*****************************************************************/ 12 | 13 | int SACbinfclose(int fd) 14 | { 15 | int error=-1; 16 | int retVal; 17 | retVal = close(fd); 18 | if (retVal==-1) { 19 | error=errno; 20 | } 21 | 22 | return(error); 23 | } 24 | 25 | /*****************************************************************/ 26 | 27 | 28 | 29 | -------------------------------------------------------------------------------- /src/stdio/src/TermFile/fprintf.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class TermFile 3 | */ 4 | 5 | 6 | 7 | #include "TermFile.h" 8 | 9 | 10 | /*****************************************************************/ 11 | 12 | 13 | void SACfprintf_TF(FILE *stream, char *format, ...) 14 | { 15 | va_list args; 16 | 17 | va_start(args, format); 18 | vfprintf( stream, format, args); 19 | va_end(args); 20 | } 21 | 22 | 23 | /*****************************************************************/ 24 | 25 | 26 | 27 | -------------------------------------------------------------------------------- /src/stdio/src/TermFile/scanf.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class File 3 | */ 4 | 5 | 6 | 7 | #include "TermFile.h" 8 | 9 | 10 | /*****************************************************************/ 11 | 12 | 13 | int SACscanf_TF( char *format, ...) 14 | { 15 | va_list args; 16 | int ret; 17 | 18 | va_start(args, format); 19 | ret = vscanf( format, args); 20 | va_end(args); 21 | 22 | return ret; 23 | } 24 | 25 | 26 | /*****************************************************************/ 27 | 28 | 29 | 30 | -------------------------------------------------------------------------------- /src/structures/src/String/sscanf.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of standard module StringC 3 | */ 4 | 5 | 6 | #include "StringC.h" 7 | 8 | 9 | /*****************************************************************/ 10 | 11 | int SACsscanf( string s, string format, ...) 12 | { 13 | int res; 14 | va_list arg_p; 15 | 16 | va_start( arg_p, format); 17 | res = vsscanf( s, format, arg_p); 18 | va_end( arg_p); 19 | 20 | return( res); 21 | } 22 | 23 | /*****************************************************************/ 24 | -------------------------------------------------------------------------------- /src/structures/src/String/sscanfstr.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of standard module StringC 3 | */ 4 | 5 | 6 | #include "StringC.h" 7 | 8 | 9 | /*****************************************************************/ 10 | 11 | string sscanf_str( string s, string format) 12 | { 13 | string new; 14 | 15 | new = (string) SAC_MALLOC( strlen( s) + 1); 16 | 17 | new[0] = 0; 18 | 19 | sscanf( s, format, new); 20 | 21 | return( new); 22 | } 23 | 24 | /*****************************************************************/ 25 | -------------------------------------------------------------------------------- /src/structures/src/String/strchr.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of standard module StringC 3 | */ 4 | 5 | 6 | #include "StringC.h" 7 | 8 | 9 | /*****************************************************************/ 10 | 11 | int SACstrchr( string str, char c) 12 | { 13 | char *occur; 14 | 15 | occur = strchr( str, c); 16 | 17 | if (occur == NULL) { 18 | return( -1); 19 | } 20 | else { 21 | return( occur - str); 22 | } 23 | } 24 | 25 | /*****************************************************************/ 26 | -------------------------------------------------------------------------------- /src/structures/src/String/strrchr.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of standard module StringC 3 | */ 4 | 5 | 6 | #include "StringC.h" 7 | 8 | 9 | /*****************************************************************/ 10 | 11 | int SACstrrchr( string str, char c) 12 | { 13 | char *occur; 14 | 15 | occur = strrchr( str, c); 16 | 17 | if (occur == NULL) { 18 | return( -1); 19 | } 20 | else { 21 | return( occur-str); 22 | } 23 | } 24 | 25 | /*****************************************************************/ 26 | -------------------------------------------------------------------------------- /src/system/src/Dir/opendir.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of directory functions. 3 | */ 4 | 5 | 6 | 7 | #include "Dir.h" 8 | 9 | 10 | 11 | /*****************************************************************/ 12 | 13 | int SACopendir( DIR ** stream, string name) 14 | { 15 | int error = -1; 16 | 17 | *stream = opendir( name); 18 | 19 | if (*stream == NULL) 20 | { 21 | error = errno; 22 | } 23 | 24 | return( error); 25 | } 26 | 27 | 28 | /*****************************************************************/ 29 | -------------------------------------------------------------------------------- /src/system/src/FileSystem/FileSystem.h: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class FileSystem 3 | */ 4 | 5 | 6 | #include 7 | #include 8 | #include 9 | #include 10 | #include 11 | #include 12 | #include 13 | 14 | 15 | #include "sac.h" 16 | 17 | /* 18 | * Cygwin fix to ensure P_tmpdir is defined as "/tmp" 19 | * without this the stdlib build will die here. 20 | */ 21 | #ifdef __CYGWIN__ 22 | #define P_tmpdir "/tmp" 23 | #endif 24 | 25 | -------------------------------------------------------------------------------- /src/stdio/src/File/fscanf.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class File 3 | */ 4 | 5 | 6 | 7 | #include "File.h" 8 | 9 | 10 | /*****************************************************************/ 11 | 12 | 13 | int SACfscanf(FILE *stream, char *format, ...) 14 | { 15 | va_list args; 16 | int ret; 17 | 18 | va_start(args, format); 19 | ret = vfscanf( stream, format, args); 20 | va_end(args); 21 | 22 | return ret; 23 | } 24 | 25 | 26 | /*****************************************************************/ 27 | 28 | 29 | 30 | -------------------------------------------------------------------------------- /src/stdio/src/File/fopen.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class File 3 | */ 4 | 5 | 6 | 7 | #include "File.h" 8 | 9 | 10 | 11 | /*****************************************************************/ 12 | 13 | int SACfopen(FILE **stream, char *name, char *mode) 14 | { 15 | int error=-1; 16 | 17 | *stream=fopen(name, mode); 18 | 19 | if (*stream==NULL) 20 | { 21 | error=errno; 22 | } 23 | 24 | return(error); 25 | } 26 | 27 | 28 | /*****************************************************************/ 29 | 30 | 31 | 32 | -------------------------------------------------------------------------------- /src/structures/src/String/btos.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of standard module StringC 3 | */ 4 | 5 | 6 | #include "StringC.h" 7 | 8 | 9 | /*****************************************************************/ 10 | 11 | string SACbtos( bool n) 12 | { 13 | char *res; 14 | 15 | res = (char *) SAC_MALLOC( 6); 16 | 17 | if (n) { 18 | strcpy( res, "true"); 19 | } 20 | else { 21 | strcpy( res, "false"); 22 | } 23 | 24 | return( res); 25 | } 26 | 27 | /*****************************************************************/ 28 | -------------------------------------------------------------------------------- /src/system/src/Clock/ctime.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of standard module Time 3 | */ 4 | 5 | 6 | 7 | #include "Clock.h" 8 | 9 | /******************************************************************/ 10 | 11 | 12 | string SACctime(time_t *t) 13 | { 14 | string buffer, result; 15 | 16 | buffer=ctime(t); 17 | 18 | result=(string)SAC_MALLOC(strlen(buffer)+1); 19 | strcpy(result, buffer); 20 | 21 | return(result); 22 | } 23 | 24 | 25 | 26 | /******************************************************************/ 27 | 28 | 29 | -------------------------------------------------------------------------------- /src/stdio/src/TermFile/fscanf.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class File 3 | */ 4 | 5 | 6 | 7 | #include "TermFile.h" 8 | 9 | 10 | /*****************************************************************/ 11 | 12 | 13 | int SACfscanf_TF(FILE *stream, char *format, ...) 14 | { 15 | va_list args; 16 | int ret; 17 | 18 | va_start(args, format); 19 | ret = vfscanf( stream, format, args); 20 | va_end(args); 21 | 22 | return ret; 23 | } 24 | 25 | 26 | /*****************************************************************/ 27 | 28 | 29 | 30 | -------------------------------------------------------------------------------- /src/structures/src/String/strdrop.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of standard module StringC 3 | */ 4 | 5 | 6 | #include "StringC.h" 7 | 8 | 9 | /*****************************************************************/ 10 | 11 | string strdrop( string old, int n) 12 | { 13 | string new; 14 | 15 | RANGECHECK( (size_t) n, 0, strlen( old), old); 16 | 17 | new = (string) SAC_MALLOC( strlen( old) - n + 1); 18 | strcpy( new, old + n); 19 | 20 | return( new); 21 | } 22 | 23 | /*****************************************************************/ 24 | -------------------------------------------------------------------------------- /src/structures/src/List/length.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of SAC standard module List 3 | */ 4 | 5 | 6 | #include "List.h" 7 | 8 | 9 | #define elems_nt (elems, T_OLD((SCL, (HID, (NUQ,))))) 10 | 11 | int SAC_List_length( SAC_ND_PARAM_in( elems_nt, list *)) 12 | { 13 | list *ptr = elems; 14 | int res = 0; 15 | 16 | while (ptr->rest != NULL) { 17 | ptr = ptr->rest; 18 | res++; 19 | } 20 | if (--(DESC_RC( elems->desc)) == 0) { 21 | SAC_List_free_list( elems); 22 | } 23 | 24 | return( res); 25 | } 26 | 27 | #undef elems_nt 28 | -------------------------------------------------------------------------------- /src/structures/src/String/strncat.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of standard module StringC 3 | */ 4 | 5 | 6 | #include "StringC.h" 7 | 8 | 9 | /*****************************************************************/ 10 | 11 | string SACstrncat( string first, string second, int n) 12 | { 13 | string new; 14 | 15 | new = (string) SAC_MALLOC( strlen( first) + n + 1); 16 | 17 | strcpy( new, first); 18 | strncat( new, second, n); 19 | 20 | return( new); 21 | } 22 | 23 | /*****************************************************************/ 24 | -------------------------------------------------------------------------------- /src/system/src/FileSystem/pltmp.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class FileSystem 3 | */ 4 | 5 | 6 | 7 | #include "FileSystem.h" 8 | 9 | /*****************************************************************/ 10 | 11 | char *SACPtmpdir( void) 12 | { 13 | char *result; 14 | 15 | const char tmp[] = "/tmp"; 16 | const size_t l = strlen(tmp); 17 | 18 | result=(char *)SAC_MALLOC(l + 1); // null byte 19 | strcpy(result, tmp); 20 | 21 | return(result); 22 | } 23 | 24 | 25 | /*****************************************************************/ 26 | -------------------------------------------------------------------------------- /src/system/src/Process/process.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of process functions. 3 | */ 4 | 5 | 6 | 7 | #include "Process.h" 8 | 9 | 10 | 11 | /*****************************************************************/ 12 | 13 | int SACpopen(FILE ** stream, char *command, char *mode) 14 | { 15 | int error = -1; 16 | 17 | *stream = popen( command, mode); 18 | 19 | if (*stream == NULL) 20 | { 21 | error = errno; 22 | } 23 | 24 | return (error); 25 | } 26 | 27 | 28 | /*****************************************************************/ 29 | -------------------------------------------------------------------------------- /src/stdio/src/BinFile/binfopen.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class BinFile 3 | */ 4 | 5 | 6 | 7 | #include "BinFile.h" 8 | 9 | 10 | 11 | /*****************************************************************/ 12 | 13 | int SACbinfopen(int *fd, char *name, int flags) 14 | { 15 | int error=-1; 16 | 17 | *fd = open(name, flags, S_IRUSR | S_IWUSR); 18 | 19 | if (*fd==-1) 20 | { 21 | error=errno; 22 | } 23 | 24 | return(error); 25 | } 26 | 27 | 28 | /*****************************************************************/ 29 | 30 | 31 | 32 | -------------------------------------------------------------------------------- /src/structures/src/List/hd.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of SAC standard module List 3 | */ 4 | 5 | 6 | #include "List.h" 7 | 8 | 9 | #define elems_nt (elems, T_OLD((SCL, (HID, (NUQ,))))) 10 | 11 | int SAC_List_hd( SAC_ND_PARAM_in( elems_nt, list *)) 12 | { 13 | int res; 14 | 15 | if (elems->rest == NULL) { 16 | SAC_RuntimeError( "hd applied to NIL\n"); 17 | } 18 | res = elems->elem; 19 | 20 | if (--(DESC_RC( elems->desc)) == 0) { 21 | SAC_List_free_list( elems); 22 | } 23 | 24 | return( res); 25 | } 26 | 27 | #undef elems_nt 28 | -------------------------------------------------------------------------------- /src/system/src/SysErr/failsucc.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of external standard module SysErr 3 | */ 4 | 5 | 6 | #include 7 | #include 8 | 9 | 10 | 11 | /*****************************************************************/ 12 | 13 | int clear(int err) 14 | { 15 | return(err==-1); 16 | } 17 | 18 | /*****************************************************************/ 19 | 20 | int fail(int err) 21 | { 22 | return(err!=-1); 23 | } 24 | 25 | /*****************************************************************/ 26 | 27 | 28 | 29 | 30 | -------------------------------------------------------------------------------- /src/stdio/src/TermFile/stdstreams.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of standard class TermFile 3 | */ 4 | 5 | 6 | 7 | #include "TermFile.h" 8 | 9 | 10 | 11 | /*****************************************************************/ 12 | 13 | void *SAC_create_stdin( void) 14 | { 15 | return(stdin); 16 | } 17 | 18 | 19 | void *SAC_create_stdout( void) 20 | { 21 | return(stdout); 22 | } 23 | 24 | 25 | void *SAC_create_stderr( void) 26 | { 27 | return(stderr); 28 | } 29 | 30 | 31 | /*****************************************************************/ 32 | 33 | 34 | -------------------------------------------------------------------------------- /src/structures/src/StringArray/alloc.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #include "StringArray.h" 5 | 6 | array *SAC_StringArray_alloc( int dim, int size) 7 | { 8 | array *res; 9 | 10 | res = (array *)malloc( sizeof( array)); 11 | res->dim = dim; 12 | res->size = size; 13 | res->shp = (int*)malloc( res->dim * sizeof( int)); 14 | res->data = (char**) malloc( res->size * sizeof( char *)); 15 | res->descs = (SAC_array_descriptor_t*) 16 | malloc( res->size * sizeof( SAC_array_descriptor_t *)); 17 | 18 | return( res); 19 | } 20 | 21 | -------------------------------------------------------------------------------- /src/system/src/FileSystem/remove.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class FileSystem 3 | */ 4 | 5 | 6 | 7 | #include "FileSystem.h" 8 | 9 | 10 | 11 | /*****************************************************************/ 12 | 13 | 14 | int SACremove(char *name) 15 | { 16 | int success; 17 | 18 | success=remove(name); 19 | 20 | if (success==-1) 21 | { 22 | success=errno; 23 | } 24 | else 25 | { 26 | success=-1; 27 | } 28 | 29 | return(success); 30 | } 31 | 32 | 33 | /*****************************************************************/ 34 | 35 | 36 | 37 | -------------------------------------------------------------------------------- /src/structures/Structures.sac: -------------------------------------------------------------------------------- 1 | #pragma safe 2 | 3 | module Structures; 4 | 5 | import Array: all; 6 | import Char: all; 7 | import String: all; 8 | 9 | #ifdef EXT_STDLIB 10 | import Color8: all; 11 | import Complex: all; 12 | import List: all; 13 | import Quaternion: all; 14 | /* Importing both currently causes a name clash, because the same C function 15 | * name is being generated for both the double and float variants. 16 | * Until this has been fixed, we must exclude them from this module. */ 17 | //import Vector3d: all; 18 | //import Vector3f: all; 19 | #endif 20 | 21 | export all; 22 | -------------------------------------------------------------------------------- /src/system/src/Environment/GetEnv.c: -------------------------------------------------------------------------------- 1 | #include "Env.h" 2 | 3 | /******************************************************************/ 4 | 5 | 6 | char *GetEnv(char *envvar) 7 | { 8 | char *buffer, *result; 9 | 10 | buffer=getenv(envvar); 11 | 12 | if (buffer==NULL) 13 | { 14 | result=(char*)SAC_MALLOC(1); 15 | result[0]=0; 16 | } 17 | else 18 | { 19 | result=(char*)SAC_MALLOC(strlen(buffer)+1); 20 | strcpy(result, buffer); 21 | } 22 | 23 | return(result); 24 | } 25 | 26 | 27 | /******************************************************************/ 28 | 29 | 30 | -------------------------------------------------------------------------------- /src/stdio/src/File/fscanl.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class File 3 | */ 4 | 5 | 6 | 7 | #include "File.h" 8 | 9 | 10 | 11 | /*****************************************************************/ 12 | 13 | char* fscanl(FILE *stream, int length) 14 | { 15 | char *input, *success; 16 | 17 | input=(char*)SAC_MALLOC(length+3); 18 | 19 | success=fgets(input, length+1, stream); 20 | 21 | if (success==NULL) 22 | { 23 | input[0]=0; 24 | } 25 | 26 | return(input); 27 | } 28 | 29 | 30 | /*****************************************************************/ 31 | 32 | 33 | -------------------------------------------------------------------------------- /src/system/src/FileSystem/rename.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class FileSystem 3 | */ 4 | 5 | 6 | 7 | #include "FileSystem.h" 8 | 9 | 10 | 11 | /*****************************************************************/ 12 | 13 | int SACrename(char *old, char *new) 14 | { 15 | int success; 16 | 17 | success=rename(old, new); 18 | 19 | if (success==-1) 20 | { 21 | success=errno; 22 | } 23 | else 24 | { 25 | success=-1; 26 | } 27 | 28 | return(success); 29 | } 30 | 31 | 32 | /*****************************************************************/ 33 | 34 | 35 | 36 | -------------------------------------------------------------------------------- /src/structures/src/StringArray/dim.c: -------------------------------------------------------------------------------- 1 | #include "StringArray.h" 2 | 3 | #define s_nt (s, T_OLD((SCL, (HID, (NUQ,))))) 4 | #define dim_nt (dim, T_OLD((SCL, (NHD, (NUQ,))))) 5 | #define res_nt (res, T_OLD((SCL, (NHD, (NUQ,))))) 6 | 7 | void SAC_StringArray_dim( SAC_ND_PARAM_out( dim_nt, int), 8 | SAC_ND_PARAM_in( s_nt, array *)) 9 | { 10 | SAC_ND_DECL__DESC( res_nt, ); 11 | SAC_ND_DECL__DATA( res_nt, int,); 12 | 13 | SAC_ND_ALLOC__DESC( res_nt, 0); 14 | SAC_ND_CREATE__SCALAR__DATA( res_nt, s->dim); 15 | 16 | SAC_ND_RET_out( dim_nt , res_nt ) 17 | } 18 | 19 | -------------------------------------------------------------------------------- /src/stdio/src/TermFile/fscanl.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class TermFile 3 | */ 4 | 5 | 6 | 7 | #include "TermFile.h" 8 | 9 | 10 | 11 | /*****************************************************************/ 12 | 13 | char* term_fscanl(FILE *stream, int length) 14 | { 15 | char *input, *success; 16 | 17 | input=(char*)SAC_MALLOC(length+3); 18 | 19 | success=fgets(input, length+1, stream); 20 | 21 | if (success==NULL) 22 | { 23 | input[0]=0; 24 | } 25 | 26 | return(input); 27 | } 28 | 29 | 30 | /*****************************************************************/ 31 | 32 | 33 | -------------------------------------------------------------------------------- /src/structures/src/StringArray/free.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #include "StringArray.h" 5 | 6 | #define subs_nt (subs, T_OLD((SCL, (HID, (NUQ,))))) 7 | 8 | void SAC_StringArray_free( array *arr) 9 | { 10 | int i; 11 | SAC_ND_DECL__DESC( subs_nt, ); 12 | char * SAC_ND_A_FIELD( subs_nt); 13 | 14 | for( i=0; isize; i++) { 15 | SAC_ND_A_DESC( subs_nt) = arr->descs[i]; 16 | SAC_ND_A_FIELD( subs_nt) = arr->data[i]; 17 | SAC_ND_DEC_RC_FREE( subs_nt, 1 , free ); 18 | } 19 | free( arr->shp); 20 | free( arr->data); 21 | free( arr->descs); 22 | free( arr); 23 | } 24 | 25 | -------------------------------------------------------------------------------- /src/structures/src/String/strcat.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of standard module StringC 3 | */ 4 | 5 | 6 | #include "StringC.h" 7 | 8 | 9 | /*****************************************************************/ 10 | 11 | string SACstrcat( string first, string second) 12 | { 13 | size_t len1; 14 | size_t len2; 15 | string new; 16 | 17 | len1 = strlen( first); 18 | len2 = strlen( second); 19 | new = (string) SAC_MALLOC( len1 + len2 + 1); 20 | 21 | strcpy( new, first); 22 | strcpy( new + len1, second); 23 | 24 | return( new); 25 | } 26 | 27 | /*****************************************************************/ 28 | -------------------------------------------------------------------------------- /src/structures/src/String/strins.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of standard module StringC 3 | */ 4 | 5 | 6 | #include "StringC.h" 7 | 8 | 9 | /*****************************************************************/ 10 | 11 | string strins( string old, int pos, string insert) 12 | { 13 | string new; 14 | 15 | RANGECHECK( (size_t) pos, 0, strlen( old), old); 16 | 17 | new = (string) SAC_MALLOC( strlen( old) + strlen( insert) + 1); 18 | 19 | strncpy( new, old, pos); 20 | new[pos] = 0; 21 | 22 | strcat( new, insert); 23 | strcat( new, old + pos); 24 | 25 | return( new); 26 | } 27 | 28 | /*****************************************************************/ 29 | -------------------------------------------------------------------------------- /src/stdio/src/File/fscans.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class File 3 | */ 4 | 5 | 6 | 7 | #include "File.h" 8 | 9 | 10 | 11 | /*****************************************************************/ 12 | 13 | char* fscans(FILE* stream, int length) 14 | { 15 | int success; 16 | char *input; 17 | char format[32]; 18 | 19 | input = (char *) SAC_MALLOC(length + 1); 20 | snprintf(format, sizeof format, " %%%ds", length); 21 | 22 | success = fscanf(stream, format, input); 23 | 24 | if (success != 1) 25 | { 26 | input[0] = 0; 27 | } 28 | 29 | return (input); 30 | } 31 | 32 | 33 | /*****************************************************************/ 34 | -------------------------------------------------------------------------------- /src/system/src/FileSystem/symlink.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class FileSystem 3 | */ 4 | 5 | 6 | 7 | #include "FileSystem.h" 8 | 9 | 10 | extern int symlink(const char *old, const char *new); 11 | 12 | 13 | 14 | /*****************************************************************/ 15 | 16 | 17 | int SACsymlink(char *name, char *link) 18 | { 19 | int success; 20 | 21 | success=symlink(name, link); 22 | 23 | if (success==-1) 24 | { 25 | success=errno; 26 | } 27 | else 28 | { 29 | success=-1; 30 | } 31 | 32 | return(success); 33 | } 34 | 35 | 36 | /*****************************************************************/ 37 | 38 | 39 | -------------------------------------------------------------------------------- /src/structures/src/Constants/mindouble.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | /* !! This function does not return DBL_MIN !! 4 | * The reason for this is that DBL_MIN is the smallest 5 | * normalised value that can represented. For consistency 6 | * with maxint() and minint(), this function returns the 7 | * lowest negative number that can be represented, which 8 | * is the exact opposite of DBL_MAX: -DBL_MAX. 9 | * 10 | * To get DBL_MIN, look at tinydouble() 11 | * 12 | * More information can be found at: 13 | * http://forums.codeguru.com/showthread.php?260921-DBL_MIN-and-DBL_MAX&p=799431#post799431 14 | */ 15 | double mindouble( void) 16 | { 17 | return( -DBL_MAX); 18 | } 19 | -------------------------------------------------------------------------------- /src/stdio/src/BinFile/binfflags.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class BinFile 3 | */ 4 | 5 | 6 | 7 | #include "BinFile.h" 8 | 9 | 10 | 11 | /*****************************************************************/ 12 | 13 | int SACbinf_O_RDONLY( void) 14 | { 15 | return(O_RDONLY); 16 | } 17 | 18 | int SACbinf_O_WRONLY( void) 19 | { 20 | return(O_WRONLY); 21 | } 22 | 23 | int SACbinf_O_RDWR( void) 24 | { 25 | return(O_RDWR); 26 | } 27 | 28 | int SACbinf_O_CREAT( void) 29 | { 30 | return(O_CREAT); 31 | } 32 | 33 | int SACbinf_O_TRUNC( void) 34 | { 35 | return(O_TRUNC); 36 | } 37 | 38 | 39 | /*****************************************************************/ 40 | 41 | 42 | 43 | -------------------------------------------------------------------------------- /src/stdio/src/TermFile/fscans.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class TermFile 3 | */ 4 | 5 | 6 | 7 | #include "TermFile.h" 8 | 9 | 10 | 11 | /*****************************************************************/ 12 | 13 | char* term_fscans(FILE *stream, int length) 14 | { 15 | int success; 16 | char *input; 17 | char format[32]; 18 | 19 | input = (char *) SAC_MALLOC(length + 1); 20 | snprintf(format, sizeof format, " %%%ds", length); 21 | 22 | success = fscanf(stream, format, input); 23 | 24 | if (success != 1) 25 | { 26 | input[0] = 0; 27 | } 28 | 29 | return (input); 30 | } 31 | 32 | 33 | /*****************************************************************/ 34 | -------------------------------------------------------------------------------- /src/system/src/Clock/strftime.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of standard module Time 3 | */ 4 | 5 | 6 | 7 | #include "Clock.h" 8 | 9 | /******************************************************************/ 10 | 11 | string SACstrftime(int len, string format, time_t* t) 12 | { 13 | string result; 14 | struct tm *tt; 15 | 16 | result = (string) SAC_MALLOC(len + 1); 17 | result[0] = '\0'; 18 | 19 | tt = localtime(t); 20 | if (tt != NULL) { 21 | if (strftime(result, len, format, tt) == 0) { 22 | result[0] = '\0'; 23 | } 24 | } 25 | 26 | return (result); 27 | } 28 | 29 | 30 | 31 | /******************************************************************/ 32 | -------------------------------------------------------------------------------- /src/structures/src/List/nil.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of SAC standard module List 3 | */ 4 | 5 | 6 | #include "List.h" 7 | 8 | 9 | #define res_nt (res, T_OLD((SCL, (HID, (NUQ,))))) 10 | 11 | void SAC_List_nil( SAC_ND_PARAM_out( res_nt, list *)) 12 | { 13 | SAC_ND_DECL__DESC( res_nt, ) 14 | SAC_ND_DECL__DATA( res_nt, list *, ) 15 | 16 | res = (list *) SAC_MALLOC( sizeof( list)); 17 | res->rest = NULL; 18 | SAC_ND_ALLOC__DESC( res_nt, 0) 19 | SAC_ND_SET__RC( res_nt, 1) 20 | res->desc = SAC_ND_A_DESC( res_nt); 21 | 22 | #if TRACE 23 | fprintf( stderr, "creating NIL at (%p)\n", res); 24 | #endif 25 | 26 | SAC_ND_RET_out( res_nt, res_nt) 27 | } 28 | 29 | #undef res_nt 30 | -------------------------------------------------------------------------------- /src/structures/src/StringArray/StringArray.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of SAC standard module StringArray 3 | */ 4 | 5 | 6 | #include 7 | #include 8 | 9 | #include "sac.h" 10 | 11 | 12 | #define TRACE 0 13 | 14 | typedef struct ARRAY { 15 | int dim; 16 | int size; 17 | int *shp; 18 | char **data; 19 | SAC_array_descriptor_t *descs; 20 | } array; 21 | 22 | extern array *SAC_StringArray_alloc( int dim, int size); 23 | extern int SAC_StringArray_index2offset( int dim, int *idx, int *shp); 24 | 25 | extern void SAC_StringArray_free( array *arr); 26 | extern array *SAC_StringArray_copy( array *arr); 27 | 28 | -------------------------------------------------------------------------------- /src/system/src/Environment/SetEnv.c: -------------------------------------------------------------------------------- 1 | #include "Env.h" 2 | 3 | /******************************************************************/ 4 | 5 | 6 | int SetEnv(char *envvar, char *value, int overwrite) 7 | { 8 | int res = 0; 9 | 10 | if (overwrite || (getenv(envvar) == NULL)) 11 | { 12 | #if HAVE_SETENV 13 | res = setenv(envvar, value, overwrite); 14 | #else 15 | size_t size = strlen(envvar) + 1 + strlen(value) + 1; 16 | char* buf = (char*) SAC_MALLOC(size); 17 | strcpy(buf, envvar); 18 | strcat(buf, "="); 19 | strcat(buf, value); 20 | putenv(buf); 21 | #endif 22 | } 23 | 24 | return (res); 25 | } 26 | 27 | 28 | /******************************************************************/ 29 | -------------------------------------------------------------------------------- /src/structures/src/String/strtod.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of standard module StringC 3 | */ 4 | 5 | 6 | #include "StringC.h" 7 | 8 | 9 | /*****************************************************************/ 10 | 11 | double SACstrtod( string *remain, string input) 12 | { 13 | double res; 14 | char *rem; 15 | 16 | res = strtod( input, &rem); 17 | 18 | *remain = (string) SAC_MALLOC( strlen( rem) + 1); 19 | strcpy( *remain, rem); 20 | 21 | return( res); 22 | } 23 | 24 | /*****************************************************************/ 25 | 26 | double SACtod( string input) 27 | { 28 | return( strtod( input, NULL)); 29 | } 30 | 31 | /*****************************************************************/ 32 | -------------------------------------------------------------------------------- /src/system/src/SysErr/strerror.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of external standard module SysErr 3 | */ 4 | 5 | 6 | #include 7 | #include 8 | 9 | #include "sac.h" 10 | 11 | 12 | /*****************************************************************/ 13 | 14 | extern char *strerror(int num); 15 | 16 | 17 | /*****************************************************************/ 18 | 19 | 20 | char *SACstrerror(int num) 21 | { 22 | char *buffer, *result; 23 | 24 | buffer=strerror(num); 25 | 26 | result=(char *)SAC_MALLOC(strlen(buffer)+1); 27 | strcpy(result, buffer); 28 | 29 | return(result); 30 | } 31 | 32 | /*****************************************************************/ 33 | 34 | 35 | -------------------------------------------------------------------------------- /src/structures/src/String/strtof.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of standard module StringC 3 | */ 4 | 5 | 6 | #include "StringC.h" 7 | 8 | 9 | /*****************************************************************/ 10 | 11 | float SACstrtof( string *remain, string input) 12 | { 13 | float res; 14 | char *rem; 15 | 16 | res = (float) strtod( input, &rem); 17 | 18 | *remain = (string) SAC_MALLOC( strlen( rem) + 1); 19 | strcpy( *remain, rem); 20 | 21 | return( res); 22 | } 23 | 24 | /*****************************************************************/ 25 | 26 | float SACtof( string input) 27 | { 28 | return( (float) strtod( input, NULL)); 29 | } 30 | 31 | /*****************************************************************/ 32 | -------------------------------------------------------------------------------- /src/structures/src/String/strtoi.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of standard module StringC 3 | */ 4 | 5 | 6 | #include "StringC.h" 7 | 8 | 9 | /*****************************************************************/ 10 | 11 | int SACstrtoi( string *remain, string input, int base) 12 | { 13 | int res; 14 | char *rem; 15 | 16 | res = (int) strtol( input, &rem, base); 17 | 18 | *remain = (string) SAC_MALLOC( strlen( rem) + 1); 19 | strcpy( *remain, rem); 20 | 21 | return( res); 22 | } 23 | 24 | /*****************************************************************/ 25 | 26 | int SACtoi( string input) 27 | { 28 | return( (int) strtol( input, NULL, 0)); 29 | } 30 | 31 | /*****************************************************************/ 32 | -------------------------------------------------------------------------------- /src/system/RTClock.sac: -------------------------------------------------------------------------------- 1 | #pragma safe 2 | class RTClock; 3 | 4 | external classtype; 5 | 6 | export { TheRTClock, touch, gettime }; 7 | 8 | objdef RTClock TheRTClock = createTheRTClock(); 9 | 10 | external RTClock createTheRTClock(); 11 | #pragma effect World::TheWorld 12 | #pragma linkobj "src/RTClock/rtclock.o" 13 | #pragma linkname "SAC_RTClock_createTheRTClock" 14 | #pragma linksign [1] 15 | 16 | external void touch(RTClock &rtclock); 17 | #pragma linkobj "src/RTClock/rtclock.o" 18 | #pragma linkname "SAC_RTClock_touch" 19 | 20 | external long, long gettime(); 21 | #pragma effect RTClock::TheRTClock 22 | #pragma linkobj "src/RTClock/rtclock.o" 23 | #pragma linkname "SAC_RTClock_gettime" 24 | #pragma linksign [1,2] 25 | -------------------------------------------------------------------------------- /src/system/src/Clock/isleap.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of standard module Time 3 | */ 4 | 5 | 6 | 7 | #include "Clock.h" 8 | 9 | /******************************************************************/ 10 | 11 | 12 | int SACisleap(int year) 13 | { 14 | return((year) % 4 == 0 && ((year) % 100 != 0 || (year) % 400 == 0)); 15 | } 16 | 17 | 18 | 19 | /******************************************************************/ 20 | 21 | 22 | int SACisleapt(time_t *t) 23 | { 24 | struct tm *tt; 25 | int year; 26 | 27 | tt=localtime(t); 28 | year=tt->tm_year + 1900; 29 | 30 | return((year) % 4 == 0 && ((year) % 100 != 0 || (year) % 400 == 0)); 31 | } 32 | 33 | 34 | 35 | /******************************************************************/ 36 | 37 | 38 | -------------------------------------------------------------------------------- /src/structures/src/Constants/minmax.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | #define UCHAR_MIN 0 4 | #define USHRT_MIN 0 5 | #define UINT_MIN 0 6 | #define ULONG_MIN 0 7 | #define ULLONG_MIN 0 8 | 9 | #define minmax(rtype, SACtype, typeucase) \ 10 | rtype max##SACtype( void ) \ 11 | { \ 12 | return( typeucase##_MAX); \ 13 | } \ 14 | \ 15 | rtype min##SACtype( void ) \ 16 | { \ 17 | return( typeucase##_MIN); \ 18 | } 19 | 20 | minmax(char, byte, CHAR) 21 | minmax(short, short, SHRT) 22 | minmax(long, long, LONG) 23 | minmax(long long, longlong, LLONG) 24 | minmax(unsigned char, ubyte, UCHAR) 25 | minmax(unsigned short, ushort, USHRT) 26 | minmax(unsigned int, uint, UINT) 27 | minmax(unsigned long, ulong, ULONG) 28 | minmax(unsigned long long, ulonglong, ULLONG) 29 | -------------------------------------------------------------------------------- /src/structures/src/List/nth.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of SAC standard module List 3 | */ 4 | 5 | 6 | #include "List.h" 7 | 8 | 9 | #define elems_nt (elems, T_OLD((SCL, (HID, (NUQ,))))) 10 | 11 | int SAC_List_nth( int n, SAC_ND_PARAM_in( elems_nt, list *)) 12 | { 13 | list *ptr; 14 | int res; 15 | 16 | if (n < 0) { 17 | SAC_RuntimeError( "negative first arg of nth\n"); 18 | } 19 | 20 | ptr = elems; 21 | while (n > 0) { 22 | ptr = ptr->rest; 23 | if (ptr->rest == NULL) { 24 | SAC_RuntimeError( "first arg of nth %d larger than length of list\n", n); 25 | } 26 | n--; 27 | } 28 | res = ptr->elem; 29 | 30 | if (--(DESC_RC( elems->desc)) == 0) { 31 | SAC_List_free_list( elems); 32 | } 33 | 34 | return( res); 35 | } 36 | 37 | #undef elems_nt 38 | -------------------------------------------------------------------------------- /src/structures/src/StringArray/copy.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #include "StringArray.h" 5 | 6 | #define subs_nt (subs, T_OLD((SCL, (HID, (NUQ,))))) 7 | 8 | array *SAC_StringArray_copy( array *arr) 9 | { 10 | int i; 11 | array *res; 12 | SAC_ND_DECL__DESC( subs_nt, ); 13 | char * SAC_ND_A_FIELD( subs_nt); 14 | 15 | res = SAC_StringArray_alloc( arr->dim, arr->size); 16 | for( i=0; idim; i++) { 17 | res->shp[i] = arr->shp[i]; 18 | } 19 | for( i=0; isize; i++) { 20 | SAC_ND_A_DESC( subs_nt) = arr->descs[i]; 21 | SAC_ND_A_FIELD( subs_nt) = arr->data[i]; 22 | SAC_ND_INC_RC( subs_nt, 1 ); 23 | res->descs[i] = SAC_ND_A_DESC( subs_nt); 24 | res->data[i] = SAC_ND_A_FIELD( subs_nt); 25 | } 26 | return( res); 27 | } 28 | 29 | -------------------------------------------------------------------------------- /src/stdio/src/BinFile/binfWriteDblArr.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of module BinFile 3 | */ 4 | 5 | 6 | #include "BinFile.h" 7 | 8 | #define array_nt (array, (AUD, (NHD, (NUQ, )))) 9 | #define ret_nt (ret, (AUD, (NHD, (NUQ, )))) 10 | 11 | void SACbinfWriteDoubleArray(int fd, int dim, int *shp, double* array) 12 | { 13 | int i; 14 | size_t size; 15 | ssize_t res; // the return value of write can be negative! 16 | for( i = 0, size = 1; i < dim; i++) { 17 | size *= shp[i]; 18 | } 19 | 20 | res = write(fd,array,size*sizeof(double)); 21 | if( res != (ssize_t) (size*sizeof(double))) { 22 | SAC_RuntimeWarning( "only managed to write %d bytes of a %d byte array of doubles", 23 | res, size*sizeof(double)); 24 | } 25 | } 26 | 27 | #undef array_nt 28 | #undef ret_nt 29 | -------------------------------------------------------------------------------- /src/structures/ArrayBasics.xsac: -------------------------------------------------------------------------------- 1 | #pragma safe 2 | 3 | module ArrayBasics; 4 | 5 | export all; 6 | 7 | #include "arraybasics.mac" 8 | #include "builtin.mac" 9 | 10 | BUILT_IN(DIM) 11 | BUILT_IN(SHAPE) 12 | BUILT_IN(SEL) 13 | BUILT_IN(RESHAPE) 14 | BUILT_IN(GENARRAY) 15 | BUILT_IN(MODARRAY) 16 | 17 | /****************************************************************************** 18 | * 19 | * @fn int[d:shp,d] iota(int[d] shp) 20 | * 21 | * @brief Creates an array of the given shape with values ranging from 0 to d. 22 | * 23 | ******************************************************************************/ 24 | 25 | inline 26 | int[d:shp,d] iota(int[d] shp) 27 | { 28 | return { iv -> iv | iv < shp }; 29 | } 30 | 31 | inline 32 | int[d] iota(int d) 33 | { 34 | return { [i] -> i | [i] < [d] }; 35 | } 36 | -------------------------------------------------------------------------------- /src/system/src/Clock/date.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of standard module Time 3 | */ 4 | 5 | 6 | 7 | #include "Clock.h" 8 | 9 | /******************************************************************/ 10 | 11 | 12 | int SACdate(int *mon, int *day, time_t *t) 13 | { 14 | struct tm *tt; 15 | 16 | tt=localtime(t); 17 | 18 | *mon=tt->tm_mon; 19 | *day=tt->tm_mday; 20 | 21 | return(tt->tm_year); 22 | } 23 | 24 | 25 | 26 | /******************************************************************/ 27 | 28 | 29 | int SACclock(int *min, int *sec, time_t *t) 30 | { 31 | struct tm *tt; 32 | 33 | tt=localtime(t); 34 | 35 | *sec=tt->tm_sec; 36 | *min=tt->tm_min; 37 | 38 | return(tt->tm_hour); 39 | } 40 | 41 | 42 | 43 | /******************************************************************/ 44 | -------------------------------------------------------------------------------- /src/system/src/Clock/mktime.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of standard module Time 3 | */ 4 | 5 | 6 | 7 | #include "Clock.h" 8 | 9 | /******************************************************************/ 10 | 11 | 12 | time_t *SACmktime(int *success, int year, int mon, int day, 13 | int hour, int min, int sec) 14 | { 15 | struct tm t; 16 | time_t *res; 17 | 18 | t.tm_year=year; 19 | t.tm_mon=mon; 20 | t.tm_mday=day; 21 | t.tm_hour=hour; 22 | t.tm_min=min; 23 | t.tm_sec=sec; 24 | 25 | res=(time_t*)SAC_MALLOC(sizeof(time_t)); 26 | 27 | *res=mktime(&t); 28 | 29 | if (*res<(time_t)0) 30 | { 31 | *success=0; 32 | } 33 | else 34 | { 35 | *success=1; 36 | } 37 | 38 | return(res); 39 | } 40 | 41 | 42 | /******************************************************************/ 43 | 44 | 45 | -------------------------------------------------------------------------------- /cmake/config.cmake: -------------------------------------------------------------------------------- 1 | INCLUDE (CheckFunctionExists) 2 | INCLUDE (CheckCSourceCompiles) 3 | INCLUDE (CheckLibraryExists) 4 | INCLUDE (CheckIncludeFiles) 5 | INCLUDE ("cmake/options.cmake") 6 | 7 | # Check for flex/bison 8 | FIND_PACKAGE (BISON REQUIRED) 9 | FIND_PACKAGE (FLEX REQUIRED) 10 | 11 | MESSAGE (" 12 | * Stdlib configuration done. 13 | * 14 | * sac2c executable: ${SAC2C_EXEC} 15 | * local builddir: ${DLL_BUILD_DIR} 16 | * targets: ${TARGETS} 17 | * sac2c CPP flags: ${SAC2C_CPP_INC} 18 | * sac2c extra flags: ${SAC2C_EXTRA_INC} 19 | * 20 | * Configuration state: 21 | * - full types: ${FULLTYPES} 22 | * - build generic ${BUILDGENERIC} 23 | * - build extended: ${BUILD_EXT} 24 | * 25 | * Packaging state: 26 | * - is release: ${IS_RELEASE} 27 | ") 28 | -------------------------------------------------------------------------------- /src/system/src/Environment/Environ.c: -------------------------------------------------------------------------------- 1 | #include "Env.h" 2 | 3 | /******************************************************************/ 4 | /* functions to query the global variable "environ". */ 5 | 6 | extern char **environ; 7 | 8 | int EnvCount( void) 9 | { 10 | int i = 0; 11 | 12 | if (environ) { 13 | while (environ[i]) { 14 | ++i; 15 | } 16 | } 17 | 18 | return i; 19 | } 20 | 21 | char* IndexEnv( int i) 22 | { 23 | char* res; 24 | int k = 0; 25 | 26 | if (environ) { 27 | while (k < i && environ[k]) { 28 | ++k; 29 | } 30 | } 31 | if (i != k || !environ || environ[k] == NULL) { 32 | res = (char*) SAC_MALLOC(1); 33 | *res = '\0'; 34 | } else { 35 | res = (char*) SAC_MALLOC(strlen(environ[k]) + 1); 36 | strcpy(res, environ[k]); 37 | } 38 | 39 | return res; 40 | } 41 | -------------------------------------------------------------------------------- /CONTRIBUTORS.md: -------------------------------------------------------------------------------- 1 | CONTRIBUTORS: 2 | 3 | The following people contributed their time and mind to develop the 4 | SAC standard library (roughly in order of entering the project): 5 | 6 | Sven-Bodo Scholz 7 | Clemens Grelck 8 | Raphael 'kena' Poss 9 | Robert Bernecky 10 | Aaron Vodney 11 | Kai Trojahner 12 | Abhishek Lal 13 | Aram Visser 14 | Jing Guo 15 | Florian Büther 16 | Frank Penczek 17 | Artem Shinkarov 18 | Bep Rinto 19 | Carl Joslin 20 | Daniel Rolls 21 | Dietmar Kreye 22 | Hans-Nikolai Viessmann 23 | Jan-Friso Evers 24 | Vu Thien Nga Nguyen 25 | Markus Weigel 26 | Martin Hawes 27 | Miguel Sousa Diogo 28 | Nico Marcussen-Wulff 29 | Nilesh Karavadara 30 | Philip Holzenspies 31 | Roeland Douma 32 | Santanu Kumar Dash 33 | Sonia Chouaieb 34 | Stephan Herhut 35 | Sören Schwartz 36 | Theo van Klaveren 37 | Jordy Aaldering 38 | Thomas Koopman 39 | -------------------------------------------------------------------------------- /src/structures/src/List/tl.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of SAC standard module List 3 | */ 4 | 5 | 6 | #include "List.h" 7 | 8 | 9 | #define res_nt (res, T_OLD((SCL, (HID, (NUQ,))))) 10 | #define elems_nt (elems, T_OLD((SCL, (HID, (NUQ,))))) 11 | 12 | void SAC_List_tl( SAC_ND_PARAM_out( res_nt, list *), 13 | SAC_ND_PARAM_in( elems_nt, list *)) 14 | { 15 | SAC_ND_DECL__DESC( res_nt, ) 16 | SAC_ND_DECL__DATA( res_nt, list *, ) 17 | 18 | if (elems->rest == NULL) { 19 | SAC_RuntimeError( "tl applied to NIL\n"); 20 | } 21 | res = elems->rest; 22 | 23 | (DESC_RC( res->desc))++; 24 | 25 | if (--(DESC_RC( elems->desc)) == 0) { 26 | SAC_List_free_list( elems); 27 | } 28 | 29 | SAC_ND_A_DESC( res_nt) = res->desc; 30 | SAC_ND_RET_out( res_nt, res_nt) 31 | } 32 | 33 | #undef res_nt 34 | #undef elems_nt 35 | -------------------------------------------------------------------------------- /src/structures/src/String/strext.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of standard module StringC 3 | */ 4 | 5 | 6 | #include "StringC.h" 7 | 8 | 9 | /*****************************************************************/ 10 | 11 | string strext( string old, int first, int len) 12 | { 13 | string new; 14 | 15 | RANGECHECK( (size_t) first, 0, strlen( old) - 1, old); 16 | 17 | if (len <= 0) { 18 | new = (string) SAC_MALLOC( 1); 19 | new[ 0] = 0; 20 | } 21 | else { 22 | new = (string) SAC_MALLOC( len + 1); 23 | strncpy( new, old + first, len); 24 | 25 | if ((size_t) (first + len) <= strlen( old)) { 26 | new[ len] = 0; 27 | } 28 | else { 29 | new[ strlen( old) - first] = 0; 30 | } 31 | } 32 | 33 | return(new); 34 | } 35 | 36 | /*****************************************************************/ 37 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | ISC License (ISC) 2 | 3 | Copyright 2022-2024: Sven-Bodo Scholz, Clemens Grelck, and other contributors: https://github.com/SacBase/Stdlib/blob/master/CONTRIBUTORS.md 4 | 5 | Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 8 | -------------------------------------------------------------------------------- /src/stdio/src/FibreIO/ScanOthers.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of standard module FibreScan 3 | */ 4 | 5 | 6 | #include "FibreScan.h" 7 | #include "FibreScan.tab.h" 8 | 9 | #define FIBRESCAN(returntype, alias, token, typename) \ 10 | returntype FibreScan##alias( FILE *stream) \ 11 | { \ 12 | start_token = PARSE_##token; \ 13 | doScan( stream); \ 14 | return( typename##val); \ 15 | } 16 | 17 | FIBRESCAN(char, Byte, BYTE, byte) 18 | FIBRESCAN(short, Short, SHORT, short) 19 | FIBRESCAN(long, Long, LONG, long) 20 | FIBRESCAN(long long, Longlong, LONGLONG, longlong) 21 | FIBRESCAN(unsigned char, Ubyte, UBYTE, ubyte) 22 | FIBRESCAN(unsigned short, Ushort, USHORT, ushort) 23 | FIBRESCAN(unsigned int, Uint, UINT, uint) 24 | FIBRESCAN(unsigned long, Ulong, ULONG, ulong) 25 | FIBRESCAN(unsigned long long, Ulonglong, ULONGLONG, ulonglong) 26 | 27 | -------------------------------------------------------------------------------- /src/system/Terminal.sac: -------------------------------------------------------------------------------- 1 | #pragma safe 2 | class Terminal; 3 | 4 | external classtype; 5 | 6 | export all except { create_TheTerminal }; 7 | 8 | objdef Terminal TheTerminal = create_TheTerminal(); 9 | 10 | /****************************************************************************** 11 | * 12 | * The global object TheTerminal of class Terminal serves as a representation 13 | * for a terminal screen. It is derived from the global object TheWorld in 14 | * order to represent this part or sub-world of the execution environment. 15 | * It is also used to synchronise the standard I/O streams stdin, stdout, 16 | * and stderr. 17 | * 18 | ******************************************************************************/ 19 | 20 | external Terminal create_TheTerminal(); 21 | #pragma effect World::TheWorld 22 | #pragma linkobj "src/Terminal/terminal.o" 23 | #pragma linksign[0] 24 | -------------------------------------------------------------------------------- /src/system/src/FileSystem/access.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class FileSystem 3 | */ 4 | 5 | 6 | 7 | #include "FileSystem.h" 8 | 9 | 10 | 11 | /*****************************************************************/ 12 | 13 | 14 | 15 | int SACaccess(int *success, char *name, int how) 16 | { 17 | int result, mode; 18 | 19 | switch (how) 20 | { 21 | case 0: 22 | mode=F_OK; 23 | break; 24 | case 1: 25 | mode=R_OK; 26 | break; 27 | case 2: 28 | mode=W_OK; 29 | break; 30 | case 3: 31 | mode=X_OK; 32 | break; 33 | default: 34 | mode=F_OK; 35 | } 36 | 37 | errno=0; 38 | 39 | result=access(name, mode); 40 | 41 | if (errno>0) 42 | { 43 | *success=errno; 44 | } 45 | else 46 | { 47 | *success=-1; 48 | } 49 | 50 | return(result==0); 51 | } 52 | 53 | 54 | /*****************************************************************/ 55 | 56 | 57 | -------------------------------------------------------------------------------- /src/structures/src/String/StringC.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of standard module StringC 3 | */ 4 | 5 | 6 | #include 7 | #include 8 | #include 9 | #include 10 | 11 | #include "sac.h" 12 | 13 | 14 | #ifdef CHECK 15 | 16 | #define RANGECHECK(check, lower, upper, str) \ 17 | if ((checkupper)) \ 18 | SAC_RuntimeError("Range violation upon string access:\n" \ 19 | "tried to access character %d of string\n" \ 20 | "\"%s\"", check, str); 21 | 22 | 23 | #else /* CHECK */ 24 | 25 | #define RANGECHECK(check, lower, upper, str) 26 | 27 | #endif /* CHECK */ 28 | 29 | 30 | #define STRDUP(new, old) new=(string)SAC_MALLOC(strlen(old)+1); \ 31 | strcpy(new, old); 32 | 33 | #define STRFREE(str) SAC_FREE(str); 34 | 35 | typedef char* string; 36 | -------------------------------------------------------------------------------- /src/stdio/src/File/fgets.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class File 3 | */ 4 | 5 | 6 | 7 | #include "File.h" 8 | 9 | #ifdef SACARG_WORKS 10 | SAC_C_EXTERN SACtypes *SACTYPE_String__string; 11 | #endif 12 | 13 | /*****************************************************************/ 14 | 15 | #ifdef SACARG_WORKS 16 | int SACfgets_F(SACarg **str, int size, FILE *stream) 17 | #else 18 | int SACfgets_F(char **str, int size, FILE *stream) 19 | #endif 20 | { 21 | int error=-1; 22 | char *buf, *buf2; 23 | 24 | buf = malloc (sizeof(char) * size); 25 | buf2 = fgets (buf, size, stream); 26 | if (buf2 == NULL) { 27 | error = errno; 28 | free (buf); 29 | } 30 | #ifdef SACARG_WORKS 31 | *str = SACARGcreateFromPointer (SACTYPE_String__string, buf2, 1, 5); 32 | #else 33 | *str = buf2; 34 | #endif 35 | 36 | return error; 37 | } 38 | 39 | 40 | /*****************************************************************/ 41 | 42 | -------------------------------------------------------------------------------- /ci/fail-on-warning.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | # the scipts reads from stdin/file the output of a build process (such as 4 | # through CMake/Autotools) and looks for text indicate that warning has 5 | # been issued. If it finds an instances of this, we return non-zero value. 6 | # Exceptions can be set, meaning that we don't consider all warnings as 7 | # a reason to return a non-zero value. 8 | 9 | # array join, supports delimiter. Usage: join_by ',' ${array} 10 | function join_by { local d=$1; shift; echo -n "$1"; shift; printf "%s" "${@/#/$d}"; } 11 | 12 | # support stdin 13 | FILE="${1:-/dev/stdin}" 14 | 15 | # construct exclude array 16 | EXCLUDES=('was built for newer macOS version') 17 | TEXCLUDES="$(join_by '|' "${EXCLUDES[@]}")" 18 | 19 | # general search 20 | WARN_NUM=$(grep -i -F 'warning:' "$FILE" | grep -i -c -v -E "${TEXCLUDES}") 21 | if [ "${WARN_NUM}" -gt 0 ]; then 22 | echo "+++ ${WARN_NUM} warnings detected +++"; 23 | exit 1 24 | fi 25 | -------------------------------------------------------------------------------- /src/numerical/src/Math/int_log.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | unsigned int SAC_MATH_log2u(unsigned int x) 4 | { 5 | #if defined __GNUC__ || defined __clang__ 6 | int leading_zeroes = __builtin_clz(x); 7 | #else 8 | int leading_zeroes = 0; 9 | unsigned int mask = 1u << (8 * sizeof(int) - 1); 10 | while (((mask & x) != mask) && mask != 0) { 11 | mask >>= 1; 12 | leading_zeroes++; 13 | } 14 | #endif 15 | 16 | return 8 * sizeof(int) - leading_zeroes - 1; 17 | } 18 | 19 | unsigned long SAC_MATH_log2ul(unsigned long x) 20 | { 21 | #if defined __GNUC__ || defined __clang__ 22 | int leading_zeroes = __builtin_clzl(x); 23 | #else 24 | int leading_zeroes = 0; 25 | unsigned long mask = 1u << (8 * sizeof(unsigned long) - 1); 26 | while (((mask & x) != mask) && mask != 0) { 27 | mask >>= 1; 28 | leading_zeroes++; 29 | } 30 | #endif 31 | 32 | return 8 * sizeof(unsigned long) - leading_zeroes - 1; 33 | } 34 | -------------------------------------------------------------------------------- /src/stdio/src/TermFile/fgets.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class File 3 | */ 4 | 5 | 6 | 7 | #include "TermFile.h" 8 | 9 | #ifdef SACARG_WORKS 10 | SAC_C_EXTERN SACtypes *SACTYPE_String__string; 11 | #endif 12 | 13 | /*****************************************************************/ 14 | 15 | #ifdef SACARG_WORKS 16 | int SACfgets_TF(SACarg **str, int size, FILE *stream) 17 | #else 18 | int SACfgets_TF(char **str, int size, FILE *stream) 19 | #endif 20 | { 21 | int error=-1; 22 | char *buf, *buf2; 23 | 24 | buf = malloc (sizeof(char) * size); 25 | buf2 = fgets (buf, size, stream); 26 | if (buf2 == NULL) { 27 | error = errno; 28 | free (buf); 29 | } 30 | #ifdef SACARG_WORKS 31 | *str = SACARGcreateFromPointer (SACTYPE_String__string, buf2, 1, 5); 32 | #else 33 | *str = buf2; 34 | #endif 35 | 36 | return error; 37 | } 38 | 39 | 40 | /*****************************************************************/ 41 | 42 | -------------------------------------------------------------------------------- /src/structures/src/String/tostring.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of standard module StringC 3 | */ 4 | 5 | 6 | #include "StringC.h" 7 | 8 | /*****************************************************************/ 9 | 10 | #define str_nt (str, T_OLD((SCL, (HID, (NUQ,))))) 11 | #define ar_nt (ar, T_OLD((AUD, (NHD, (NUQ,))))) 12 | 13 | void to_string( SAC_ND_PARAM_out( str_nt, string), 14 | SAC_ND_PARAM_in( ar_nt, char), 15 | int length) 16 | { 17 | SAC_ND_DECL__DESC( str_nt, ) 18 | SAC_ND_DECL__DATA( str_nt, string, ) 19 | 20 | SAC_ND_ALLOC__DESC( str_nt, 0) 21 | SAC_ND_SET__RC( str_nt, 1) 22 | SAC_ND_A_FIELD( str_nt) = (string) SAC_MALLOC( length + 1); 23 | strncpy( SAC_ND_A_FIELD( str_nt), SAC_ND_A_FIELD( ar_nt), length); 24 | SAC_ND_A_FIELD( str_nt)[length] = '\0'; 25 | 26 | SAC_ND_RET_out( str_nt, str_nt) 27 | } 28 | 29 | #undef str_nt 30 | #undef ar_nt 31 | 32 | /*****************************************************************/ 33 | -------------------------------------------------------------------------------- /src/structures/src/List/cons.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of SAC standard module List 3 | */ 4 | 5 | 6 | #include "List.h" 7 | 8 | 9 | #define res_nt (res, T_OLD((SCL, (HID, (NUQ,))))) 10 | #define elems_nt (elems, T_OLD((SCL, (HID, (NUQ,))))) 11 | 12 | void SAC_List_cons( SAC_ND_PARAM_out( res_nt, list *), 13 | int elem, 14 | SAC_ND_PARAM_in( elems_nt, list *)) 15 | { 16 | SAC_ND_DECL__DESC( res_nt, ) 17 | SAC_ND_DECL__DATA( res_nt, list *, ) 18 | 19 | res = (list *) SAC_MALLOC( sizeof( list)); 20 | res->elem = elem; 21 | res->rest = elems; 22 | SAC_ND_ALLOC__DESC( res_nt, 0) 23 | SAC_ND_SET__RC( res_nt, 1) 24 | res->desc = SAC_ND_A_DESC( res_nt); 25 | 26 | #if TRACE 27 | fprintf( stderr, "creating CONS at (%p)\n", res); 28 | fprintf( stderr, " [ %d . (%p)]\n", elem, elems); 29 | #endif 30 | 31 | SAC_ND_RET_out( res_nt, res_nt) 32 | } 33 | 34 | #undef res_nt 35 | #undef elemsA_nt 36 | #undef elemsB_nt 37 | #undef new_nt 38 | -------------------------------------------------------------------------------- /src/structures/src/StringArray/shape.c: -------------------------------------------------------------------------------- 1 | #include "StringArray.h" 2 | 3 | #define s_nt (s, T_OLD((SCL, (HID, (NUQ,))))) 4 | #define shp_nt (shp, T_OLD((AKD, (NHD, (NUQ,))))) 5 | #define res_nt (res, T_OLD((AKD, (NHD, (NUQ,))))) 6 | 7 | void SAC_StringArray_shape( SAC_ND_PARAM_out( shp_nt, int), 8 | SAC_ND_PARAM_in( s_nt, array *)) 9 | { 10 | int i; 11 | int SAC_ND_A_MIRROR_DIM( res_nt) = 1; 12 | SAC_ND_DECL__DESC( res_nt, ); 13 | SAC_ND_DECL__DATA( res_nt, int, ); 14 | 15 | SAC_ND_ALLOC__DESC( res_nt, 1); 16 | 17 | SAC_ND_A_DESC_SHAPE( res_nt, 0) = s->dim; 18 | 19 | SAC_ND_SET__RC( res_nt, 1); 20 | SAC_ND_A_DESC_SIZE( res_nt) = SAC_ND_A_DESC_SHAPE( res_nt, 0); 21 | SAC_ND_A_FIELD( res_nt) = SAC_MALLOC( s->dim * sizeof( int)); 22 | for( i=0; idim; i++) { 23 | SAC_ND_A_FIELD( res_nt)[i] = s->shp[i]; 24 | } 25 | 26 | SAC_ND_RET_out( shp_nt , res_nt ) 27 | } 28 | 29 | #undef s_nt 30 | #undef shp_nt 31 | #undef res_nt 32 | -------------------------------------------------------------------------------- /src/structures/ComplexArrayTransform.xsac: -------------------------------------------------------------------------------- 1 | #pragma safe 2 | 3 | module ComplexArrayTransform; 4 | 5 | use ComplexBasics: { complex }; 6 | use ComplexArrayBasics: { sel }; 7 | 8 | export all; 9 | 10 | #include "arraytransform.mac" 11 | 12 | #define COMPLEX(fun) \ 13 | fun(complex, \ 14 | /* no postfix */, \ 15 | /* no format */, \ 16 | ((complex)[0d,0d]), \ 17 | ((complex)[1d,1d])) 18 | 19 | COMPLEX(TAKE) 20 | COMPLEX(DROP) 21 | COMPLEX(TILE) 22 | COMPLEX(CAT) 23 | COMPLEX(REVERSE) 24 | COMPLEX(ROTATE) 25 | COMPLEX(SHIFT) 26 | 27 | inline complex sum(complex[d:shp] arr) 28 | { 29 | return with { 30 | (_mul_SxV_(0, shp) <= iv < shp) : arr[iv]; 31 | } : fold(ComplexScalarArith::+, (complex)[0d, 0d]); 32 | } 33 | -------------------------------------------------------------------------------- /src/system/World.sac: -------------------------------------------------------------------------------- 1 | #pragma safe 2 | class World; 3 | 4 | external classtype; 5 | 6 | export all except { create_TheWorld }; 7 | 8 | objdef World TheWorld = create_TheWorld(); 9 | 10 | /****************************************************************************** 11 | * 12 | * The global object TheWorld of class World serves as a representation of the 13 | * execution environment. It provides access to resources residing outside the 14 | * functional framework of a SAC program. 15 | * 16 | * In order to allow concurrent access to unrelated parts of the execution 17 | * environment, some other predefined global objects are derived from world 18 | * upon program start. These represent disjoint partitions of the execution 19 | * environment or outside world. 20 | * 21 | * These are: 22 | * - TheTerminal 23 | * - TheFileSys 24 | * - TheEnvironment 25 | * - TheCommandLine 26 | * - TheClock 27 | * 28 | ******************************************************************************/ 29 | 30 | external World create_TheWorld(); 31 | #pragma linkobj "src/World/World.o" 32 | #pragma linksign[0] 33 | -------------------------------------------------------------------------------- /src/structures/src/List/drop.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of SAC standard module List 3 | */ 4 | 5 | 6 | #include "List.h" 7 | 8 | 9 | #define res_nt (res, T_OLD((SCL, (HID, (NUQ,))))) 10 | #define elems_nt (elems, T_OLD((SCL, (HID, (NUQ,))))) 11 | 12 | void SAC_List_drop( SAC_ND_PARAM_out( res_nt, list *), 13 | int n, 14 | SAC_ND_PARAM_in( elems_nt, list *)) 15 | { 16 | SAC_ND_DECL__DESC( res_nt, ) 17 | SAC_ND_DECL__DATA( res_nt, list *, ) 18 | 19 | if (n < 0) { 20 | SAC_RuntimeError( "negative first arg of drop\n"); 21 | } 22 | 23 | SAC_ND_A_DESC( res_nt) = SAC_ND_A_DESC( elems_nt); 24 | SAC_ND_A_FIELD( res_nt) = SAC_ND_A_FIELD( elems_nt); 25 | 26 | while (n > 0) { 27 | if (res->rest == NULL) { 28 | SAC_RuntimeError( "first arg of drop %d larger than length of list\n", n); 29 | } 30 | res=res->rest; 31 | n--; 32 | } 33 | (DESC_RC( res->desc))++; 34 | 35 | if (--(DESC_RC( elems->desc)) == 0) { 36 | SAC_List_free_list( elems); 37 | } 38 | 39 | SAC_ND_A_DESC( res_nt) = res->desc; 40 | SAC_ND_RET_out( res_nt, res_nt) 41 | } 42 | 43 | #undef res_nt 44 | #undef elems_nt 45 | -------------------------------------------------------------------------------- /src/system/MTClock.sac: -------------------------------------------------------------------------------- 1 | #pragma safe 2 | class MTClock; 3 | 4 | external classtype; 5 | 6 | export all; 7 | 8 | objdef MTClock TheMTClock = createTheMTClock(); 9 | 10 | external MTClock createTheMTClock(); 11 | #pragma linkname "SAC_MTClock_createTheMTClock" 12 | #pragma linkobj "src/MTClock/mtclock.o" 13 | #pragma effect World::TheWorld 14 | #pragma linksign [1] 15 | 16 | external void touch(MTClock& mtclock); 17 | #pragma linkname "SAC_MTClock_touch" 18 | #pragma linkobj "src/MTClock/mtclock.o" 19 | 20 | external long, long gettime(); 21 | #pragma linkname "SAC_MTClock_gettime" 22 | #pragma linkobj "src/MTClock/mtclock.o" 23 | #pragma effect MTClock::TheMTClock 24 | #pragma linksign [1,2] 25 | 26 | double timediff(long sec1, long nsec1, long sec2, long nsec2) 27 | { 28 | sec = _sub_SxS_(sec2, sec1); 29 | nsec = _sub_SxS_(nsec2, nsec1); 30 | 31 | if (_lt_SxS_(nsec, 0l)) { 32 | nsec = _add_SxS_(nsec, 1000000000l); 33 | sec = _sub_SxS_(sec, 1l); 34 | } 35 | 36 | return _add_SxS_(_tod_S_(sec), 37 | _div_SxS_(_tod_S_(nsec), 1e9d)); 38 | } 39 | 40 | void touch() 41 | { 42 | touch(TheMTClock); 43 | } 44 | -------------------------------------------------------------------------------- /src/structures/src/String/strtok.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of standard module StringC 3 | */ 4 | 5 | 6 | #include "StringC.h" 7 | 8 | 9 | /*****************************************************************/ 10 | 11 | string SACstrtok( string *remain, string input, string sep) 12 | { 13 | int i, j, k; 14 | string token; 15 | 16 | /* increment 'i' as long as input[i] is in "sep". */ 17 | i = k = 0; 18 | while (input[i] && sep[k]) { 19 | k = 0; 20 | while (sep[k] && input[i] != sep[k]) { 21 | ++k; 22 | } 23 | if (sep[k]) { 24 | ++i; 25 | } 26 | } 27 | 28 | /* increment 'j' as long as input[j] is not in "sep". */ 29 | j = i; 30 | k = 0; 31 | while (input[j] && sep[k] != input[j]) { 32 | k = 0; 33 | while (sep[k] && input[j] != sep[k]) { 34 | ++k; 35 | } 36 | if (!sep[k]) { 37 | ++j; 38 | } 39 | } 40 | 41 | token = (string) SAC_MALLOC( j - i + 1); 42 | strncpy(token, input + i, j - i); 43 | token[j - i] = '\0'; 44 | 45 | *remain = (string) SAC_MALLOC( strlen( input + j) + 1); 46 | strcpy( *remain, input + j); 47 | 48 | return( token); 49 | } 50 | 51 | /*****************************************************************/ 52 | -------------------------------------------------------------------------------- /src/structures/src/String/sprintf.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of standard module StringC 3 | */ 4 | 5 | 6 | #include "StringC.h" 7 | #include 8 | 9 | /* Allow for long path names and URLs with long parameters. */ 10 | #if defined(PATH_MAX) && PATH_MAX >= 2048 11 | #define BUFFER_SIZE PATH_MAX 12 | #else 13 | #define BUFFER_SIZE 2048 14 | #endif 15 | 16 | 17 | /*****************************************************************/ 18 | 19 | string SACsprintf( string format, ...) 20 | { 21 | va_list arg_p; 22 | char buffer[BUFFER_SIZE]; 23 | int n; 24 | string new; 25 | 26 | buffer[0] = '\0'; 27 | va_start( arg_p, format); 28 | n = vsnprintf( buffer, sizeof buffer, format, arg_p); 29 | va_end( arg_p); 30 | if ((size_t)n >= sizeof buffer) { 31 | new = (string) SAC_MALLOC( n + 1); 32 | va_start( arg_p, format); 33 | n = vsnprintf( new, n + 1, format, arg_p); 34 | va_end( arg_p); 35 | } 36 | else if (n >= 0) { 37 | new = (string) SAC_MALLOC( strlen( buffer) + 1); 38 | strcpy( new, buffer); 39 | } 40 | else { 41 | new = (string) SAC_MALLOC( 1); 42 | new[0] = '\0'; 43 | } 44 | 45 | return( new); 46 | } 47 | 48 | /*****************************************************************/ 49 | -------------------------------------------------------------------------------- /src/structures/src/String/strmod.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of standard module StringC 3 | */ 4 | 5 | 6 | #include "StringC.h" 7 | 8 | 9 | /*****************************************************************/ 10 | 11 | #define new_nt (new, T_OLD((SCL, (HID, (NUQ,))))) 12 | #define old_nt (old, T_OLD((SCL, (HID, (NUQ,))))) 13 | 14 | void strmod( SAC_ND_PARAM_out( new_nt, string), 15 | SAC_ND_PARAM_in( old_nt, string), 16 | int pos, char c) 17 | { 18 | SAC_ND_DECL__DATA( new_nt, string, ) 19 | SAC_ND_DECL__DESC( new_nt, ) 20 | 21 | RANGECHECK( (size_t)pos, 0, strlen( SAC_ND_A_FIELD( old_nt)) - 1, 22 | SAC_ND_A_FIELD( old_nt)); 23 | 24 | if (SAC_ND_A_RC( old_nt) == 1) { 25 | SAC_ND_A_DESC( new_nt) = SAC_ND_A_DESC( old_nt); 26 | SAC_ND_A_FIELD( new_nt) = SAC_ND_A_FIELD( old_nt); 27 | } 28 | else { 29 | SAC_ND_ALLOC__DESC( new_nt, 0) 30 | SAC_ND_SET__RC( new_nt, 1) 31 | STRDUP( SAC_ND_A_FIELD( new_nt), SAC_ND_A_FIELD( old_nt)); 32 | 33 | SAC_ND_DEC_RC_FREE( old_nt, 1, SAC_FREE) 34 | } 35 | SAC_ND_A_FIELD( new_nt)[pos] = c; 36 | 37 | SAC_ND_RET_out( new_nt, new_nt) 38 | } 39 | 40 | #undef new_nt 41 | #undef old_nt 42 | 43 | /*****************************************************************/ 44 | -------------------------------------------------------------------------------- /src/stdio/src/BinFile/binfReadDblArr.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of module BinFile 3 | */ 4 | 5 | 6 | #include "BinFile.h" 7 | 8 | #define array_nt (array, T_OLD((AUD, (NHD, (NUQ, ))))) 9 | #define ret_nt (ret, T_OLD((AUD, (NHD, (NUQ, ))))) 10 | 11 | void SACbinfReadDoubleArray( SAC_ND_PARAM_out( array_nt, double), int fd, int dim, int *shp) 12 | { 13 | SAC_ND_DECL__DATA( ret_nt, double, ) 14 | SAC_ND_DECL__DESC( ret_nt, ) 15 | int SAC_ND_A_MIRROR_DIM( ret_nt) = dim; 16 | int i, size; 17 | int bytesRead; 18 | double *doublearray; 19 | int given_dim; 20 | int *given_shp; 21 | 22 | SAC_ND_ALLOC__DESC( ret_nt, dim) 23 | SAC_ND_SET__RC( ret_nt, 1) 24 | 25 | /* start_token = PARSE_DOUBLE_ARRAY; */ 26 | /* yyin = stream; */ 27 | given_dim = dim; 28 | given_shp = shp; 29 | for( i = 0, size = 1; i < dim; i++) { 30 | size *= shp[i]; 31 | SAC_ND_A_DESC_SHAPE( ret_nt, i) = shp[i]; 32 | } 33 | SAC_ND_A_DESC_SIZE( ret_nt) = size; 34 | doublearray = (double *) SAC_MALLOC( size * sizeof( double)); 35 | 36 | /* read double array from file fd */ 37 | bytesRead = read(fd,doublearray,size * sizeof(double)); 38 | 39 | SAC_ND_A_FIELD( ret_nt) = doublearray; 40 | 41 | SAC_ND_RET_out( array_nt, ret_nt) 42 | } 43 | 44 | #undef array_nt 45 | #undef ret_nt 46 | -------------------------------------------------------------------------------- /src/structures/src/String/strtake.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of standard module StringC 3 | */ 4 | 5 | 6 | #include "StringC.h" 7 | 8 | 9 | /*****************************************************************/ 10 | 11 | #define new_nt (new, T_OLD((SCL, (HID, (NUQ,))))) 12 | #define old_nt (old, T_OLD((SCL, (HID, (NUQ,))))) 13 | 14 | void strtake( SAC_ND_PARAM_out( new_nt, string), 15 | SAC_ND_PARAM_in( old_nt, string), 16 | int n) 17 | { 18 | SAC_ND_DECL__DESC( new_nt, ) 19 | SAC_ND_DECL__DATA( new_nt, string, ) 20 | 21 | RANGECHECK( (size_t)n, 0, strlen( SAC_ND_A_FIELD( old_nt)), SAC_ND_A_FIELD( old_nt)); 22 | 23 | if (SAC_ND_A_RC( old_nt) == 1) { 24 | SAC_ND_A_DESC( new_nt) = SAC_ND_A_DESC( old_nt); 25 | SAC_ND_A_FIELD( new_nt) = SAC_ND_A_FIELD( old_nt); 26 | } 27 | else { 28 | SAC_ND_ALLOC__DESC( new_nt, 0) 29 | SAC_ND_SET__RC( new_nt, 1) 30 | SAC_ND_A_FIELD( new_nt) = (string) SAC_MALLOC( n + 1); 31 | strncpy( SAC_ND_A_FIELD( new_nt), SAC_ND_A_FIELD( old_nt), n); 32 | 33 | SAC_ND_DEC_RC_FREE( old_nt, 1, SAC_FREE) 34 | } 35 | SAC_ND_A_FIELD( new_nt)[n] = '\0'; 36 | 37 | SAC_ND_RET_out( new_nt, new_nt) 38 | } 39 | 40 | #undef new_nt 41 | #undef old_nt 42 | 43 | /*****************************************************************/ 44 | -------------------------------------------------------------------------------- /src/structures/src/StringArray/sel.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #include "StringArray.h" 5 | 6 | #define strout_nt (strout, T_OLD((SCL, (HID, (NUQ,))))) 7 | #define str_nt (str, T_OLD((SCL, (HID, (NUQ,))))) 8 | #define idx_nt (idx, T_OLD((AKD, (NHD, (NUQ,))))) 9 | #define arr_nt (arr, T_OLD((SCL, (HID, (NUQ,))))) 10 | 11 | void SAC_StringArray_sel( SAC_ND_PARAM_out( strout_nt, char *), 12 | SAC_ND_PARAM_in( idx_nt, int ), 13 | SAC_ND_PARAM_in( arr_nt, array *)) 14 | { 15 | int offset; 16 | SAC_ND_DECL__DESC( str_nt, ); 17 | char *SAC_ND_A_FIELD( str_nt ); 18 | 19 | offset = SAC_StringArray_index2offset( arr->dim, 20 | SAC_ND_A_FIELD(idx_nt), 21 | arr->shp); 22 | 23 | SAC_ND_A_FIELD( str_nt) = arr->data[offset]; 24 | SAC_ND_A_DESC( str_nt) = arr->descs[offset]; 25 | SAC_ND_INC_RC( str_nt, 1); 26 | 27 | /* DSR: Removing the line below makes StringArray usable for now 28 | * but we need to investigate why this works. 29 | * See bug 616 for details. 30 | */ 31 | SAC_ND_DEC_RC_FREE( idx_nt, 1 , ); 32 | SAC_ND_DEC_RC_FREE( arr_nt, 1 , SAC_StringArray_free ); 33 | 34 | SAC_ND_RET_out( strout_nt , str_nt ) 35 | } 36 | 37 | -------------------------------------------------------------------------------- /src/system/src/RTClock/rtclock.c: -------------------------------------------------------------------------------- 1 | /****************************************************************************** 2 | * 3 | * @file rtclock.c 4 | * 5 | * @brief This module implements the functionally sound integration of the 6 | * real time clock into the world of SAC. 7 | * 8 | ******************************************************************************/ 9 | #include 10 | 11 | #ifdef __MACH__ 12 | #include 13 | #include 14 | #endif 15 | 16 | void *SAC_RTClock_createTheRTClock(void) 17 | { 18 | return((void*)0); 19 | } 20 | 21 | void SAC_RTClock_touch(void *rtclock) 22 | { 23 | /* noop */ 24 | } 25 | 26 | void SAC_RTClock_gettime(long *sec, long *nsec) 27 | { 28 | struct timespec result; 29 | result.tv_sec = 0; 30 | result.tv_nsec = 0; 31 | 32 | #ifdef __MACH__ 33 | // OS X does not have clock_gettime, use clock_get_time 34 | clock_serv_t cclock; 35 | mach_timespec_t mts; 36 | host_get_clock_service(mach_host_self(), CALENDAR_CLOCK, &cclock); 37 | clock_get_time(cclock, &mts); 38 | mach_port_deallocate(mach_task_self(), cclock); 39 | result.tv_sec = mts.tv_sec; 40 | result.tv_nsec = mts.tv_nsec; 41 | #else 42 | clock_gettime(CLOCK_REALTIME, &result); 43 | #endif 44 | 45 | *sec = result.tv_sec; 46 | *nsec = result.tv_nsec; 47 | } 48 | -------------------------------------------------------------------------------- /src/structures/src/StringArray/genarray.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #include "StringArray.h" 5 | 6 | #define resout_nt (resout, T_OLD((SCL, (HID, (NUQ,))))) 7 | #define res_nt (res, T_OLD((SCL, (HID, (NUQ,))))) 8 | #define shp_nt (shp, T_OLD((AKD, (NHD, (NUQ,))))) 9 | #define s_nt (s, T_OLD((SCL, (HID, (NUQ,))))) 10 | 11 | void SAC_StringArray_genarray( SAC_ND_PARAM_out( resout_nt, array *), 12 | SAC_ND_PARAM_in( shp_nt, int ), 13 | SAC_ND_PARAM_in( s_nt, char *)) 14 | { 15 | SAC_ND_DECL__DESC( res_nt, ); 16 | array *SAC_ND_A_FIELD( res_nt ); 17 | int dim, size; 18 | int i; 19 | 20 | SAC_ND_ALLOC__DESC( res_nt, 0); 21 | SAC_ND_SET__RC( res_nt, 1); 22 | 23 | dim = SAC_ND_A_DESC_SIZE( shp_nt ); 24 | size = 1; 25 | for( i=0; i < dim; i++) { 26 | size *= SAC_ND_READ( shp_nt, i); 27 | } 28 | 29 | res = SAC_StringArray_alloc( dim, size); 30 | 31 | for( i=0; i < dim; i++) { 32 | res->shp[i] = SAC_ND_READ( shp_nt, i); 33 | } 34 | 35 | for( i=0; i < size ; i++) { 36 | res->data[i] = SAC_ND_A_FIELD( s_nt ); 37 | res->descs[i] = SAC_ND_A_DESC( s_nt ); 38 | SAC_ND_INC_RC( s_nt, 1); 39 | } 40 | 41 | SAC_ND_DEC_RC_FREE( s_nt, 1 , free ); 42 | SAC_ND_DEC_RC_FREE( shp_nt, 1,); 43 | 44 | SAC_ND_RET_out( resout_nt , res_nt ) 45 | 46 | } 47 | 48 | 49 | -------------------------------------------------------------------------------- /src/system/RTimer.sac: -------------------------------------------------------------------------------- 1 | #pragma safe 2 | class RTimer; 3 | 4 | external classtype; 5 | 6 | use RTClock: { TheRTClock }; 7 | 8 | export all; 9 | 10 | external RTimer createRTimer(); 11 | #pragma effect TheRTClock 12 | #pragma linkobj "src/RTimer/rtimer.o" 13 | #pragma linkname "SAC_RTimer_createRTimer" 14 | #pragma linksign [1] 15 | 16 | external void destroyRTimer(RTimer rtimer); 17 | #pragma effect TheRTClock 18 | #pragma linkobj "src/RTimer/rtimer.o" 19 | #pragma linkname "SAC_RTimer_destroyRTimer" 20 | 21 | external void startRTimer(RTimer &rtimer); 22 | #pragma effect TheRTClock 23 | #pragma linkobj "src/RTimer/rtimer.o" 24 | #pragma linkname "SAC_RTimer_startRTimer" 25 | 26 | external void stopRTimer(RTimer &rtimer); 27 | #pragma effect TheRTClock 28 | #pragma linkobj "src/RTimer/rtimer.o" 29 | #pragma linkname "SAC_RTimer_stopRTimer" 30 | 31 | external void resetRTimer(RTimer &rtimer); 32 | #pragma linkobj "src/RTimer/rtimer.o" 33 | #pragma linkname "SAC_RTimer_resetRTimer" 34 | 35 | external int, int getRTimerInts(RTimer &rtimer); 36 | #pragma linkobj "src/RTimer/rtimer.o" 37 | #pragma linkname "SAC_RTimer_getRTimerInts" 38 | #pragma linksign [2,3,1] 39 | 40 | external double getRTimerDbl(RTimer &rtimer); 41 | #pragma linkobj "src/RTimer/rtimer.o" 42 | #pragma linkname "SAC_RTimer_getRTimerDbl" 43 | #pragma linksign [0,1] 44 | -------------------------------------------------------------------------------- /src/system/src/Clock/strptime.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of standard module Time 3 | */ 4 | 5 | 6 | 7 | #include "Clock.h" 8 | 9 | 10 | extern char *strptime(const char *, const char *, struct tm *); 11 | 12 | /* 13 | * Unfortunately, the function strptime() is not declared in time.h ! 14 | * Fortunately, the standard library libc.a contains an implementation 15 | * of strptime(). 16 | * 17 | * bro: Actually, time.h does have a prototype for strptime(), but 18 | * then _XOPEN_SOURCE must be defined before including time.h. 19 | */ 20 | 21 | 22 | 23 | /******************************************************************/ 24 | 25 | 26 | time_t *SACstrptime(string * result, string s, string format) 27 | { 28 | struct tm tt; 29 | string remain; 30 | time_t *t; 31 | 32 | t = (time_t *) SAC_MALLOC(sizeof(time_t)); 33 | 34 | memset(&tt, 0, sizeof tt); 35 | remain = strptime(s, format, &tt); 36 | 37 | /* strptime() may return NULL if it fails to match all of the format string. 38 | * In that case an error occurred and the contents of tt is undefined. 39 | */ 40 | if (remain == NULL) { 41 | *t = 0; 42 | *result = (string) SAC_MALLOC(1); 43 | **result = '\0'; 44 | } else { 45 | *t = mktime(&tt); 46 | *result = (string) SAC_MALLOC(strlen(remain) + 1); 47 | strcpy(*result, remain); 48 | } 49 | 50 | return (t); 51 | } 52 | 53 | 54 | 55 | /******************************************************************/ 56 | -------------------------------------------------------------------------------- /test/xoshiro-advance.sac: -------------------------------------------------------------------------------- 1 | use Array: all; 2 | use StdIO: all; 3 | use Xoshiro: all; 4 | 5 | bool test_advancel(struct State256 seed, int num) 6 | { 7 | state1 = seed; 8 | state2 = seed; 9 | state1 = advancel(state1, num); 10 | 11 | for (i = 0; i < num; i++) { 12 | state2 = advancel(state2, 1); 13 | } 14 | 15 | return (state1.s0l == state2.s0l && state1.s1l == state2.s1l && 16 | state1.s2l == state2.s2l && state1.s3l == state2.s3l); 17 | } 18 | 19 | bool test_advance(struct State128 seed, int num) 20 | { 21 | state1 = seed; 22 | state2 = seed; 23 | state1 = advance(state1, num); 24 | for (i = 0; i < num; i++) { 25 | state2 = advance(state2, 1); 26 | } 27 | 28 | return (state1.s0 == state2.s0 && state1.s1 == state2.s1 && 29 | state1.s2 == state2.s2 && state1.s3 == state2.s3); 30 | } 31 | 32 | int main() 33 | { 34 | seedl = srand256(); 35 | seed = srand128(); 36 | 37 | printf("Test xoshiro128 advance\n"); 38 | for (i = 1; i < 12; i++) { 39 | printf("Advance %d times: %s\n", i, test_advance(seed, i) ? 40 | "success" : 41 | "failure"); 42 | } 43 | 44 | printf("Test xoshiro256 advance\n"); 45 | for (i = 1; i < 12; i++) { 46 | printf("Advance %d times: %s\n", i, test_advancel(seedl, i) ? 47 | "success" : 48 | "failure"); 49 | } 50 | 51 | return 0; 52 | } 53 | -------------------------------------------------------------------------------- /src/system/src/Dir/readdir.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of directory functions. 3 | */ 4 | 5 | 6 | 7 | #include "Dir.h" 8 | 9 | /* 10 | * SBS: I assume all systems do have readdir 11 | * If they turn out not to, we may have to preset the macro 12 | * HAVE_READDIR through cmake... 13 | */ 14 | #define HAVE_READDIR 1 15 | 16 | /*****************************************************************/ 17 | 18 | string SACreaddir( DIR* stream) 19 | { 20 | 21 | #if HAVE_READDIR 22 | #else // HAVE_READDIR 23 | /* some old OSes don't allocate enough room for entry.d_name. */ 24 | struct bigenough { 25 | struct dirent entry; 26 | char name[1024]; 27 | } big; 28 | int r; 29 | #endif // HAVE_READDIR 30 | 31 | struct dirent* entptr; 32 | string name = NULL; 33 | 34 | while (name == NULL) { 35 | #if HAVE_READDIR 36 | entptr = readdir( stream); 37 | if (entptr != NULL) { 38 | #else // HAVE_READDIR 39 | entptr = NULL; 40 | r = readdir_r( stream, &big.entry, &entptr); 41 | if (r == 0 && entptr != NULL) { 42 | #endif // HAVE_READDIR 43 | char *s = entptr->d_name; 44 | /* ignore "." and ".." */ 45 | if (*s == '.' && (s[1] == '\0' || (s[1] == '.' && s[2] == '\0'))) { 46 | } else { 47 | name = (string) SAC_MALLOC( strlen( s) + 1); 48 | strcpy( name, s); 49 | } 50 | } else { 51 | name = (string) SAC_MALLOC( 1); 52 | name[0] = '\0'; 53 | } 54 | } 55 | 56 | return( name); 57 | } 58 | 59 | /*****************************************************************/ 60 | -------------------------------------------------------------------------------- /src/structures/src/StringArray/modarray.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #include "StringArray.h" 5 | 6 | #define arrout_nt (arrout, T_OLD((SCL, (HID, (NUQ,))))) 7 | #define str_nt (str, T_OLD((SCL, (HID, (NUQ,))))) 8 | #define val_nt (val, T_OLD((SCL, (HID, (NUQ,))))) 9 | #define idx_nt (idx, T_OLD((AKD, (NHD, (NUQ,))))) 10 | #define arr_nt (arr, T_OLD((SCL, (HID, (NUQ,))))) 11 | 12 | void SAC_StringArray_modarray( SAC_ND_PARAM_out( arrout_nt, array *), 13 | SAC_ND_PARAM_in( arr_nt, array *), 14 | SAC_ND_PARAM_in( idx_nt, int ), 15 | SAC_ND_PARAM_in( val_nt, char * )) 16 | { 17 | int offset; 18 | SAC_ND_DECL__DESC( str_nt, ); 19 | char *SAC_ND_A_FIELD( str_nt ); 20 | 21 | if( SAC_ND_A_RC( arr_nt) > 1 ) { 22 | SAC_ND_DEC_RC( arr_nt, 1); 23 | SAC_ND_A_FIELD( arr_nt) = SAC_StringArray_copy( SAC_ND_A_FIELD( arr_nt)); 24 | SAC_ND_ALLOC__DESC( arr_nt, 0); 25 | SAC_ND_SET__RC( arr_nt, 1); 26 | } 27 | offset = SAC_StringArray_index2offset( arr->dim, 28 | SAC_ND_A_FIELD(idx_nt), 29 | arr->shp); 30 | 31 | SAC_ND_A_FIELD( str_nt) = arr->data[offset]; 32 | SAC_ND_A_DESC( str_nt) = arr->descs[offset]; 33 | SAC_ND_DEC_RC_FREE( str_nt, 1, free); 34 | arr->data[offset] = SAC_ND_A_FIELD( val_nt); 35 | arr->descs[offset] = SAC_ND_A_DESC( val_nt); 36 | 37 | SAC_ND_DEC_RC_FREE( idx_nt, 1 , ); 38 | 39 | SAC_ND_RET_out( arrout_nt , arr_nt ) 40 | } 41 | 42 | -------------------------------------------------------------------------------- /src/stdio/src/File/mkstemp.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class File 3 | */ 4 | #include 5 | #include 6 | 7 | #include "File.h" 8 | 9 | #define res_nt (res, T_OLD((SCL, (HID, (NUQ,))))) 10 | #define str_nt (str, T_OLD((SCL, (HID, (NUQ,))))) 11 | #define filep_nt (filep, T_OLD((SCL, (HID, (NUQ,))))) 12 | 13 | /*****************************************************************/ 14 | 15 | int SACmkstemp ( SAC_ND_PARAM_out_nodesc (filep_nt, FILE*), 16 | SAC_ND_PARAM_out (str_nt, char*), 17 | const char* template) 18 | { 19 | int error = EXIT_SUCCESS; 20 | int filedesc; 21 | int length = strlen (template); 22 | SAC_ND_DECL__DESC (str_nt, ) 23 | SAC_ND_DECL__DATA (str_nt, char*, ) 24 | SAC_ND_DECL__DATA (filep_nt, FILE*, ) 25 | 26 | // initialise filep 27 | SAC_ND_A_FIELD (filep_nt) = NULL; 28 | 29 | // alloc string descriptor and string 30 | SAC_ND_ALLOC__DESC (str_nt, 0) 31 | SAC_ND_SET__RC (str_nt, 1) 32 | SAC_ND_A_FIELD (str_nt) = SAC_MALLOC (length + 1); 33 | 34 | // copy template 35 | strcpy (SAC_ND_A_FIELD (str_nt), template); 36 | 37 | // create temp file, get name back 38 | filedesc = mkstemp (SAC_ND_A_FIELD (str_nt)); 39 | 40 | if (filedesc == -1) { 41 | error = EIO; 42 | } 43 | else { 44 | SAC_ND_A_FIELD (filep_nt) = fdopen( filedesc, "w+"); 45 | if (SAC_ND_A_FIELD (filep_nt) == NULL) { 46 | error = errno; 47 | } 48 | } 49 | 50 | SAC_ND_RET_out__NODESC (filep_nt, filep_nt) 51 | SAC_ND_RET_out (str_nt, str_nt) 52 | 53 | // return the error 54 | return error; 55 | } 56 | 57 | #undef res_nt 58 | #undef str_nt 59 | #undef filep_nt 60 | -------------------------------------------------------------------------------- /src/stdio/src/FibreIO/ScanIntArr.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of standard module FibreScan 3 | */ 4 | 5 | 6 | #include "FibreScan.h" 7 | #include "FibreScan.tab.h" 8 | 9 | 10 | #define array_nt (array, T_OLD((AUD, (NHD, (NUQ, ))))) 11 | #define ret_nt (ret, T_OLD((AUD, (NHD, (NUQ, ))))) 12 | 13 | void FibreScanIntArray( SAC_ND_PARAM_out( array_nt, int), FILE *stream) 14 | { 15 | SAC_ND_DECL__DATA( ret_nt, int, ) 16 | SAC_ND_DECL__DESC( ret_nt, ) 17 | int i; 18 | start_token = PARSE_INT_ARRAY; 19 | doScan( stream); 20 | int SAC_ND_A_MIRROR_DIM( ret_nt) = dims; 21 | SAC_ND_ALLOC__DESC( ret_nt, dims) 22 | SAC_ND_SET__RC( ret_nt, 1) 23 | for( i = 0; i < dims; i++) { 24 | SAC_ND_A_DESC_SHAPE( ret_nt, i) = shape[i]; 25 | } 26 | SAC_ND_A_DESC_SIZE( ret_nt) = size; 27 | SAC_ND_A_FIELD( ret_nt) = intarray; 28 | SAC_ND_RET_out( array_nt, ret_nt) 29 | } 30 | 31 | #undef array_nt 32 | #undef ret_nt 33 | 34 | #define array_nt (array, T_OLD((AUD, (NHD, (NUQ, ))))) 35 | #define ret_nt (ret, T_OLD((AUD, (NHD, (NUQ, ))))) 36 | 37 | void FibreScanIntArrayStr( SAC_ND_PARAM_out( array_nt, int), char *stream) 38 | { 39 | SAC_ND_DECL__DATA( ret_nt, int, ) 40 | SAC_ND_DECL__DESC( ret_nt, ) 41 | int i; 42 | start_token = PARSE_INT_ARRAY; 43 | yy_scan_string( stream); 44 | FibreScanparse(); 45 | int SAC_ND_A_MIRROR_DIM( ret_nt) = dims; 46 | SAC_ND_ALLOC__DESC( ret_nt, dims) 47 | SAC_ND_SET__RC( ret_nt, 1) 48 | for( i = 0; i < dims; i++) { 49 | SAC_ND_A_DESC_SHAPE( ret_nt, i) = shape[i]; 50 | } 51 | SAC_ND_A_DESC_SIZE( ret_nt) = size; 52 | SAC_ND_A_FIELD( ret_nt) = intarray; 53 | SAC_ND_RET_out( array_nt, ret_nt) 54 | } 55 | 56 | #undef array_nt 57 | #undef ret_nt 58 | 59 | -------------------------------------------------------------------------------- /src/system/Process.sac: -------------------------------------------------------------------------------- 1 | #pragma safe 2 | module Process; 3 | 4 | use File: { File }; 5 | use FileSystem: { TheFileSystem }; 6 | use String: { string }; 7 | use SysErr: { syserr }; 8 | 9 | export all; 10 | 11 | /****************************************************************************** 12 | * 13 | * Functions to open and close processes. 14 | * 15 | ******************************************************************************/ 16 | 17 | external syserr, File popen(string COMMAND, string MODE); 18 | #pragma effect TheFileSystem 19 | #pragma linkobj "src/Process/process.o" 20 | #pragma linkname "SACpopen" 21 | #pragma linksign [0,1,2,3] 22 | /* 23 | * Open the process COMMAND in mode MODE. The modes supported are identical 24 | * to the C version of this function. An error condition and a process 25 | * handle are returned. You should inspect the error condition before 26 | * using the process handle. The process handle must be closed by pclose. 27 | */ 28 | 29 | external void pclose(File STREAM); 30 | #pragma effect TheFileSystem 31 | #pragma linkobj "src/Process/pclose.o" 32 | #pragma linkname "SACpclose" 33 | /* 34 | * Close the process stream given by the process handle STREAM. 35 | */ 36 | 37 | external int system(string COMMAND); 38 | #pragma effect TheFileSystem 39 | #pragma linkobj "src/Process/system.o" 40 | #pragma linkname "SACsystem" 41 | #pragma linksign [0,1] 42 | /* 43 | * Execute COMMAND by calling: /bin/sh -c COMMAND 44 | * and wait until the command has completed execution. 45 | * The exit status is -1 on error. 46 | * This function is identical to the one from the C library. 47 | */ 48 | -------------------------------------------------------------------------------- /src/stdio/src/FibreIO/ScanFltArr.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of standard module FibreScan 3 | */ 4 | 5 | 6 | #include "FibreScan.h" 7 | #include "FibreScan.tab.h" 8 | 9 | 10 | #define array_nt (array, T_OLD((AUD, (NHD, (NUQ, ))))) 11 | #define ret_nt (ret, T_OLD((AUD, (NHD, (NUQ, ))))) 12 | 13 | void FibreScanFloatArray( SAC_ND_PARAM_out( array_nt, float), FILE *stream) 14 | { 15 | SAC_ND_DECL__DATA( ret_nt, float, ) 16 | SAC_ND_DECL__DESC( ret_nt, ) 17 | int i; 18 | start_token = PARSE_FLOAT_ARRAY; 19 | doScan( stream); 20 | int SAC_ND_A_MIRROR_DIM( ret_nt) = dims; 21 | SAC_ND_ALLOC__DESC( ret_nt, dims) 22 | SAC_ND_SET__RC( ret_nt, 1) 23 | for( i = 0; i < dims; i++) { 24 | SAC_ND_A_DESC_SHAPE( ret_nt, i) = shape[i]; 25 | } 26 | SAC_ND_A_DESC_SIZE( ret_nt) = size; 27 | SAC_ND_A_FIELD( ret_nt) = floatarray; 28 | SAC_ND_RET_out( array_nt, ret_nt) 29 | } 30 | 31 | #undef array_nt 32 | #undef ret_nt 33 | 34 | #define array_nt (array, T_OLD((AUD, (NHD, (NUQ, ))))) 35 | #define ret_nt (ret, T_OLD((AUD, (NHD, (NUQ, ))))) 36 | 37 | void FibreScanFloatArrayStr( SAC_ND_PARAM_out( array_nt, float), char *stream) 38 | { 39 | SAC_ND_DECL__DATA( ret_nt, float, ) 40 | SAC_ND_DECL__DESC( ret_nt, ) 41 | int i; 42 | start_token = PARSE_FLOAT_ARRAY; 43 | yy_scan_string( stream); 44 | FibreScanparse(); 45 | int SAC_ND_A_MIRROR_DIM( ret_nt) = dims; 46 | SAC_ND_ALLOC__DESC( ret_nt, dims) 47 | SAC_ND_SET__RC( ret_nt, 1) 48 | for( i = 0; i < dims; i++) { 49 | SAC_ND_A_DESC_SHAPE( ret_nt, i) = shape[i]; 50 | } 51 | SAC_ND_A_DESC_SIZE( ret_nt) = size; 52 | SAC_ND_A_FIELD( ret_nt) = floatarray; 53 | SAC_ND_RET_out( array_nt, ret_nt) 54 | } 55 | 56 | #undef array_nt 57 | #undef ret_nt 58 | -------------------------------------------------------------------------------- /src/stdio/src/FibreIO/ScanDblArr.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of standard module FibreScan 3 | */ 4 | 5 | 6 | #include "FibreScan.h" 7 | #include "FibreScan.tab.h" 8 | 9 | 10 | 11 | #define array_nt (array, T_OLD((AUD, (NHD, (NUQ, ))))) 12 | #define ret_nt (ret, T_OLD((AUD, (NHD, (NUQ, ))))) 13 | 14 | void FibreScanDoubleArray( SAC_ND_PARAM_out( array_nt, double), FILE *stream) 15 | { 16 | SAC_ND_DECL__DATA( ret_nt, double, ) 17 | SAC_ND_DECL__DESC( ret_nt, ) 18 | int i; 19 | start_token = PARSE_DOUBLE_ARRAY; 20 | doScan( stream); 21 | int SAC_ND_A_MIRROR_DIM( ret_nt) = dims; 22 | SAC_ND_ALLOC__DESC( ret_nt, dims) 23 | SAC_ND_SET__RC( ret_nt, 1) 24 | for( i = 0; i < dims; i++) { 25 | SAC_ND_A_DESC_SHAPE( ret_nt, i) = shape[i]; 26 | } 27 | SAC_ND_A_DESC_SIZE( ret_nt) = size; 28 | SAC_ND_A_FIELD( ret_nt) = doublearray; 29 | SAC_ND_RET_out( array_nt, ret_nt) 30 | } 31 | 32 | #undef array_nt 33 | #undef ret_nt 34 | 35 | #define array_nt (array, T_OLD((AUD, (NHD, (NUQ, ))))) 36 | #define ret_nt (ret, T_OLD((AUD, (NHD, (NUQ, ))))) 37 | 38 | void FibreScanDoubleArrayStr( SAC_ND_PARAM_out( array_nt, double), char *stream) 39 | { 40 | SAC_ND_DECL__DATA( ret_nt, double, ) 41 | SAC_ND_DECL__DESC( ret_nt, ) 42 | int i; 43 | start_token = PARSE_DOUBLE_ARRAY; 44 | yy_scan_string( stream); 45 | FibreScanparse(); 46 | int SAC_ND_A_MIRROR_DIM( ret_nt) = dims; 47 | SAC_ND_ALLOC__DESC( ret_nt, dims) 48 | SAC_ND_SET__RC( ret_nt, 1) 49 | for( i = 0; i < dims; i++) { 50 | SAC_ND_A_DESC_SHAPE( ret_nt, i) = shape[i]; 51 | } 52 | SAC_ND_A_DESC_SIZE( ret_nt) = size; 53 | SAC_ND_A_FIELD( ret_nt) = doublearray; 54 | SAC_ND_RET_out( array_nt, ret_nt) 55 | } 56 | 57 | #undef array_nt 58 | #undef ret_nt 59 | -------------------------------------------------------------------------------- /src/system/src/MTClock/mtclock.c: -------------------------------------------------------------------------------- 1 | /****************************************************************************** 2 | * 3 | * @file mtclock.c 4 | * 5 | * @brief This module implements the functionally sound integration of the 6 | * monotonic time clock into the world of SAC. 7 | * 8 | ******************************************************************************/ 9 | #include 10 | #ifdef __MACH__ 11 | #include 12 | #include 13 | #endif 14 | 15 | void *SAC_MTClock_createTheMTClock(void) 16 | { 17 | return((void*)0); 18 | } 19 | 20 | void SAC_MTClock_touch(void *mtclock) 21 | { 22 | /* noop */ 23 | } 24 | 25 | void SAC_MTClock_gettime(long *sec, long *nsec) 26 | { 27 | struct timespec result; 28 | 29 | #ifdef __MACH__ 30 | // OS X does not have clock_gettime, use clock_get_time. 31 | clock_serv_t cclock; 32 | mach_timespec_t mts; 33 | host_get_clock_service(mach_host_self(), SYSTEM_CLOCK, &cclock); 34 | clock_get_time(cclock, &mts); 35 | mach_port_deallocate(mach_task_self(), cclock); 36 | result.tv_sec = mts.tv_sec; 37 | result.tv_nsec = mts.tv_nsec; 38 | #else 39 | /* Using the raw monotonic clock because the latter is NOT influenced by 40 | * changes to system time (be it via an admin changing the time of the 41 | * system or NTP updating the time). 42 | * If however the raw monotonic clock is not available, we default to using 43 | * the regular monotonic clock - which can be influenced by NTP and the 44 | * like. */ 45 | # ifndef CLOCK_MONOTONIC_RAW 46 | clock_gettime(CLOCK_MONOTONIC, &result); 47 | # else 48 | clock_gettime(CLOCK_MONOTONIC_RAW, &result); 49 | # endif 50 | #endif 51 | 52 | *sec = result.tv_sec; 53 | *nsec = result.tv_nsec; 54 | } 55 | -------------------------------------------------------------------------------- /src/structures/src/Char/ctype.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of standard module Char ctype functions. 3 | * It is sort of unfortunate that we have to use these 4 | * functions as they incur a per-character overhead. 5 | * However, without them incorrect values were produced. 6 | * There were two problems: 7 | * The isxxx(.) functions work on unsigned chars and not on chars. 8 | * They may segfault when not in the range [-1,255]. 9 | * They may return any non-zero value when true, but a SAC bool is true if 1. 10 | */ 11 | 12 | #include 13 | 14 | typedef unsigned char uchar; 15 | 16 | int SACisalpha(uchar c) 17 | { 18 | return isalpha(c) != 0; 19 | } 20 | 21 | int SACisupper(uchar c) 22 | { 23 | return isupper(c) != 0; 24 | } 25 | 26 | int SACislower(uchar c) 27 | { 28 | return islower(c) != 0; 29 | } 30 | 31 | int SACisdigit(uchar c) 32 | { 33 | return isdigit(c) != 0; 34 | } 35 | 36 | int SACisxdigit(uchar c) 37 | { 38 | return isxdigit(c) != 0; 39 | } 40 | 41 | int SACisspace(uchar c) 42 | { 43 | return isspace(c) != 0; 44 | } 45 | 46 | int SACispunct(uchar c) 47 | { 48 | return ispunct(c) != 0; 49 | } 50 | 51 | int SACisalnum(uchar c) 52 | { 53 | return isalnum(c) != 0; 54 | } 55 | 56 | int SACisprint(uchar c) 57 | { 58 | return isprint(c) != 0; 59 | } 60 | 61 | int SACisgraph(uchar c) 62 | { 63 | return isgraph(c) != 0; 64 | } 65 | 66 | int SACiscntrl(uchar c) 67 | { 68 | return iscntrl(c) != 0; 69 | } 70 | 71 | int SACisascii(int c) 72 | { 73 | return c >= 0 && c < 256 && isascii(c) != 0; 74 | } 75 | 76 | int SACtoascii(int c) 77 | { 78 | return toascii(c & 0xFF); 79 | } 80 | 81 | int SACtolower(uchar c) 82 | { 83 | return tolower(c); 84 | } 85 | 86 | int SACtoupper(uchar c) 87 | { 88 | return toupper(c); 89 | } 90 | 91 | -------------------------------------------------------------------------------- /src/utrace/Indent.sac: -------------------------------------------------------------------------------- 1 | class Indent; 2 | 3 | classtype int; 4 | 5 | /****************************************************************************** 6 | * 7 | * Depends on String and TermFile. 8 | * 9 | ******************************************************************************/ 10 | 11 | use String: { string, strlen, tochar, to_string }; 12 | use TermFile: { printf }; 13 | 14 | export all; 15 | 16 | objdef Indent indent = to_Indent(0); 17 | 18 | Indent newIndent(int value) 19 | { 20 | return to_Indent(value); 21 | } 22 | 23 | int getIndent() 24 | { 25 | return getIndent(indent); 26 | } 27 | 28 | int getIndent(Indent &i) 29 | { 30 | val = from_Indent(i); 31 | i = to_Indent(val); 32 | return val; 33 | } 34 | 35 | void setIndent(Indent &i, int val) 36 | { 37 | i = to_Indent(val); 38 | } 39 | 40 | void doIndent(string pattern) 41 | { 42 | doIndent(indent, pattern); 43 | } 44 | 45 | void doIndent(Indent &i, string pattern) 46 | { 47 | val = getIndent(i); 48 | indents = _reshape_VxA_([_mul_SxS_(strlen(pattern), val)], 49 | { iv -> tochar(pattern) | iv < [val] }); 50 | printf(to_string(indents)); 51 | } 52 | 53 | void incIndent(Indent &i) 54 | { 55 | val = from_Indent(i); 56 | i = to_Indent(_add_SxS_(val, 1)); 57 | } 58 | 59 | void incIndent(Indent &i, int offset) 60 | { 61 | val = from_Indent(i); 62 | i = to_Indent(_add_SxS_(val, offset)); 63 | } 64 | 65 | void incIndent() 66 | { 67 | incIndent(indent); 68 | } 69 | 70 | void decIndent(Indent &i) 71 | { 72 | val = from_Indent(i); 73 | i = to_Indent(_sub_SxS_(val, 1)); 74 | } 75 | 76 | void decIndent(Indent &i, int offset) 77 | { 78 | val = from_Indent(i); 79 | i = to_Indent(_sub_SxS_(val, offset)); 80 | } 81 | 82 | void decIndent() 83 | { 84 | decIndent(indent); 85 | } 86 | -------------------------------------------------------------------------------- /src/system/CommandLine.sac: -------------------------------------------------------------------------------- 1 | #pragma safe 2 | class CommandLine; 3 | 4 | external classtype; 5 | 6 | use String: { string }; 7 | 8 | export all; 9 | 10 | objdef CommandLine TheCommandLine = create_TheCommandLine(); 11 | 12 | /****************************************************************************** 13 | * 14 | * The global object TheCommandLine of class CommandLine serves as a 15 | * representation of the shell command used for starting program execution. 16 | * It is derived from the global object TheWorld in order to represent this 17 | * part or sub-world of the execution environment. 18 | * 19 | * These functions provide access to the shell command by which 20 | * a program has been started. 21 | * 22 | * - argc() Returns the number of command line parameters, 23 | * including the program's name itself. 24 | * 25 | * - argv() Returns the entire command line. 26 | * 27 | * - argv(n) Returns the nth command line parameter. 28 | * Remember that argv(0) returns the program's name itself. 29 | * 30 | ******************************************************************************/ 31 | 32 | external CommandLine create_TheCommandLine(); 33 | #pragma effect World::TheWorld 34 | #pragma linkobj "src/CommandLine/CommandLine.o" 35 | #pragma linksign [0] 36 | 37 | external int argc(); 38 | #pragma effect TheCommandLine 39 | #pragma linkobj "src/CommandLine/CommandLine.o" 40 | #pragma linkname "SACargc" 41 | #pragma linksign [0] 42 | 43 | external string argv(); 44 | #pragma effect TheCommandLine 45 | #pragma linkobj "src/CommandLine/CommandLine.o" 46 | #pragma linkname "SACargvall" 47 | #pragma linksign [0] 48 | 49 | external string argv(int N); 50 | #pragma effect TheCommandLine 51 | #pragma linkobj "src/CommandLine/CommandLine.o" 52 | #pragma linkname "SACargv" 53 | #pragma linksign [0,1] 54 | -------------------------------------------------------------------------------- /scripts/debug.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | if [ "$#" -ne 1 ]; then 4 | printf "Usage: %s SAC2C_FILE\n" "$0" >&2 5 | printf "\tSAC2C_FILE: .sac2c file created by sac2c option -dcccall\n\n" >&2 6 | printf "\tThis is for debugging parts of stdlib using gdb.\n" >&2 7 | printf "\tBuild stdlib with VERBOSE=1 in the environment, and copy\n" >&2 8 | printf "\tthe command compiling the relevant module.\n" >&2 9 | printf "\tThen add -dcccall to the compile command.\n" >&2 10 | printf "\tThis will create a sac2c file in that directory, which you.\n" >&2 11 | printf "\tpass as argument to this script.\n" >&2 12 | printf "\tgdb will then give line numbers for readable generated code.\n" >&2 13 | exit 14 | fi 15 | 16 | hash clang-format || exit 17 | 18 | # We store our source files preinstead of in /tmp 19 | mkdir -p source_files 20 | 21 | # Copy the .c files from tmp to source_files 22 | grep -E -oh "/tmp/[^/]*/[^.]*\.c" "$1" | xargs cp -t ./source_files 23 | 24 | # Create the command to run the preprocessor storing the output in source_files 25 | sed -i -E 's/\/tmp\/[^/]*\/([^.]*\.i)/\.\/source_files\/\1/g' "$1" 26 | 27 | # Run the preprocessor command 28 | grep "\-E" "$1" | sh 29 | 30 | # Format the .i files 31 | format_in_place() 32 | { 33 | temp=$(mktemp) 34 | 35 | grep -v "#" "$1" | clang-format > "$temp" 36 | mv "$temp" "$1" 37 | } 38 | 39 | for file in ./source_files/* 40 | do 41 | format_in_place "$file" 42 | done 43 | 44 | # Delete the preprocessing commands from the .sac2c-file 45 | sed -i '/-E/d' "$1" 46 | 47 | # Create the command to make sure gdb uses the .i file and not .c 48 | sed -i 's/\/usr\/bin\/cc/\/usr\/bin\/cc\ -no-integrated-cpp -P/g' "$1" 49 | 50 | # Compile the objects files 51 | grep "\-c" "$1" | sh 52 | 53 | # Delete those commands from the .sac2c-file 54 | sed -i '/-c\ /d' "$1" 55 | 56 | # Run the remaining commands (making directories and linking) 57 | sh < "$1" 58 | -------------------------------------------------------------------------------- /src/system/src/FileSystem/dir.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class FileSystem 3 | */ 4 | 5 | 6 | 7 | #include "FileSystem.h" 8 | 9 | 10 | 11 | /*****************************************************************/ 12 | 13 | char *SACgetcwd( void) 14 | { 15 | char *res; 16 | int size=100; 17 | char *success; 18 | 19 | res=(char *)SAC_MALLOC(size); 20 | 21 | success=getcwd(res, size); 22 | 23 | while (success!=NULL) 24 | { 25 | size*=2; 26 | SAC_FREE(res); 27 | res=(char *)SAC_MALLOC(size); 28 | success=getcwd(res, size); 29 | } 30 | 31 | return(res); 32 | } 33 | 34 | 35 | 36 | /*****************************************************************/ 37 | 38 | int SACchdir(char *name) 39 | { 40 | int success; 41 | 42 | success=chdir(name); 43 | 44 | if (success==-1) 45 | { 46 | success=errno; 47 | } 48 | else 49 | { 50 | success=-1; 51 | } 52 | 53 | return(success); 54 | } 55 | 56 | 57 | /*****************************************************************/ 58 | 59 | 60 | int SACmkdir(char *name) 61 | { 62 | int success; 63 | mode_t mask; 64 | 65 | mask=umask(0); 66 | umask(mask); 67 | 68 | success=mkdir(name, mask); 69 | 70 | if (success==-1) 71 | { 72 | success=errno; 73 | } 74 | else 75 | { 76 | success=-1; 77 | } 78 | 79 | return(success); 80 | } 81 | 82 | 83 | /*****************************************************************/ 84 | 85 | 86 | int SACrmdir(char *name) 87 | { 88 | int success; 89 | 90 | success=rmdir(name); 91 | 92 | if (success==-1) 93 | { 94 | success=errno; 95 | } 96 | else 97 | { 98 | success=-1; 99 | } 100 | 101 | return(success); 102 | } 103 | 104 | 105 | 106 | /*****************************************************************/ 107 | 108 | 109 | 110 | -------------------------------------------------------------------------------- /cmake/parse-core-ext-files.cmake: -------------------------------------------------------------------------------- 1 | # This file contains a function that parses a file with the 2 | # description of sac filea belonging either to Core or to 3 | # Ext build of the standard library. 4 | 5 | FUNCTION (PARSE_CORE_EXT_CONFIG fname core_sac ext_sac core_xsac ext_xsac) 6 | SET (score) 7 | SET (sext) 8 | SET (xcore) 9 | SET (xext) 10 | 11 | 12 | FILE (READ ${fname} content) 13 | STRING (REPLACE "\n" ";" lines ${content}) 14 | 15 | FOREACH (l ${lines}) 16 | # Get rid of comments 17 | STRING (REGEX REPLACE "#.*$" "" l "${l}") 18 | 19 | # Get rid of spaces 20 | STRING (REGEX REPLACE "^[ \t]+" "" l "${l}") 21 | STRING (REGEX REPLACE "[ \t]+$" "" l "${l}") 22 | 23 | IF ("${l}" STREQUAL "") 24 | CONTINUE () 25 | ENDIF () 26 | 27 | # Parse the filename and the type 28 | STRING (REGEX MATCH "([a-zA-Z0-9_\.-/]+)(\.x?sac)[ \t]+(Core|Ext)" l_match ${l}) 29 | IF (NOT l_match) 30 | MESSAGE (FATAL_ERROR "error while parsing file `${fname}':\n${l}") 31 | ENDIF () 32 | 33 | SET (name "${CMAKE_MATCH_1}${CMAKE_MATCH_2}") 34 | SET (ext "${CMAKE_MATCH_2}") 35 | SET (type "${CMAKE_MATCH_3}") 36 | 37 | 38 | IF ("${type}" STREQUAL "Ext") 39 | IF ("${ext}" STREQUAL ".sac") 40 | LIST (APPEND sext "${name}") 41 | ELSE () 42 | LIST (APPEND xext "${name}") 43 | ENDIF () 44 | ELSE () 45 | IF ("${ext}" STREQUAL ".sac") 46 | LIST (APPEND score "${name}") 47 | ELSE () 48 | LIST (APPEND xcore "${name}") 49 | ENDIF () 50 | ENDIF () 51 | 52 | SET (${core_sac} ${score} PARENT_SCOPE) 53 | SET (${core_xsac} ${xcore} PARENT_SCOPE) 54 | SET (${ext_sac} ${sext} PARENT_SCOPE) 55 | SET (${ext_xsac} ${xext} PARENT_SCOPE) 56 | ENDFOREACH () 57 | ENDFUNCTION () 58 | -------------------------------------------------------------------------------- /src/random/xoshiro128p.sage: -------------------------------------------------------------------------------- 1 | # We precompute tables that we can use to jump ahead 2^k * 2^96 states in O(1). 2 | # By precomputing this for k = 0, ..., 31, we can jump ahead int l states in 3 | # O(log(l)). 4 | # 5 | # The theory is based on 6 | # 1. Efficient Jump Ahead for F2-Linear Random Number Generators 7 | # 2. Scrambled Linear Pseudorandom Number Generators 8 | 9 | def rotate(b): 10 | R = matrix(GF(2), 32) 11 | for i in range(32): 12 | R[mod(i + b, 32), i] = 1 13 | return R 14 | 15 | def shift(a): 16 | S = matrix(GF(2), 32) 17 | for i in range(32 - a): 18 | S[i + a, i] = 1 19 | return S 20 | 21 | I = matrix.identity(n = 32, ring = GF(2)) 22 | R = rotate(11) 23 | S = shift(9) 24 | O = matrix(GF(2), 32) 25 | 26 | xoshiro128p = block_matrix([[I, I, I, O], 27 | [I, I, S, R], 28 | [O, I, I, O], 29 | [I, O, O, R]]) 30 | 31 | p = xoshiro128p.charpoly() 32 | 33 | ring = PolynomialRing(GF(2), 'x') 34 | qring = ring.quotient(p, 'a') 35 | a = qring.gen() 36 | 37 | # Packs coefficients of polynomial q in a hex string, 38 | # with the degree-0 coefficient on the right. 39 | def pack_hex(q, degree): 40 | # length degree + 1 41 | coeff = q.list() 42 | num = 0 43 | for b in range(degree + 1): 44 | if (q[b] == 1): 45 | num += 2^b 46 | return format(num, '032x') 47 | 48 | print("jump = [") 49 | for k in range(32): 50 | q = a^(2^(k) * 2^(96)) 51 | # Polynomials in quotient rings apparently have no degree 52 | coeff = pack_hex(q, 127) 53 | four_coeff = [coeff[i: i + 8] for i in range(0, 32, 8)] 54 | # Have to reverse because xoshiro implementation walks through these 55 | # backwards. 56 | print("[0x" , four_coeff[3], 57 | "u, 0x", four_coeff[2], 58 | "u, 0x", four_coeff[1], 59 | "u, 0x", four_coeff[0], 60 | "u]", 61 | "" if k == 31 else ",", 62 | sep = "") 63 | print("];") 64 | -------------------------------------------------------------------------------- /src/random/xoshiro256p.sage: -------------------------------------------------------------------------------- 1 | # We precompute tables that we can use to jump ahead 2^k * 2^192 states in O(1). 2 | # By precomputing this for k = 0, ..., 31, we can jump ahead int l states in 3 | # O(log(l)). 4 | # 5 | # The theory is based on 6 | # 1. Efficient Jump Ahead for F2-Linear Random Number Generators 7 | # 2. Scrambled Linear Pseudorandom Number Generators 8 | 9 | def rotate(b): 10 | R = matrix(GF(2), 64) 11 | for i in range(64): 12 | R[mod(i + b, 64), i] = 1 13 | return R 14 | 15 | def shift(a): 16 | S = matrix(GF(2), 64) 17 | for i in range(64 - a): 18 | S[i + a, i] = 1 19 | return S 20 | 21 | I = matrix.identity(n = 64, ring = GF(2)) 22 | R = rotate(45) 23 | S = shift(17) 24 | O = matrix(GF(2), 64) 25 | 26 | xoshiro256p = block_matrix([[I, I, I, O], 27 | [I, I, S, R], 28 | [O, I, I, O], 29 | [I, O, O, R]]) 30 | 31 | p = xoshiro256p.charpoly() 32 | 33 | ring = PolynomialRing(GF(2), 'x') 34 | qring = ring.quotient(p, 'a') 35 | a = qring.gen() 36 | 37 | # Packs coefficients of polynomial q in a hex string, 38 | # with the degree-0 coefficient on the right. 39 | def pack_hex(q, degree): 40 | # length degree + 1 41 | coeff = q.list() 42 | num = 0 43 | for b in range(degree + 1): 44 | if (q[b] == 1): 45 | num += 2^b 46 | return format(num, '064x') 47 | 48 | print("jump = [") 49 | for k in range(32): 50 | q = a^(2^(k) * 2^(192)) 51 | # Polynomials in quotient rings apparently have no degree 52 | coeff = pack_hex(q, 255) 53 | four_coeff = [coeff[i: i + 16] for i in range(0, 64, 16)] 54 | # The xoshiro implementation traverses the coefficients back to front, 55 | # so have to reverse. 56 | print("[0x" , four_coeff[3], 57 | "ul, 0x", four_coeff[2], 58 | "ul, 0x", four_coeff[1], 59 | "ul, 0x", four_coeff[0], 60 | "ul]", 61 | "" if k == 31 else ",", 62 | sep = "") 63 | print("];") 64 | -------------------------------------------------------------------------------- /src/structures/src/String/strovwt.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of standard module StringC 3 | */ 4 | 5 | 6 | #include "StringC.h" 7 | 8 | 9 | /*****************************************************************/ 10 | 11 | #define new_nt (new, T_OLD((SCL, (HID, (NUQ,))))) 12 | #define old_nt (old, T_OLD((SCL, (HID, (NUQ,))))) 13 | 14 | void strovwt( SAC_ND_PARAM_out( new_nt, string), 15 | SAC_ND_PARAM_in( old_nt, string), 16 | int pos, string insert) 17 | { 18 | SAC_ND_DECL__DESC( new_nt, ) 19 | SAC_ND_DECL__DATA( new_nt, string, ) 20 | int len_old = strlen( SAC_ND_A_FIELD( old_nt)); 21 | int len_insert = strlen( insert); 22 | int len_insert_pos = len_insert+pos; 23 | char store; 24 | 25 | RANGECHECK( (size_t)pos, 0, strlen( SAC_ND_A_FIELD( old_nt)), 26 | SAC_ND_A_FIELD( old_nt)); 27 | 28 | if (len_insert_pos <= len_old) { 29 | store = SAC_ND_A_FIELD( old_nt)[len_insert_pos]; 30 | 31 | if (SAC_ND_A_RC( old_nt) == 1) { 32 | SAC_ND_A_DESC( new_nt) = SAC_ND_A_DESC( old_nt); 33 | SAC_ND_A_FIELD( new_nt) = SAC_ND_A_FIELD( old_nt); 34 | strcpy( SAC_ND_A_FIELD( new_nt) + pos, insert); 35 | } 36 | else { 37 | SAC_ND_ALLOC__DESC( new_nt, 0) 38 | SAC_ND_SET__RC( new_nt, 1) 39 | STRDUP( SAC_ND_A_FIELD( new_nt), SAC_ND_A_FIELD( old_nt)); 40 | strcpy( SAC_ND_A_FIELD( new_nt) + pos, insert); 41 | 42 | SAC_ND_DEC_RC_FREE( old_nt, 1, SAC_FREE) 43 | } 44 | SAC_ND_A_FIELD( new_nt)[len_insert_pos] = store; 45 | } 46 | else { 47 | SAC_ND_ALLOC__DESC( new_nt, 0) 48 | SAC_ND_SET__RC( new_nt, 1) 49 | SAC_ND_A_FIELD( new_nt) = (string) SAC_MALLOC( len_insert_pos + 1); 50 | strncpy( SAC_ND_A_FIELD( new_nt), SAC_ND_A_FIELD( old_nt), pos); 51 | SAC_ND_A_FIELD( new_nt)[pos] = '\0'; 52 | 53 | strcat( SAC_ND_A_FIELD( new_nt), insert); 54 | 55 | SAC_ND_DEC_RC_FREE( old_nt, 1, SAC_FREE) 56 | } 57 | 58 | SAC_ND_RET_out( new_nt, new_nt) 59 | } 60 | 61 | #undef new_nt 62 | #undef old_nt 63 | 64 | /*****************************************************************/ 65 | -------------------------------------------------------------------------------- /src/system/src/FileSystem/testfile.c: -------------------------------------------------------------------------------- 1 | /* 2 | * implementation of class FileSystem 3 | */ 4 | 5 | 6 | 7 | #include "FileSystem.h" 8 | 9 | 10 | 11 | /*****************************************************************/ 12 | 13 | int SACisdir(int *success, char *name) 14 | { 15 | struct stat buf; 16 | int result = 0; 17 | 18 | *success = stat(name, &buf); 19 | 20 | if (*success == -1) 21 | { 22 | *success = errno; 23 | } 24 | else 25 | { 26 | *success = -1; 27 | result = S_ISDIR(buf.st_mode); 28 | } 29 | 30 | return (result); 31 | } 32 | 33 | 34 | /*****************************************************************/ 35 | 36 | int SACisreg(int *success, char *name) 37 | { 38 | struct stat buf; 39 | int result = 0; 40 | 41 | *success = stat(name, &buf); 42 | 43 | if (*success == -1) 44 | { 45 | *success = errno; 46 | } 47 | else 48 | { 49 | *success = -1; 50 | result = S_ISREG(buf.st_mode); 51 | } 52 | 53 | return (result); 54 | } 55 | 56 | 57 | 58 | /*****************************************************************/ 59 | 60 | int SACislnk(int *success, char *name) 61 | { 62 | struct stat buf; 63 | int result = 0; 64 | 65 | *success = stat(name, &buf); 66 | 67 | if (*success == -1) 68 | { 69 | *success = errno; 70 | } 71 | else 72 | { 73 | *success = -1; 74 | result = S_ISLNK(buf.st_mode); 75 | } 76 | 77 | return (result); 78 | } 79 | 80 | 81 | 82 | /*****************************************************************/ 83 | 84 | unsigned long long SACfilesize(int *success, char *name) 85 | { 86 | struct stat buf; 87 | unsigned long long result = 0; 88 | 89 | *success = stat(name, &buf); 90 | 91 | if (*success == -1) 92 | { 93 | *success = errno; 94 | } 95 | else 96 | { 97 | *success = -1; 98 | result = (unsigned long long) buf.st_size; 99 | } 100 | 101 | return (result); 102 | } 103 | 104 | 105 | 106 | /*****************************************************************/ 107 | -------------------------------------------------------------------------------- /src/system/src/Clock/extracttime.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of standard module Time 3 | */ 4 | 5 | 6 | 7 | #include "Clock.h" 8 | 9 | /******************************************************************/ 10 | 11 | 12 | int SACsec(time_t *t) 13 | { 14 | struct tm *tt; 15 | 16 | tt=localtime(t); 17 | 18 | return(tt->tm_sec); 19 | } 20 | 21 | 22 | /******************************************************************/ 23 | 24 | 25 | int SACmin(time_t *t) 26 | { 27 | struct tm *tt; 28 | 29 | tt=localtime(t); 30 | 31 | return(tt->tm_min); 32 | } 33 | 34 | 35 | /******************************************************************/ 36 | 37 | 38 | int SAChour(time_t *t) 39 | { 40 | struct tm *tt; 41 | 42 | tt=localtime(t); 43 | 44 | return(tt->tm_hour); 45 | } 46 | 47 | 48 | /******************************************************************/ 49 | 50 | 51 | int SACmday(time_t *t) 52 | { 53 | struct tm *tt; 54 | 55 | tt=localtime(t); 56 | 57 | return(tt->tm_mday); 58 | } 59 | 60 | 61 | /******************************************************************/ 62 | 63 | 64 | int SACmon(time_t *t) 65 | { 66 | struct tm *tt; 67 | 68 | tt=localtime(t); 69 | 70 | return(tt->tm_mon); 71 | } 72 | 73 | 74 | 75 | /******************************************************************/ 76 | 77 | 78 | int SACyear(time_t *t) 79 | { 80 | struct tm *tt; 81 | 82 | tt=localtime(t); 83 | 84 | return(tt->tm_year); 85 | } 86 | 87 | 88 | 89 | /******************************************************************/ 90 | 91 | 92 | int SACwday(time_t *t) 93 | { 94 | struct tm *tt; 95 | 96 | tt=localtime(t); 97 | 98 | return(tt->tm_wday); 99 | } 100 | 101 | 102 | 103 | /******************************************************************/ 104 | 105 | 106 | int SACyday(time_t *t) 107 | { 108 | struct tm *tt; 109 | 110 | tt=localtime(t); 111 | 112 | return(tt->tm_yday); 113 | } 114 | 115 | 116 | 117 | /******************************************************************/ 118 | 119 | 120 | -------------------------------------------------------------------------------- /src/stdio/src/ArrayIO/ShowArray.c: -------------------------------------------------------------------------------- 1 | /* $Id$ */ 2 | 3 | /* 4 | * Implementation of printing functions for Arrays as used in ArrayIO, 5 | * conforming with ISO Standard APL N8485. 6 | * The show() functions print data only - no rank, shape, or decorators 7 | * 8 | */ 9 | 10 | 11 | #include 12 | #include 13 | #include 14 | 15 | #include "sac.h" 16 | 17 | #define INT 1 18 | #define FLOAT 2 19 | #define DOUBLE 3 20 | #define CHAR 4 21 | #define BOOL 5 22 | 23 | typedef char* string; 24 | 25 | static 26 | void ShowArr(FILE *stream, int typeflag, string fmt, int dim, int * shp, char *a) 27 | { 28 | // Introduce new lines at end of ultimate and penultimate dimensions 29 | int i, element_count; 30 | int rownum, colnum, planenum; 31 | int rownums, colnums, planenums; 32 | int rowoffset = 0; 33 | 34 | planenums = 1; 35 | for (i=0;i<(dim-2);i++) { 36 | planenums = planenums * shp[i]; 37 | } 38 | 39 | 40 | if( 0 == dim) { // show scalar 41 | fprintf(stream, fmt, a[0]); 42 | fprintf(stream, "\n"); // End row with new line 43 | } else { 44 | colnums = shp[dim-1]; 45 | if (dim >= 2) { // row count for matrix and tensor 46 | rownums = shp[dim-2]; 47 | } else { 48 | rownums = 1; // vector row count 49 | } 50 | 51 | element_count = planenums * colnums * rownums; 52 | 53 | if (element_count != 0) { // no output for empty array 54 | for ( planenum=0; planenum 7 | #include "StringC.h" 8 | 9 | 10 | /*****************************************************************/ 11 | 12 | string SACchomp(string in) 13 | { 14 | size_t len = strlen(in); 15 | size_t i; 16 | string out; 17 | 18 | for (i = len; i > 0; ) { 19 | --i; 20 | if (in[i] != '\r' && in[i] != '\n') { 21 | ++i; 22 | break; 23 | } 24 | } 25 | 26 | out = (string) SAC_MALLOC( i + 1); 27 | strncpy(out, in, i); 28 | out[i] = '\0'; 29 | 30 | return out; 31 | } 32 | 33 | /*****************************************************************/ 34 | 35 | string SACrtrim(string in) 36 | { 37 | size_t len = strlen(in); 38 | size_t i; 39 | string out; 40 | 41 | for (i = len; i > 0; ) { 42 | --i; 43 | if (!isspace((unsigned char) in[i])) { 44 | ++i; 45 | break; 46 | } 47 | } 48 | 49 | out = (string) SAC_MALLOC( i + 1); 50 | strncpy(out, in, i); 51 | out[i] = '\0'; 52 | 53 | return out; 54 | } 55 | 56 | /*****************************************************************/ 57 | 58 | string SACltrim(string in) 59 | { 60 | size_t len = strlen(in); 61 | size_t i; 62 | string out; 63 | 64 | for (i = 0; i < len; ++i) { 65 | if (!isspace((unsigned char) in[i])) { 66 | break; 67 | } 68 | } 69 | 70 | out = (string) SAC_MALLOC( len - i + 1); 71 | strncpy(out, in + i, len - i); 72 | out[len - i] = '\0'; 73 | 74 | return out; 75 | } 76 | 77 | /*****************************************************************/ 78 | 79 | string SACtrim(string in) 80 | { 81 | size_t len = strlen(in); 82 | size_t i, j; 83 | string out; 84 | 85 | for (i = len; i > 0; ) { 86 | --i; 87 | if (!isspace((unsigned char) in[i])) { 88 | ++i; 89 | break; 90 | } 91 | } 92 | for (j = 0; j < i; ++j) { 93 | if (!isspace((unsigned char) in[j])) { 94 | break; 95 | } 96 | } 97 | 98 | out = (string) SAC_MALLOC( i - j + 1); 99 | strncpy(out, in + j, i - j); 100 | out[i - j] = '\0'; 101 | 102 | return out; 103 | } 104 | 105 | /*****************************************************************/ 106 | -------------------------------------------------------------------------------- /src/system/Dir.sac: -------------------------------------------------------------------------------- 1 | #pragma safe 2 | class Dir; 3 | 4 | external classtype; 5 | 6 | use FileSystem: { TheFileSystem }; 7 | use String: { string }; 8 | use SysErr: { syserr }; 9 | 10 | export all; 11 | 12 | external syserr, Dir opendir( string NAME); 13 | #pragma effect TheFileSystem 14 | #pragma linksign [0,1,2] 15 | #pragma linkobj "src/Dir/opendir.o" 16 | #pragma linkname "SACopendir" 17 | /* 18 | * Open a directory stream using the directory NAME. 19 | * An error condition and a directory handle are returned. 20 | * You should inspect the error condition using 21 | * either SysErr::fail(.) or SysErr::clear(.) 22 | * before using the directory handle. 23 | */ 24 | 25 | external void closedir( Dir& DIR); 26 | #pragma effect TheFileSystem 27 | #pragma linksign [1] 28 | #pragma linkobj "src/Dir/closedir.o" 29 | #pragma linkname "SACclosedir" 30 | /* 31 | * Close the directory stream DIR. 32 | */ 33 | 34 | external string readdir( Dir& DIR); 35 | #pragma effect TheFileSystem 36 | #pragma linksign [0,1] 37 | #pragma linkobj "src/Dir/readdir.o" 38 | #pragma linkname "SACreaddir" 39 | /* 40 | * Read the next entry from the directory stream DIR. 41 | * Entries for "." and ".." are skipped automatically. 42 | * When the end of the directory stream is encountered 43 | * an empty string is returned. 44 | */ 45 | 46 | external void rewinddir( Dir& DIR); 47 | #pragma effect TheFileSystem 48 | #pragma linksign [1] 49 | #pragma linkobj "src/Dir/rewinddir.o" 50 | #pragma linkname "SACrewinddir" 51 | /* 52 | * Reposition the directory stream DIR to the beginning. 53 | */ 54 | 55 | external long telldir( Dir& DIR); 56 | #pragma effect TheFileSystem 57 | #pragma linksign [0,1] 58 | #pragma linkobj "src/Dir/telldir.o" 59 | #pragma linkname "SACtelldir" 60 | /* 61 | * Return the current position of the directory stream DIR. 62 | * On error -1 is returned. 63 | */ 64 | 65 | external void seekdir( Dir& DIR, long POS); 66 | #pragma effect TheFileSystem 67 | #pragma linksign [1,2] 68 | #pragma linkobj "src/Dir/seekdir.o" 69 | #pragma linkname "SACseekdir" 70 | /* 71 | * Reposition the directory stream DIR to POS. 72 | */ 73 | 74 | -------------------------------------------------------------------------------- /src/numerical/MathArray.sac: -------------------------------------------------------------------------------- 1 | #pragma safe 2 | module MathArray; 3 | 4 | export all except { + }; 5 | 6 | /****************************************************************************** 7 | * 8 | * This module provides float[*] and double[*] variants 9 | * of the math operations from Math.sac. 10 | * 11 | * Namely, these are: 12 | * log, log2, log10, exp, fabs, sqrt, floor, pow 13 | * 14 | ******************************************************************************/ 15 | 16 | #define MAP_A(op, typ) \ 17 | inline typ[d>0:shp] op(typ[d>0:shp] arr) \ 18 | { \ 19 | return { iv -> Math::op(_sel_VxA_(iv, arr)) | iv < shp }; \ 20 | } 21 | 22 | #define MAP_AxS(op, typ) \ 23 | inline typ[d>0:shp] op(typ[d>0:shp] arr, typ x) \ 24 | { \ 25 | return { iv -> Math::op(_sel_VxA_(iv, arr), x) | iv < shp }; \ 26 | } 27 | 28 | #define MAP_REAL(fun, op) \ 29 | fun(op, float) \ 30 | fun(op, double) 31 | 32 | MAP_REAL(MAP_A, log) 33 | MAP_REAL(MAP_A, log2) 34 | MAP_REAL(MAP_A, log10) 35 | MAP_REAL(MAP_A, exp) 36 | MAP_REAL(MAP_A, fabs) 37 | MAP_REAL(MAP_A, sqrt) 38 | MAP_REAL(MAP_A, floor) 39 | MAP_REAL(MAP_AxS, pow) 40 | 41 | /****************************************************************************** 42 | * 43 | * L2-norm 44 | * 45 | ******************************************************************************/ 46 | 47 | inline float +(float a, float b) { return _add_SxS_(a, b); } 48 | inline float l2norm(float[d:shp] a) 49 | { 50 | return Math::sqrt(with { 51 | (_mul_SxV_(0, shp) <= iv < shp) 52 | : _mul_SxS_(_sel_VxA_(iv, a), _sel_VxA_(iv, a)); 53 | } : fold(+, 0f)); 54 | } 55 | 56 | inline double +(double a, double b) { return _add_SxS_(a, b); } 57 | inline double l2norm(double[d:shp] a) 58 | { 59 | return Math::sqrt(with { 60 | (_mul_SxV_(0, shp) <= iv < shp) 61 | : _mul_SxS_(_sel_VxA_(iv, a), _sel_VxA_(iv, a)); 62 | } : fold(+, 0d)); 63 | } 64 | -------------------------------------------------------------------------------- /src/system/src/CommandLine/CommandLine.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of external standard class CommandLine. 3 | */ 4 | 5 | 6 | #include 7 | 8 | #include "sac.h" 9 | 10 | 11 | /*****************************************************/ 12 | 13 | 14 | typedef struct COMLINE 15 | { 16 | int argc; 17 | char **argv; 18 | } 19 | ComLine; 20 | 21 | 22 | /*****************************************************/ 23 | 24 | 25 | extern ComLine *SACo_CommandLine__TheCommandLine; 26 | 27 | 28 | /*****************************************************/ 29 | 30 | 31 | ComLine *create_TheCommandLine( void) 32 | { 33 | ComLine *parameters; 34 | 35 | parameters=(ComLine *)SAC_MALLOC(sizeof(ComLine)); 36 | 37 | SAC_COMMANDLINE_GET( parameters->argc, parameters->argv); 38 | 39 | return(parameters); 40 | } 41 | 42 | 43 | /*****************************************************/ 44 | 45 | 46 | int SACargc( void) 47 | { 48 | return(SACo_CommandLine__TheCommandLine->argc); 49 | } 50 | 51 | 52 | /*****************************************************/ 53 | 54 | 55 | char *SACargv(int n) 56 | { 57 | char *result; 58 | 59 | if (nargc) 60 | { 61 | result=(char*)SAC_MALLOC(strlen((SACo_CommandLine__TheCommandLine->argv)[n])+1); 62 | 63 | strcpy(result, (SACo_CommandLine__TheCommandLine->argv)[n]); 64 | } 65 | else 66 | { 67 | result=(char*)SAC_MALLOC(1); 68 | result[0]=0; 69 | } 70 | 71 | return(result); 72 | } 73 | 74 | 75 | /*****************************************************/ 76 | 77 | 78 | char *SACargvall( void) 79 | { 80 | char *result; 81 | int len,i; 82 | 83 | len=0; 84 | 85 | for (i=0; iargc; i++) 86 | { 87 | len += strlen(SACo_CommandLine__TheCommandLine->argv[i]); 88 | } 89 | 90 | result=(char*)SAC_MALLOC(len+1+SACo_CommandLine__TheCommandLine->argc); 91 | 92 | strcpy(result, (SACo_CommandLine__TheCommandLine->argv)[0]); 93 | 94 | for (i=1; iargc; i++) 95 | { 96 | strcat(result, " "); 97 | strcat(result, (SACo_CommandLine__TheCommandLine->argv)[i]); 98 | } 99 | 100 | return(result); 101 | } 102 | 103 | 104 | /*****************************************************/ 105 | 106 | 107 | 108 | 109 | 110 | -------------------------------------------------------------------------------- /src/stdio/src/FibreIO/FibreScan.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of standard module FibreScan 3 | */ 4 | 5 | 6 | #include 7 | #include 8 | 9 | #include "sac.h" 10 | 11 | 12 | #define yyFlexLexer FibreScanFlexLexer 13 | #define yy_create_buffer FibreScan_create_buffer 14 | #define yy_delete_buffer FibreScan_delete_buffer 15 | #define yy_flex_debug FibreScan_flex_debug 16 | #define yy_init_buffer FibreScan_init_buffer 17 | #define yy_load_buffer_state FibreScan_load_buffer_state 18 | #define yy_switch_to_buffer FibreScan_switch_to_buffer 19 | #define yyin FibreScanin 20 | #define yy_scan_string FibreScan_scan_string 21 | #define yyleng FibreScanleng 22 | #define yylex FibreScanlex 23 | #define yyout FibreScanout 24 | #define yyrestart FibreScanrestart 25 | #define yytext FibreScantext 26 | #define yywrap FibreScanwrap 27 | 28 | #define yyparse FibreScanparse 29 | #define yyerror FibreScanerror 30 | #define yylval FibreScanlval 31 | #define yychar FibreScanchar 32 | #define yydebug FibreScandebug 33 | #define yynerrs FibreScannerrs 34 | 35 | 36 | 37 | 38 | #define MAXDIM 10 39 | 40 | extern int linenum; 41 | 42 | extern int yyparse(void); 43 | extern int yy_scan_string( char*); 44 | extern void yyerror(char *); 45 | extern int FibreScanparse( void); 46 | 47 | extern char *yytext; 48 | 49 | extern FILE *yyin; 50 | extern int start_token; 51 | extern int FibreScanlex(void); 52 | extern void doScan( FILE *stream); 53 | 54 | extern int boolval; 55 | extern char byteval; 56 | extern short shortval; 57 | extern int intval; 58 | extern long longval; 59 | extern long long longlongval; 60 | extern unsigned char ubyteval; 61 | extern unsigned short ushortval; 62 | extern unsigned int uintval; 63 | extern unsigned long ulongval; 64 | extern unsigned long long ulonglongval; 65 | extern float floatval; 66 | extern double doubleval; 67 | extern char *stringval; 68 | extern double *doublearray; 69 | extern float *floatarray; 70 | extern char *bytearray; 71 | extern short *shortarray; 72 | extern int *intarray; 73 | extern long *longarray; 74 | extern long long *longlongarray; 75 | extern unsigned char *ubytearray; 76 | extern unsigned short *ushortarray; 77 | extern unsigned int *uintarray; 78 | extern unsigned long *ulongarray; 79 | extern unsigned long long *ulonglongarray; 80 | extern char **stringarray; 81 | 82 | extern int got_scaler; 83 | extern int size; 84 | extern int dims; 85 | extern int shape[ MAXDIM]; 86 | 87 | -------------------------------------------------------------------------------- /src/system/Environment.sac: -------------------------------------------------------------------------------- 1 | #pragma safe 2 | class Environment; 3 | 4 | external classtype; 5 | 6 | use String: { string }; 7 | 8 | export all; 9 | 10 | objdef Environment TheEnvironment = create_TheEnvironment( ); 11 | 12 | /* 13 | * The global object TheEnvironment of class Environment serves as 14 | * a representation of the environment. 15 | * It is derived from the global object TheWorld in 16 | * order to represent this part or sub-world of the execution environment. 17 | */ 18 | 19 | external Environment create_TheEnvironment( ); 20 | #pragma effect World::TheWorld 21 | #pragma linksign [0] 22 | #pragma linkobj "src/Environment/Env.o" 23 | 24 | 25 | external string GetEnv(string ENVVAR); 26 | #pragma effect TheEnvironment 27 | #pragma linksign [0,1] 28 | #pragma linkobj "src/Environment/GetEnv.o" 29 | /* 30 | * Get the value of the environment variable ENVVAR from the current 31 | * environment. 32 | */ 33 | 34 | external bool ExistEnv(string ENVVAR); 35 | #pragma effect TheEnvironment 36 | #pragma linksign [0,1] 37 | #pragma linkobj "src/Environment/ExistEnv.o" 38 | /* 39 | * Check if the environment variable ENVVAR exists in the current 40 | * environment. 41 | */ 42 | 43 | external bool SetEnv(string ENVVAR, string VALUE, bool OVERWRITE); 44 | #pragma effect TheEnvironment 45 | #pragma linksign [0,1,2,3] 46 | #pragma linkobj "src/Environment/SetEnv.o" 47 | /* 48 | * Set the environment variable ENVVAR to VALUE. If ENVVAR is already 49 | * set in the current environment, then the old value is only 50 | * overwritten if OVERWRITE evaluates to true. The boolean result 51 | * informs about success or failure of this operation. 52 | */ 53 | 54 | external void UnsetEnv(string ENVVAR); 55 | #pragma effect TheEnvironment 56 | #pragma linkobj "src/Environment/UnsetEnv.o" 57 | /* 58 | * Clear the environment variable ENVVAR from the current environment. 59 | */ 60 | 61 | external int EnvCount(); 62 | #pragma effect TheEnvironment 63 | #pragma linksign [0] 64 | #pragma linkobj "src/Environment/Environ.o" 65 | /* 66 | * Return the number of environment variables. 67 | */ 68 | 69 | external string IndexEnv(int N); 70 | #pragma effect TheEnvironment 71 | #pragma linksign [0,1] 72 | #pragma linkobj "src/Environment/Environ.o" 73 | /* 74 | * Return the N'th environment variable. 75 | */ 76 | 77 | -------------------------------------------------------------------------------- /src/stdio/src/FibreIO/ScanStringArr.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of standard module FibreScan 3 | */ 4 | 5 | 6 | #include "FibreScan.h" 7 | #include "FibreScan.tab.h" 8 | 9 | #include "../../../structures/src/StringArray/StringArray.h" 10 | 11 | #define resout_nt (resout, T_OLD((SCL, (HID, (NUQ, ))))) 12 | #define res_nt (res, T_OLD((SCL, (HID, (NUQ, ))))) 13 | #define s_nt (s, T_OLD((SCL, (HID, (NUQ,))))) 14 | 15 | 16 | void FibreScanStringArray( SAC_ND_PARAM_out( resout_nt, array *), FILE *stream) 17 | { 18 | 19 | SAC_ND_DECL__DESC( res_nt, ); 20 | 21 | array *SAC_ND_A_FIELD( res_nt ); 22 | int size; 23 | int i; 24 | 25 | SAC_ND_ALLOC__DESC( res_nt, 0); 26 | SAC_ND_SET__RC( res_nt, 1); 27 | 28 | 29 | start_token = PARSE_STRING_ARRAY; 30 | doScan( stream); 31 | 32 | size = 1; 33 | for( i=0; i < dims; i++) { 34 | size *= shape[i]; 35 | } 36 | 37 | res = SAC_StringArray_alloc( dims, size); 38 | 39 | for( i=0; i < dims; i++) { 40 | res->shp[i] = shape[i]; 41 | } 42 | 43 | res->data = stringarray; 44 | 45 | for( i=0; i < size ; i++) { 46 | SAC_ND_DECL__DESC( s_nt, ); 47 | SAC_ND_ALLOC__DESC( s_nt, 0); 48 | SAC_ND_SET__RC( s_nt, 1); 49 | res->descs[i] = SAC_ND_A_DESC( s_nt); 50 | } 51 | 52 | SAC_ND_RET_out( resout_nt, res_nt ) 53 | } 54 | 55 | #undef resout_nt 56 | #undef res_nt 57 | #undef s_nt 58 | 59 | #define resout_nt (resout, T_OLD((SCL, (HID, (NUQ, ))))) 60 | #define res_nt (res, T_OLD((SCL, (HID, (NUQ, ))))) 61 | #define s_nt (s, T_OLD((SCL, (HID, (NUQ,))))) 62 | 63 | void FibreScanStringArrayStr( SAC_ND_PARAM_out( resout_nt, array *), char *stream) 64 | { 65 | 66 | SAC_ND_DECL__DESC( res_nt, ); 67 | 68 | array *SAC_ND_A_FIELD( res_nt ); 69 | int size; 70 | int i; 71 | 72 | SAC_ND_ALLOC__DESC( res_nt, 0); 73 | SAC_ND_SET__RC( res_nt, 1); 74 | 75 | 76 | start_token = PARSE_STRING_ARRAY; 77 | yy_scan_string( stream); 78 | FibreScanparse(); 79 | 80 | size = 1; 81 | for( i=0; i < dims; i++) { 82 | size *= shape[i]; 83 | } 84 | 85 | res = SAC_StringArray_alloc( dims, size); 86 | 87 | for( i=0; i < dims; i++) { 88 | res->shp[i] = shape[i]; 89 | } 90 | 91 | res->data = stringarray; 92 | 93 | for( i=0; i < size ; i++) { 94 | SAC_ND_DECL__DESC( s_nt, ); 95 | SAC_ND_ALLOC__DESC( s_nt, 0); 96 | SAC_ND_SET__RC( s_nt, 1); 97 | res->descs[i] = SAC_ND_A_DESC( s_nt); 98 | } 99 | 100 | SAC_ND_RET_out( resout_nt, res_nt ) 101 | } 102 | 103 | #undef resout_nt 104 | #undef res_nt 105 | #undef s_nt 106 | 107 | -------------------------------------------------------------------------------- /src/structures/ArrayReduce.xsac: -------------------------------------------------------------------------------- 1 | #pragma safe 2 | 3 | module ArrayReduce; 4 | 5 | /****************************************************************************** 6 | * 7 | * Depends on ScalarArith, ArrayBasics, and Constants. 8 | * 9 | ******************************************************************************/ 10 | 11 | use ArrayBasics: { sel }; 12 | use Constants: all; 13 | 14 | export all; 15 | 16 | #include "builtin.mac" 17 | 18 | /****************************************************************************** 19 | * 20 | * @fn reduce([d:shp] arr) 21 | * 22 | * @brief Reduces the given array to a single element. 23 | * 24 | ******************************************************************************/ 25 | 26 | #define REDUCE(name, typ, fun, neutral) \ 27 | inline typ name(typ[d:shp] arr) \ 28 | { \ 29 | return with { \ 30 | (_mul_SxV_(0, shp) <= iv < shp) : _sel_VxA_(iv, arr); \ 31 | } : fold(fun, neutral); \ 32 | } 33 | 34 | #define NUM_REDUCE(typ, _postfix, _fmt, zval, oval) \ 35 | REDUCE(sum, typ, ScalarArith::+, zval) \ 36 | REDUCE(prod, typ, ScalarArith::*, oval) \ 37 | REDUCE(minval, typ, ScalarArith::min, max##typ()) \ 38 | REDUCE(maxval, typ, ScalarArith::max, min##typ()) 39 | 40 | NUM(NUM_REDUCE) 41 | 42 | #define BOOL_REDUCE(typ, _postfix, _fmt, zval, oval) \ 43 | REDUCE(any, typ, ScalarArith::|, zval) \ 44 | REDUCE(all, typ, ScalarArith::&, oval) 45 | 46 | BOOL(BOOL_REDUCE) 47 | 48 | /****************************************************************************** 49 | * 50 | * @fn [i:ishp] rsum(int r, [r:rshp,i:ishp] arr) 51 | * 52 | * @brief Sum along the first `r` axes of `arr`. 53 | * 54 | ******************************************************************************/ 55 | 56 | #define RSUM(typ, _postfix, _fmt, zval, _oval) \ 57 | inline typ[i:ishp] rsum(int r, typ[r:rshp,i:ishp] arr) \ 58 | { \ 59 | return { iv -> sum({ \ 60 | ov -> arr[_cat_VxV_(ov, iv)] | ov < rshp }) \ 61 | | iv < ishp }; \ 62 | } 63 | 64 | NUM(RSUM) 65 | -------------------------------------------------------------------------------- /CMakeLists.txt: -------------------------------------------------------------------------------- 1 | CMAKE_MINIMUM_REQUIRED (VERSION 3.20) 2 | 3 | PROJECT (sac-stdlib) 4 | #FIXME(artem) we can create a definitoin for language "SAC" which will 5 | # automatically pull sac2c compiler. 6 | 7 | # Where the compiled sac modules result 8 | SET (DLL_BUILD_DIR "${PROJECT_BINARY_DIR}/lib") 9 | 10 | # For what targets we build modules 11 | SET (TARGETS seq seq_checks mt_pth CACHE STRING "Build stdlib for these targets") 12 | SET (SAC2C_EXEC CACHE STRING "A path to sac2c compiler") 13 | SET (LINKSETSIZE "500" CACHE STRING "Set a value for -linksetsize parameter of sac2c") 14 | SET (IS_RELEASE FALSE CACHE BOOL "Indicate if we are building with release version of SAC2C") 15 | 16 | SET (SAC2C_EXTRA_INC 17 | -DHAVE_CONFIG_H 18 | -I${PROJECT_BINARY_DIR}/include 19 | -I${PROJECT_SOURCE_DIR}/include) 20 | 21 | SET (SAC2C_CPP_INC 22 | -DHAVE_CONFIG_H 23 | -cppI${PROJECT_BINARY_DIR}/include 24 | -cppI${PROJECT_SOURCE_DIR}/include) 25 | 26 | # Check whether sac2c is operational 27 | LIST (APPEND CMAKE_MODULE_PATH "${CMAKE_SOURCE_DIR}/cmake-common") 28 | INCLUDE ("cmake-common/check-sac2c.cmake") # get SAC2C_VERSION 29 | INCLUDE ("cmake-common/misc-macros.cmake") 30 | INCLUDE ("cmake-common/check-sac2c-feature-support.cmake") 31 | INCLUDE ("cmake-common/generate-version-vars.cmake") 32 | 33 | # if building generically, we need to make sure sac2c supports this 34 | IF (BUILDGENERIC) 35 | CHECK_SAC2C_SUPPORT_FLAG ("generic" "-generic" "") 36 | IF (HAVE_FLAG_generic) 37 | LIST (APPEND SAC2C_CPP_INC "-generic") 38 | ELSE () 39 | MESSAGE (STATUS "Generic-build disabled as sac2c does not support this!") 40 | SET (BUILDGENERIC OFF) 41 | ENDIF () 42 | ENDIF () 43 | 44 | # complete configuration now 45 | INCLUDE ("cmake/config.cmake") 46 | 47 | IF (FULLTYPES) 48 | LIST (APPEND SAC2C_EXTRA_INC -DFULLTYPES) 49 | LIST (APPEND SAC2C_CPP_INC -DFULLTYPES) 50 | ENDIF () 51 | 52 | IF (BUILD_EXT) 53 | LIST (APPEND SAC2C_EXTRA_INC -DEXT_STDLIB) 54 | LIST (APPEND SAC2C_CPP_INC -DEXT_STDLIB) 55 | ENDIF () 56 | 57 | # For every target run CMakeLists.txt in src 58 | FOREACH (TARGET IN ITEMS ${TARGETS}) 59 | ADD_SUBDIRECTORY (src src-${TARGET}) 60 | ENDFOREACH () 61 | 62 | # This build target is responsible for generating the package sac2crc file 63 | CREATE_SAC2CRC_TARGET ("stdlib" "${DLL_BUILD_DIR}" "${DLL_BUILD_DIR}" "") 64 | 65 | # lets create packages 66 | SET (PROJECT_SHORT_VERSION) 67 | SET (PROJECT_MAJOR_VERSION) 68 | SET (PROJECT_MINOR_VERSION) 69 | SET (PROJECT_PATCH_VERSION) 70 | GET_PROJECT_VERSION (PROJECT_SHORT_VERSION PROJECT_MAJOR_VERSION PROJECT_MINOR_VERSION PROJECT_PATCH_VERSION) 71 | INCLUDE ("${PROJECT_SOURCE_DIR}/cmake/cpack.cmake") 72 | -------------------------------------------------------------------------------- /src/system/GetOpt.sac: -------------------------------------------------------------------------------- 1 | #pragma safe 2 | module GetOpt; 3 | 4 | use CommandLine: { TheCommandLine }; 5 | use String: { string }; 6 | 7 | export all; 8 | 9 | /****************************************************************************** 10 | * 11 | * Provide getopt(3) functionality for SAC. See the getopt(3) manual page 12 | * for details. You only need getopt(), optarg() and optEND(), the rest 13 | * is standardization effort. 14 | * 15 | ******************************************************************************/ 16 | 17 | external char getopt(string opts); 18 | #pragma effect TheCommandLine 19 | #pragma linkobj "src/GetOpt/getopt.o" 20 | #pragma linkname "getopt_sac" 21 | #pragma linksign [0,1] 22 | /* 23 | * Return the next command line option using the options given in 'opts'. 24 | * If the option requires an argument then this is available by optarg(). 25 | * If no more options are available then getopt returns optEND(). 26 | * See the manual page for getopt(3) for more details. 27 | */ 28 | 29 | external char optEND(); 30 | #pragma linkobj "src/GetOpt/getopt.o" 31 | #pragma linkname "optEND" 32 | #pragma linksign [0] 33 | /* 34 | * Return the option character that is used to signal end-of-options. 35 | */ 36 | 37 | external string optarg(); 38 | #pragma effect TheCommandLine 39 | #pragma linkobj "src/GetOpt/getopt.o" 40 | #pragma linkname "get_optarg" 41 | #pragma linksign [0] 42 | /* 43 | * Retrieve the argument to the current option. 44 | * If the option doesn't require an argument then this is empty. 45 | */ 46 | 47 | external char optopt(); 48 | #pragma effect TheCommandLine 49 | #pragma linkobj "src/GetOpt/getopt.o" 50 | #pragma linkname "get_optopt" 51 | #pragma linksign [0] 52 | /* 53 | * Retrieve the last option value. 54 | */ 55 | 56 | external int optind(); 57 | #pragma effect TheCommandLine 58 | #pragma linkobj "src/GetOpt/getopt.o" 59 | #pragma linkname "get_optind" 60 | #pragma linksign [0] 61 | /* 62 | * Return the current index into argv. 63 | */ 64 | 65 | external void optind(int set); 66 | #pragma effect TheCommandLine 67 | #pragma linkobj "src/GetOpt/getopt.o" 68 | #pragma linkname "set_optind" 69 | #pragma linksign [1] 70 | /* 71 | * Set or reset the current option index into argv. 72 | */ 73 | 74 | external bool opterr(); 75 | #pragma effect TheCommandLine 76 | #pragma linkobj "src/GetOpt/getopt.o" 77 | #pragma linkname "get_opterr" 78 | #pragma linksign [0] 79 | /* 80 | * Query if option error reporting is enabled. 81 | */ 82 | 83 | external void opterr(bool set); 84 | #pragma effect TheCommandLine 85 | #pragma linkobj "src/GetOpt/getopt.o" 86 | #pragma linkname "set_opterr" 87 | #pragma linksign [1] 88 | /* 89 | * Enable/disable option error reporting. 90 | */ 91 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | SaC standard library 2 | ==================== 3 | 4 | [![build status](https://github.com/SacBase/Stdlib/workflows/Build%20On%20Changes/badge.svg)](https://github.com/SacBase/Stdlib/actions?query=workflow%3A"Build+On+Changes") [![contributions welcome](https://img.shields.io/badge/contributions-welcome-brightgreen.svg)](https://github.com/SacBase/Stdlib/issues) 5 | 6 | This repository consists of SaC modules with basic functionality like 7 | arithmetic, stdio, etc; which together form the standard library of the SaC 8 | language. 9 | 10 | Build instructions 11 | ================== 12 | 13 | To build the system one requires an operational [CMake](https://cmake.org/) >= 3.20, 14 | [Flex](http://flex.sourceforge.net/), and [Bison](https://www.gnu.org/software/bison/). 15 | 16 | The quick and dirty option is just 17 | 18 | ``` 19 | make -j4 20 | ``` 21 | 22 | You can also use the `cmake` build system for more control 23 | 24 | ``` 25 | mkdir build 26 | cd build 27 | cmake .. 28 | make -j4 29 | ``` 30 | 31 | **NOTE:** *When pulling the latest commit, remember to run `git submodule 32 | update` or you will be missing changes to the `cmake-common` repository.* 33 | 34 | Variables that can be passed to CMake 35 | ========================================= 36 | 37 | When running CMake it is possible to pass the following variables: 38 | 39 | * `-DTARGETS=x;y;z` --- build stdlib for targets x, y and z. 40 | (Default is `seq;mt_pth`) 41 | * `-DBUILDGENERIC=ON|OFF` --- build stdlib without using architecture specific optimizations. 42 | (Useful when creating distributable packages) 43 | (Default is `OFF`) 44 | * `-DSAC2C_EXEC=/path/to/sac2c` --- specify `sac2c` executable directly. 45 | Otherwise CMake will try to find `sac2c` on your PATH. 46 | * `-DLINKSETSIZE=n` --- set `-linksetsize n` when calling `sac2c`. This option is responsible 47 | for the number of C functions that are put in a single C file when compiling a SaC program. 48 | The rule of thumb: 49 | * value `0` is the fastest time-wise but potentially results in a large memory consumption 50 | * value `1` reduces the memory consumption to minimum, but significantly increases compilation time. 51 | 52 | *Default value: 500.* 53 | * `-DFULLTYPES=ON|OFF` --- add support for further types to the stdlib, such as `short` and `longlong` 54 | (Default is `OFF`). 55 | * `-DBUILD_EXT=ON|OFF` --- build extended stdlib (see `cmake/source-core-ext.txt` for details) 56 | (Default is `ON`) 57 | 58 | Continuous Integration 59 | ===================== 60 | 61 | We make use of Github Actions for our CI pipeline, building the standard library on different systems 62 | anytime there is a pull request. Build will fail if there are any compile-time warnings. 63 | 64 | Please look at `.github/workflows/` for more exact details on what we do. 65 | 66 | Licensing 67 | ========= 68 | 69 | This project is OSS, please have a look at [LICENSE.md][license] for more details. Contributions 70 | are welcome! 71 | 72 | [license]: https://github.com/SacBase/Stdlib/blob/master/LICENSE.md 73 | -------------------------------------------------------------------------------- /src/structures/src/List/append.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of SAC standard module List 3 | */ 4 | 5 | 6 | #include "List.h" 7 | 8 | 9 | #define res_nt (res, T_OLD((SCL, (HID, (NUQ,))))) 10 | #define elemsA_nt (elemsA, T_OLD((SCL, (HID, (NUQ,))))) 11 | #define elemsB_nt (elemsB, T_OLD((SCL, (HID, (NUQ,))))) 12 | #define new_nt (new, T_OLD((SCL, (HID, (NUQ,))))) 13 | 14 | void SAC_List_append( SAC_ND_PARAM_out( res_nt, list *), 15 | SAC_ND_PARAM_in( elemsA_nt, list *), 16 | SAC_ND_PARAM_in( elemsB_nt, list *)) 17 | { 18 | SAC_ND_DECL__DESC( new_nt, ) 19 | SAC_ND_DECL__DATA( new_nt, list *, ) 20 | 21 | if (elemsA->rest == NULL) { /* elemsA == NIL! */ 22 | SAC_ND_RET_out( res_nt, elemsB_nt) 23 | if (--(DESC_RC( elemsA->desc)) == 0) { 24 | SAC_List_free_list( elemsA); 25 | } 26 | } 27 | else { 28 | 29 | if (DESC_RC( elemsA->desc) == 1) { /* re-use all elems while (rc == 1)! */ 30 | SAC_ND_RET_out( res_nt, elemsA_nt) 31 | 32 | do { 33 | new = elemsA; 34 | elemsA = elemsA->rest; 35 | } 36 | while ((elemsA->rest != NULL) && (DESC_RC( elemsA->desc) == 1)); 37 | /* 38 | * Now, we decrement the "rest" of elemsA. 39 | * Although this may lead to a 0 rc in case of NIL, 40 | * we do NOT free that node, since we have to make 41 | * sure that it survives the copying while-loop. 42 | * After that loop we check, whether the rc is 0. 43 | * If that is the case, we know that there were 44 | * no copies to be done and we can free the NIL! 45 | */ 46 | (DESC_RC( elemsA->desc))--; 47 | #if TRACE 48 | fprintf( stderr, "changing CONS at (%p)\n", new); 49 | #endif 50 | } 51 | 52 | else { /* copy first elem & decrement rc of 'elemsA'! */ 53 | new = (list *) SAC_MALLOC( sizeof( list)); 54 | new->elem = elemsA->elem; 55 | SAC_ND_ALLOC__DESC( new_nt, 0) 56 | SAC_ND_SET__RC( new_nt, 1) 57 | new->desc = SAC_ND_A_DESC( new_nt); 58 | #if TRACE 59 | fprintf( stderr, "creating CONS at (%p)\n", new); 60 | #endif 61 | SAC_ND_RET_out( res_nt, new_nt) 62 | (DESC_RC( elemsA->desc))--; 63 | 64 | elemsA = elemsA->rest; /* 'elemsA' has to be one in advance of 'new'! */ 65 | } 66 | 67 | /* 68 | * 'new' points to the last elem reused/copied 69 | * 'elemsA' is one in front 70 | */ 71 | while (elemsA->rest != NULL) { 72 | new->rest = (list *) SAC_MALLOC( sizeof( list)); 73 | #if TRACE 74 | fprintf( stderr, " [ %d . (%p)]\n", new->elem, new->rest); 75 | fprintf( stderr, "creating CONS at (%p)\n", new->rest); 76 | #endif 77 | new = new->rest; 78 | new->elem = elemsA->elem; 79 | SAC_ND_ALLOC__DESC( new_nt, 0) 80 | SAC_ND_SET__RC( new_nt, 1) 81 | new->desc = SAC_ND_A_DESC( new_nt); 82 | elemsA = elemsA->rest; 83 | } 84 | new->rest = elemsB; 85 | #if TRACE 86 | fprintf( stderr, " [ %d . (%p)]\n", new->elem, new->rest); 87 | #endif 88 | /* Finally, we have to do some housekeeping! (see comment above!) */ 89 | if (DESC_RC( elemsA->desc) == 0) { 90 | SAC_List_free_list( elemsA); 91 | } 92 | } 93 | } 94 | 95 | #undef res_nt 96 | #undef elemsA_nt 97 | #undef elemsB_nt 98 | #undef new_nt 99 | -------------------------------------------------------------------------------- /src/structures/Constants.sac: -------------------------------------------------------------------------------- 1 | #pragma safe 2 | 3 | module Constants; 4 | 5 | export all; 6 | 7 | #ifdef FULLTYPES 8 | 9 | external byte minbyte(); 10 | #pragma linksign[0] 11 | #pragma linkobj "src/Constants/minmax.o" 12 | 13 | external byte maxbyte(); 14 | #pragma linksign[0] 15 | #pragma linkobj "src/Constants/minmax.o" 16 | 17 | external short minshort(); 18 | #pragma linksign[0] 19 | #pragma linkobj "src/Constants/minmax.o" 20 | 21 | external short maxshort(); 22 | #pragma linksign[0] 23 | #pragma linkobj "src/Constants/minmax.o" 24 | 25 | external longlong minlonglong(); 26 | #pragma linksign[0] 27 | #pragma linkobj "src/Constants/minmax.o" 28 | 29 | external longlong maxlonglong(); 30 | #pragma linksign[0] 31 | #pragma linkobj "src/Constants/minmax.o" 32 | 33 | external ubyte minubyte(); 34 | #pragma linksign[0] 35 | #pragma linkobj "src/Constants/minmax.o" 36 | 37 | external ubyte maxubyte(); 38 | #pragma linksign[0] 39 | #pragma linkobj "src/Constants/minmax.o" 40 | 41 | external ushort minushort(); 42 | #pragma linksign[0] 43 | #pragma linkobj "src/Constants/minmax.o" 44 | 45 | external ushort maxushort(); 46 | #pragma linksign[0] 47 | #pragma linkobj "src/Constants/minmax.o" 48 | 49 | external ulonglong minulonglong(); 50 | #pragma linksign[0] 51 | #pragma linkobj "src/Constants/minmax.o" 52 | 53 | external ulonglong maxulonglong(); 54 | #pragma linksign[0] 55 | #pragma linkobj "src/Constants/minmax.o" 56 | 57 | #endif /* FULLTYPES */ 58 | 59 | external int minint(); 60 | #pragma linksign[0] 61 | #pragma linkobj "src/Constants/minint.o" 62 | 63 | external int maxint(); 64 | #pragma linksign[0] 65 | #pragma linkobj "src/Constants/maxint.o" 66 | 67 | external long minlong(); 68 | #pragma linksign[0] 69 | #pragma linkobj "src/Constants/minmax.o" 70 | 71 | external long maxlong(); 72 | #pragma linksign[0] 73 | #pragma linkobj "src/Constants/minmax.o" 74 | 75 | external uint minuint(); 76 | #pragma linksign[0] 77 | #pragma linkobj "src/Constants/minmax.o" 78 | 79 | external uint maxuint(); 80 | #pragma linksign[0] 81 | #pragma linkobj "src/Constants/minmax.o" 82 | 83 | external ulong minulong(); 84 | #pragma linksign[0] 85 | #pragma linkobj "src/Constants/minmax.o" 86 | 87 | external ulong maxulong(); 88 | #pragma linksign[0] 89 | #pragma linkobj "src/Constants/minmax.o" 90 | 91 | external float minfloat(); 92 | #pragma linksign[0] 93 | #pragma linkobj "src/Constants/minfloat.o" 94 | 95 | external float maxfloat(); 96 | #pragma linksign[0] 97 | #pragma linkobj "src/Constants/maxfloat.o" 98 | 99 | external double mindouble(); 100 | #pragma linksign[0] 101 | #pragma linkobj "src/Constants/mindouble.o" 102 | 103 | external double tinydouble(); 104 | #pragma linksign[0] 105 | #pragma linkobj "src/Constants/tinydouble.o" 106 | 107 | external double maxdouble(); 108 | #pragma linksign[0] 109 | #pragma linkobj "src/Constants/maxdouble.o" 110 | 111 | external double epidouble(); 112 | #pragma linksign[0] 113 | #pragma linkobj "src/Constants/epidouble.o" 114 | 115 | external int randmax(); 116 | #pragma linksign[0] 117 | #pragma linkobj "src/Constants/randmax.o" 118 | -------------------------------------------------------------------------------- /cmake/sac-core-ext.txt: -------------------------------------------------------------------------------- 1 | # This file describes the list of all the *.sac and *.xsac files 2 | # and annotation whether a file belongs to the Core build or 3 | # to the Extended build of the standard library. 4 | # 5 | # The syntax of the file is: 6 | # (Core|Ext) 7 | # 8 | # The filename is specified relatively to src directory. 9 | 10 | # Auxiliary 11 | auxiliary/Benchmarking.sac Ext 12 | auxiliary/Hiding.xsac Ext 13 | auxiliary/Interval.sac Ext 14 | 15 | # Numerical 16 | numerical/ComplexMath.sac Ext 17 | numerical/Math.sac Core 18 | numerical/MathArray.sac Core 19 | numerical/Numerical.sac Core 20 | 21 | # Random 22 | random/Xoshiro.sac Core 23 | 24 | # StdIO 25 | stdio/ArrayIO.xsac Core 26 | stdio/BinFile.sac Core 27 | stdio/ComplexIO.sac Ext 28 | stdio/FibreIO.sac Ext 29 | stdio/File.sac Core 30 | stdio/IOresources.sac Core 31 | stdio/ListIO.sac Ext 32 | stdio/ScalarIO.xsac Core 33 | stdio/StdIO.sac Core 34 | stdio/TermFile.sac Core 35 | 36 | # Structures 37 | structures/Array.sac Core 38 | structures/ArrayArith.xsac Core 39 | structures/ArrayBasics.xsac Core 40 | structures/ArrayFormat.sac Core 41 | structures/ArrayReduce.xsac Core 42 | structures/ArrayTransform.xsac Core 43 | structures/ArrayTransformApl.xsac Ext 44 | structures/Char.sac Core 45 | structures/Color8.sac Ext 46 | structures/Complex.sac Ext 47 | structures/ComplexArrayArith.xsac Ext 48 | structures/ComplexArrayBasics.xsac Ext 49 | structures/ComplexArrayTransform.xsac Ext 50 | structures/ComplexBasics.sac Ext 51 | structures/ComplexScalarArith.sac Ext 52 | structures/Constants.sac Core 53 | structures/List.sac Ext 54 | structures/Quaternion.xsac Ext 55 | structures/ScalarArith.xsac Core 56 | structures/String.sac Core 57 | structures/StringArray.sac Ext 58 | structures/Structures.sac Core 59 | structures/Vector3d.xsac Ext 60 | structures/Vector3f.xsac Ext 61 | 62 | # System 63 | system/Clock.sac Core 64 | system/CommandLine.sac Core 65 | system/Dir.sac Core 66 | system/Environment.sac Core 67 | system/FileSystem.sac Core 68 | system/GetOpt.sac Core 69 | system/MTClock.sac Core 70 | system/Process.sac Core 71 | system/RTClock.sac Core 72 | system/RTimer.sac Core 73 | system/RuntimeError.sac Core 74 | system/SysErr.sac Core 75 | system/System.sac Core 76 | system/Terminal.sac Core 77 | system/TimeStamp.sac Core 78 | system/World.sac Core 79 | 80 | # UTrace 81 | utrace/Indent.sac Ext 82 | utrace/UTrace.sac Ext 83 | -------------------------------------------------------------------------------- /src/system/src/RTimer/rtimer.c: -------------------------------------------------------------------------------- 1 | /* 2 | * $Id$ 3 | * 4 | * Description: 5 | * 6 | * This module implements access to the system real time clock, more precisely 7 | * it provides functions to create, start, stop, reset and inquire real clock timers. 8 | * 9 | * As a special feature timers can be 'stacked', i.e. a timer can repeatedly be 10 | * started without effect, the timer just continues to run. It then requires the 11 | * same number of stops to effectively stop. This feature is meant as a preparatory 12 | * step towards automatically inserting timer calls into the code by the compiler, 13 | * where we need to take recursive functions into account. 14 | */ 15 | #include 16 | #include "sac.h" 17 | 18 | #ifdef __MACH__ 19 | #include 20 | #include 21 | #endif 22 | 23 | struct rtimer 24 | { 25 | struct timespec elapsed; 26 | struct timespec started; 27 | int instance; 28 | }; 29 | 30 | void current_utc_time(struct timespec *ts) 31 | { 32 | ts->tv_sec = 0; 33 | ts->tv_nsec = 0; 34 | 35 | #ifdef __MACH__ 36 | // OS X does not have clock_gettime, use clock_get_time 37 | clock_serv_t cclock; 38 | mach_timespec_t mts; 39 | host_get_clock_service(mach_host_self(), CALENDAR_CLOCK, &cclock); 40 | clock_get_time(cclock, &mts); 41 | mach_port_deallocate(mach_task_self(), cclock); 42 | ts->tv_sec = mts.tv_sec; 43 | ts->tv_nsec = mts.tv_nsec; 44 | #else 45 | clock_gettime(CLOCK_REALTIME, ts); 46 | #endif 47 | } 48 | 49 | void SAC_RTimer_createRTimer(struct rtimer **ts) 50 | { 51 | *ts = (struct rtimer *)SAC_MALLOC(sizeof(struct rtimer)); 52 | (*ts)->elapsed.tv_sec = 0; 53 | (*ts)->elapsed.tv_nsec = 0; 54 | (*ts)->started.tv_sec = 0; 55 | (*ts)->started.tv_nsec = 0; 56 | (*ts)->instance = 0; 57 | } 58 | 59 | void SAC_RTimer_destroyRTimer(struct rtimer *ts) 60 | { 61 | SAC_FREE(ts); 62 | } 63 | 64 | void SAC_RTimer_startRTimer(struct rtimer *timer) 65 | { 66 | if (timer->instance == 0) { 67 | current_utc_time(&(timer->started)); 68 | timer->instance += 1; 69 | } 70 | } 71 | 72 | void SAC_RTimer_stopRTimer( struct rtimer *timer) 73 | { 74 | struct timespec now; 75 | 76 | if (timer->instance == 1) { 77 | current_utc_time(&now); 78 | if (now.tv_nsec > timer->started.tv_nsec) { 79 | timer->elapsed.tv_sec += now.tv_sec - timer->started.tv_sec; 80 | timer->elapsed.tv_nsec += now.tv_nsec - timer->started.tv_nsec; 81 | } 82 | else { 83 | timer->elapsed.tv_sec += (now.tv_sec - timer->started.tv_sec) - 1; 84 | timer->elapsed.tv_nsec += 1000000000L - timer->started.tv_nsec + now.tv_nsec; 85 | } 86 | 87 | timer->instance = 0; 88 | } 89 | else if (timer->instance > 1) { 90 | timer->instance -= 1; 91 | } 92 | } 93 | 94 | void SAC_RTimer_resetRTimer( struct rtimer *timer) 95 | { 96 | if (timer->instance == 0) { 97 | timer->elapsed.tv_sec = 0; 98 | timer->elapsed.tv_nsec = 0; 99 | } 100 | } 101 | 102 | void SAC_RTimer_getRTimerInts(struct rtimer *timer, int *sec, int *nsec) 103 | { 104 | *sec = (int)(timer->elapsed.tv_sec); 105 | *nsec = (int)(timer->elapsed.tv_nsec); 106 | } 107 | 108 | double SAC_RTimer_getRTimerDbl(struct rtimer *timer) 109 | { 110 | double sec = (double)timer->elapsed.tv_sec; 111 | double nsec = (double)timer->elapsed.tv_nsec; 112 | return sec + nsec / 1000000000.0; 113 | } 114 | 115 | -------------------------------------------------------------------------------- /cmake/cpack.cmake: -------------------------------------------------------------------------------- 1 | # This file activates CPack binary packaging for different distributions 2 | # At the moment we support only *UNIX systems (DEB, RPM, productbuild (MacOS), 3 | # and TGZ). 4 | 5 | IF (NOT DEFINED SAC2C_VERSION) 6 | MESSAGE (FATAL_ERROR "Sac2c Version not set!") 7 | ENDIF () 8 | 9 | # lets get sac2c version components 10 | PARSE_SAC2C_VERSION ("${SAC2C_VERSION}" SAC2C_MAJOR SAC2C_MINOR SAC2C_PATCH) 11 | 12 | # By setting this on we can see where installation targets are specified via 13 | # absolute paths. XXX (???) For portability purposes this should be avoided. 14 | SET (CPACK_WARN_ON_ABSOLUTE_INSTALL_DESTINATION ON) 15 | 16 | IF (${CMAKE_SYSTEM_NAME} MATCHES "Darwin") 17 | SET (CPACK_GENERATOR "productbuild;TGZ") 18 | ELSE () 19 | SET (CPACK_GENERATOR "RPM;DEB;TGZ") 20 | ENDIF () 21 | 22 | SET (CPACK_productbuild_COMPONENT_INSTALL ON) 23 | SET (CPACK_RPM_COMPONENT_INSTALL ON) 24 | SET (CPACK_DEB_COMPONENT_INSTALL ON) 25 | SET (CPACK_TGZ_COMPONENT_INSTALL ON) 26 | SET (CPACK_COMPONENTS_GROUPING ALL_COMPONENTS_IN_ONE) 27 | SET (CPACK_COMPONENTS_ALL modules trees) 28 | 29 | # We create separate config files for different generators 30 | #set(CPACK_PROJECT_CONFIG_FILE "${PROJECT_SOURCE_DIR}/cmake/cpack_options.cmake") 31 | 32 | # Set default CPack Packaging options 33 | SET (CPACK_PACKAGE_NAME "sac-stdlib") 34 | SET (CPACK_PACKAGE_VENDOR "SaC Development Team") 35 | SET (CPACK_PACKAGE_CONTACT "info@sac-home.org") 36 | SET (CPACK_PACKAGE_VERSION "${PROJECT_SHORT_VERSION}") 37 | SET (CPACK_PACKAGE_VERSION_MAJOR "${PROJECT_MAJOR_VERSION}") 38 | SET (CPACK_PACKAGE_VERSION_MINOR "${PROJECT_MINOR_VERSION}") 39 | SET (CPACK_PACKAGE_VERSION_PATCH "${PROJECT_PATCH_VERSION}") 40 | IF (${IS_RELEASE}) # we are building for a release (tag) version of SAC2C 41 | SET (CPACK_PACKAGE_FILE_NAME "${CPACK_PACKAGE_NAME}-${PROJECT_SHORT_VERSION}-for-${SAC2C_VERSION}") 42 | ELSE () 43 | SET (CPACK_PACKAGE_FILE_NAME "${CPACK_PACKAGE_NAME}-${PROJECT_SHORT_VERSION}") 44 | ENDIF () 45 | #SET (CPACK_PACKAGE_ICON "${PROJECT_SOURCE_DIR}/cmake/sac_logo.png") 46 | SET (CPACK_PACKAGING_INSTALL_PREFIX "${CMAKE_INSTALL_PREFIX}") 47 | 48 | # SET (CPACK_PACKAGE_DESCRIPTION_FILE ...) 49 | SET (CPACK_PACKAGE_DESCRIPTION_SUMMARY "The standard library for a data-parallel array-based functional language SAC") 50 | SET (CPACK_RESOURCE_FILE_LICENSE "${PROJECT_SOURCE_DIR}/cmake/cpack/LICENSE.txt") 51 | SET (CPACK_RESOURCE_FILE_README "${PROJECT_SOURCE_DIR}/cmake/cpack/README.txt") 52 | SET (CPACK_RESOURCE_FILE_WELCOME "${PROJECT_SOURCE_DIR}/cmake/cpack/WELCOME.txt") 53 | 54 | # Debian-specific variables 55 | SET (CPACK_DEBIAN_PACKAGE_MAINTAINER "${CPACK_PACKAGE_VENDOR} <${CPACK_PACKAGE_CONTACT}>") 56 | SET (CPACK_DEBIAN_ARCHITECTURE ${CMAKE_SYSTEM_PROCESSOR}) 57 | SET (CPACK_DEBIAN_PACKAGE_SHLIBDEPS ON) # non-functional? 58 | # FIXME Can we auto-generate these dependencies? 59 | SET (CPACK_DEBIAN_PACKAGE_DEPENDS "sac2c-compiler (= ${SAC2C_MAJOR}.${SAC2C_MINOR}.${SAC2C_PATCH})") 60 | 61 | # RPM-specific variables 62 | # XXX (hans): this may not be exhaustive - does not take into account if the user 63 | # changes the install prefix 64 | SET (CPACK_RPM_EXCLUDE_FROM_AUTO_FILELIST_ADDITION /usr/local /usr/local/bin /usr/local/include /usr/local/lib /usr/local/libexec /usr/local/share) 65 | # FIXME Can we auto-generate these dependencies? 66 | SET (CPACK_RPM_PACKAGE_REQUIRES "sac2c-compiler = ${SAC2C_MAJOR}.${SAC2C_MINOR}.${SAC2C_PATCH}") # we don't need to go crazy here as rpmbuild handles most of this for us 67 | 68 | INCLUDE (CPack) 69 | 70 | # vim: ts=2 sw=2 et: 71 | -------------------------------------------------------------------------------- /src/structures/Quaternion.xsac: -------------------------------------------------------------------------------- 1 | #pragma safe 2 | module Quaternion; 3 | 4 | export all; 5 | 6 | #include "arraybasics.mac" 7 | 8 | struct Quaternion { 9 | double a, b, c, d; 10 | }; 11 | 12 | /****************************************************************************** 13 | * 14 | * Array operations. 15 | * 16 | ******************************************************************************/ 17 | 18 | #define QUATERNION(fun) \ 19 | fun(struct Quaternion, \ 20 | /* no postfix */, \ 21 | /* no format */, \ 22 | (Quaternion{ 0.0, 0.0, 0.0, 0.0 }), \ 23 | (Quaternion{ 1.0, 1.0, 1.0, 1.0 })) 24 | 25 | QUATERNION(DIM) 26 | QUATERNION(SHAPE) 27 | QUATERNION(SEL) 28 | 29 | /****************************************************************************** 30 | * 31 | * Binary operations on quaternions. 32 | * 33 | ******************************************************************************/ 34 | 35 | inline struct Quaternion[d:shp] +(struct Quaternion q, double x) 36 | { 37 | return Quaternion{ _add_SxS_(q.a, x), 38 | _add_SxS_(q.b, x), 39 | _add_SxS_(q.c, x), 40 | _add_SxS_(q.d, x) }; 41 | } 42 | 43 | inline struct Quaternion[d:shp] +(struct Quaternion[d:shp] q, double x) 44 | { 45 | return { iv -> q[iv] + x | iv < shp }; 46 | } 47 | 48 | inline struct Quaternion +(struct Quaternion a, struct Quaternion b) 49 | { 50 | return Quaternion{ _add_SxS_(a.a, b.a), 51 | _add_SxS_(a.b, b.b), 52 | _add_SxS_(a.c, b.c), 53 | _add_SxS_(a.d, b.d) }; 54 | } 55 | 56 | inline struct Quaternion[d:shp] +(struct Quaternion[d:shp] a, 57 | struct Quaternion[d:shp] b) 58 | { 59 | return { iv -> a[iv] + b[iv] | iv < shp }; 60 | } 61 | 62 | /******************************************************************************/ 63 | 64 | inline struct Quaternion *(struct Quaternion a, struct Quaternion b) 65 | { 66 | return Quaternion{ 67 | _sub_SxS_(_mul_SxS_(a.a, b.a), 68 | _sub_SxS_(_mul_SxS_(a.b, b.b), 69 | _sub_SxS_(_mul_SxS_(a.c, b.c), 70 | _mul_SxS_(a.d, b.d)))), 71 | _add_SxS_(_mul_SxS_(a.a, b.b), 72 | _add_SxS_(_mul_SxS_(a.b, b.a), 73 | _sub_SxS_(_mul_SxS_(a.c, b.d), 74 | _mul_SxS_(a.d, b.c)))), 75 | _sub_SxS_(_mul_SxS_(a.a, b.c), 76 | _add_SxS_(_mul_SxS_(a.b, b.d), 77 | _add_SxS_(_mul_SxS_(a.c, b.a), 78 | _mul_SxS_(a.d, b.b)))), 79 | _add_SxS_(_mul_SxS_(a.a, b.d), 80 | _sub_SxS_(_mul_SxS_(a.b, b.c), 81 | _add_SxS_(_mul_SxS_(a.c, b.b), 82 | _mul_SxS_(a.d, b.a)))) 83 | }; 84 | } 85 | 86 | inline struct Quaternion[d:shp] *(struct Quaternion a, 87 | struct Quaternion[d:shp] b) 88 | { 89 | return { iv -> a * b[iv] | iv < shp }; 90 | } 91 | 92 | inline struct Quaternion[d:shp] *(struct Quaternion[d:shp] a, 93 | struct Quaternion b) 94 | { 95 | return { iv -> a[iv] * b | iv < shp }; 96 | } 97 | 98 | inline struct Quaternion[d:shp] *(struct Quaternion[d:shp] a, 99 | struct Quaternion[d:shp] b) 100 | { 101 | return { iv -> a[iv] * b[iv] | iv < shp }; 102 | } 103 | -------------------------------------------------------------------------------- /src/stdio/src/ComplexIO/PrintComplexArray.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Implementation of printing functions for Arrays as used in ArrayIO 3 | */ 4 | 5 | 6 | #include 7 | #include 8 | #include 9 | 10 | #include "sac.h" 11 | 12 | #define COMPLEX 1 13 | 14 | typedef char* string; 15 | typedef double complex[2]; 16 | 17 | static 18 | int Index2Offset( int dim, int *shp, int *index) 19 | { 20 | int i,n; 21 | int offset=0; 22 | int fact; 23 | 24 | for (i=0; i\n"); 52 | 53 | /* 54 | * Now, element_count carries the total number of elements 55 | * to be expected behind *a! 56 | */ 57 | 58 | if( dim == 0) { 59 | switch(typeflag) { 60 | case COMPLEX: 61 | fprintf(stream, format, (*((complex *)a))[0], (*((complex *)a))[1]); 62 | break; 63 | default: 64 | break; 65 | } 66 | fprintf(stream,"\n"); 67 | 68 | } else if (dim > 0) { 69 | if (element_count == 0) { 70 | fprintf(stream, "<>\n"); 71 | } else { 72 | 73 | index = SAC_MALLOC(dim * sizeof(int)); 74 | for (i=0; i "); 110 | } 111 | else { 112 | fprintf(stream, "| "); 113 | } 114 | 115 | while(( n>0) && (index[n]>=(shp[n]-1))) { 116 | index[n]=0; 117 | n -= 2; 118 | if(n<0) { 119 | space="\n"; 120 | n=((dim-2)/2)*2; 121 | } 122 | fprintf(stream, "%s",space); 123 | } 124 | if(( n>=0) && (index[n]<(shp[n]-1))) { 125 | index[n]++; 126 | n=dim-1; 127 | space=" "; 128 | } 129 | } while( n>0); 130 | 131 | fprintf(stream, "\n"); 132 | 133 | SAC_FREE(index); 134 | } /* if (element_count == 0) */ 135 | } else { 136 | SAC_RuntimeError ("Dimension is less than 0, aborting!"); 137 | } 138 | 139 | } 140 | 141 | void COMPLEXIO__PrintComplexArray( FILE *stream, int dim, int * shp, complex * a) 142 | { 143 | PrintArr(stream, COMPLEX, "(%.g, %.g) ", dim, shp, a); 144 | } 145 | 146 | void COMPLEXIO__PrintComplexArrayFormat( FILE *stream, string format, int dim, int * shp, complex * a) 147 | { 148 | PrintArr(stream, COMPLEX, format, dim, shp, a); 149 | } 150 | -------------------------------------------------------------------------------- /include/builtin.mac: -------------------------------------------------------------------------------- 1 | /****************************************************************************** 2 | * 3 | * Macros for mimicking polymorphism on elementary types. 4 | * 5 | ******************************************************************************/ 6 | 7 | #ifdef FULLTYPES 8 | 9 | #define SIGNED_INT_NUM(fun) \ 10 | fun(byte, b, x, 0b, 1b) \ 11 | fun(short, s, hd, 0s, 1s) \ 12 | fun(int, i, d, 0i, 1i) \ 13 | fun(long, l, ld, 0l, 1l) \ 14 | fun(longlong, ll, Ld, 0ll, 1ll) 15 | 16 | #define UNSIGNED_INT_NUM(fun) \ 17 | fun(ubyte, ub, X, 0ub, 1ub) \ 18 | fun(ushort, us, hu, 0us, 1us) \ 19 | fun(uint, ui, u, 0ui, 1ui) \ 20 | fun(ulong, ul, lu, 0ul, 1ul) \ 21 | fun(ulonglong, ull, Lu, 0ull, 1ull) 22 | 23 | #else /* FULLTYPES */ 24 | 25 | #define SIGNED_INT_NUM(fun) \ 26 | fun(int, i, d, 0i, 1i) \ 27 | fun(long, l, ld, 0l, 1l) 28 | 29 | #define UNSIGNED_INT_NUM(fun) \ 30 | fun(uint, ui, u, 0ui, 1ui) \ 31 | fun(ulong, ul, lu, 0ul, 1ul) 32 | 33 | #endif /* FULLTYPES */ 34 | 35 | #define INT_NUM(fun) \ 36 | SIGNED_INT_NUM(fun) \ 37 | UNSIGNED_INT_NUM(fun) 38 | 39 | #define REAL_NUM(fun) \ 40 | fun(float, f, f, 0f, 1f) \ 41 | fun(double, d, g, 0d, 1d) 42 | 43 | #define SIGNED_NUM(fun) \ 44 | SIGNED_INT_NUM(fun) \ 45 | REAL_NUM(fun) 46 | 47 | #define NUM(fun) \ 48 | INT_NUM(fun) \ 49 | REAL_NUM(fun) 50 | 51 | #define CHAR(fun) \ 52 | fun(char, /* no postfix */, c, ' ', ' ') 53 | 54 | #define BOOL(fun) \ 55 | fun(bool, /* no postfix */, d, false, true) 56 | 57 | /****************************************************************************** 58 | * 59 | * Macro for generating a function for built-in types. 60 | * 61 | * It is of the following format: 62 | * 63 | * #define BUILT_IN(fun) 64 | * fun(type, postfix, format, zero/false, one/true) 65 | * 66 | * @param type: The name of the type. 67 | * @param postfix: The postfix specifier for scalar values. 68 | * E.g. 1i is an integer of value 1, whereas 1f is a float value. 69 | * @param format: String format specifier for scalar values. 70 | * E.g. 'd' for integers, 'ld' for longs, or 'x' for bytes. 71 | * @param zero/false: The default zero/false value. 72 | * E.g. 0i for integers or false for booleans. 73 | * @param one/true: The default zero/false value. 74 | * E.g. 1i for integers or true for booleans. 75 | * 76 | ******************************************************************************/ 77 | 78 | #define BUILT_IN(fun) \ 79 | NUM(fun) \ 80 | CHAR(fun) \ 81 | BOOL(fun) 82 | --------------------------------------------------------------------------------