paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-06 04:29:42 +02:00
Code Issues Packages Projects Releases Wiki Activity

tosunits: first bits of the Atari TOS/GEM interface package

Browse Source 
git-svn-id: trunk@35214 -
This commit is contained in:
Károly Balogh 2016-12-30 01:23:09 +00:00
parent 217307cd69
commit 114c90ecca
9 changed files with 2843 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
.gitattributes vendored
View File

@ -7297,6 +7297,12 @@ packages/tcl/fpmake.pp svneol=native#text/plain
packages/tcl/src/tcl80.pp svneol=native#text/plain
packages/tcl/tests/tcl_demo.pp svneol=native#text/plain
packages/tcl/tests/test.tcl svneol=native#text/plain
packages/tosunits/Makefile svneol=native#text/plain
packages/tosunits/Makefile.fpc svneol=native#text/plain
packages/tosunits/README.txt svneol=native#text/plain
packages/tosunits/fpmake.pp svneol=native#text/plain
packages/tosunits/src/gemdos.pas svneol=native#text/plain
packages/tosunits/src/xbios.pas svneol=native#text/plain
packages/univint/Makefile svneol=native#text/plain
packages/univint/Makefile.fpc svneol=native#text/plain
packages/univint/Makefile.fpc.fpcmake svneol=native#text/plain

1
packages/fpmake_add.inc
View File

@ -113,6 +113,7 @@
add_symbolic(ADirectory+IncludeTrailingPathDelimiter('symbolic'));
add_syslog(ADirectory+IncludeTrailingPathDelimiter('syslog'));
add_tcl(ADirectory+IncludeTrailingPathDelimiter('tcl'));
add_tosunits(ADirectory+IncludeTrailingPathDelimiter('tosunits'));
add_univint(ADirectory+IncludeTrailingPathDelimiter('univint'));
add_unixutil(ADirectory+IncludeTrailingPathDelimiter('unixutil'));
add_unzip(ADirectory+IncludeTrailingPathDelimiter('unzip'));

6
packages/fpmake_proc.inc
View File

@ -647,6 +647,12 @@ begin
{$include tcl/fpmake.pp}
end;
procedure add_tosunits(const ADirectory: string);
begin
with Installer do
{$include tosunits/fpmake.pp}
end;
procedure add_univint(const ADirectory: string);
begin
with Installer do

2494
packages/tosunits/Makefile Normal file
View File

File diff suppressed because it is too large Load Diff

102
packages/tosunits/Makefile.fpc Normal file
View File

@ -0,0 +1,102 @@
#
# Makefile.fpc for running fpmake
#
[package]
name=ami-extra
version=3.1.1
[require]
packages=rtl fpmkunit
[install]
fpcpackage=y
[default]
fpcdir=../..
[prerules]
FPMAKE_BIN_CLEAN=$(wildcard ./fpmake$(SRCEXEEXT))
ifdef OS_TARGET
FPC_TARGETOPT+=--os=$(OS_TARGET)
endif
ifdef CPU_TARGET
FPC_TARGETOPT+=--cpu=$(CPU_TARGET)
endif
LOCALFPMAKE=./fpmake$(SRCEXEEXT)
[rules]
# Do not pass the Makefile's unit and binary target locations. Fpmake uses it's own.
override FPCOPT:=$(filter-out -FU%,$(FPCOPT))
override FPCOPT:=$(filter-out -FE%,$(FPCOPT))
# Do not pass the package-unitdirectories. Fpmake adds those and this way they don't apear in the .fpm
override FPCOPT:=$(filter-out $(addprefix -Fu,$(COMPILER_UNITDIR)),$(FPCOPT))# Compose general fpmake-parameters
# Compose general fpmake-parameters
ifdef FPMAKEOPT
FPMAKE_OPT+=$(FPMAKEOPT)
endif
FPMAKE_OPT+=--localunitdir=../..
FPMAKE_OPT+=--globalunitdir=..
FPMAKE_OPT+=$(FPC_TARGETOPT)
FPMAKE_OPT+=$(addprefix -o ,$(FPCOPT))
FPMAKE_OPT+=--compiler=$(FPC)
FPMAKE_OPT+=-bu
.NOTPARALLEL:
fpmake$(SRCEXEEXT): fpmake.pp
$(FPCFPMAKE) fpmake.pp $(FPMAKE_SKIP_CONFIG) $(addprefix -Fu,$(COMPILER_FPMAKE_UNITDIR)) $(FPCMAKEOPT) $(OPT)
all: fpmake$(SRCEXEEXT)
$(LOCALFPMAKE) compile $(FPMAKE_OPT)
smart: fpmake$(SRCEXEEXT)
$(LOCALFPMAKE) compile $(FPMAKE_OPT) -o -XX -o -CX
release: fpmake$(SRCEXEEXT)
$(LOCALFPMAKE) compile $(FPMAKE_OPT) -o -dRELEASE
debug: fpmake$(SRCEXEEXT)
$(LOCALFPMAKE) compile $(FPMAKE_OPT) -o -dDEBUG
# If no fpmake exists and (dist)clean is called, do not try to build fpmake, it will
# most often fail because the dependencies are cleared.
# In case of a clean, simply do nothing
ifeq ($(FPMAKE_BIN_CLEAN),)
clean:
else
clean:
$(FPMAKE_BIN_CLEAN) clean $(FPMAKE_OPT)
endif
# In case of a distclean, perform an 'old'-style distclean. This to avoid problems
# when the package is compiled using fpcmake prior to running this clean using fpmake
ifeq ($(FPMAKE_BIN_CLEAN),)
distclean: $(addsuffix _distclean,$(TARGET_DIRS)) fpc_cleanall
else
distclean:
ifdef inUnix
{ $(FPMAKE_BIN_CLEAN) distclean $(FPMAKE_OPT); if [ $$? != "0" ]; then { echo Something wrong with fpmake exectable. Remove the executable and call make recursively to recover.; $(DEL) $(FPMAKE_BIN_CLEAN); $(MAKE) fpc_cleanall; }; fi; }
else
$(FPMAKE_BIN_CLEAN) distclean $(FPMAKE_OPT)
endif
-$(DEL) $(LOCALFPMAKE)
endif
cleanall: distclean
install: fpmake$(SRCEXEEXT)
ifdef UNIXHier
$(LOCALFPMAKE) install $(FPMAKE_OPT) --prefix=$(INSTALL_PREFIX) --baseinstalldir=$(INSTALL_LIBDIR)/fpc/$(FPC_VERSION) --unitinstalldir=$(INSTALL_UNITDIR)
else
$(LOCALFPMAKE) install $(FPMAKE_OPT) --prefix=$(INSTALL_BASEDIR) --baseinstalldir=$(INSTALL_BASEDIR) --unitinstalldir=$(INSTALL_UNITDIR)
endif
# distinstall also installs the example-sources and omits the location of the source-
# files from the fpunits.cfg files.
distinstall: fpmake$(SRCEXEEXT)
ifdef UNIXHier
$(LOCALFPMAKE) install $(FPMAKE_OPT) --prefix=$(INSTALL_PREFIX) --baseinstalldir=$(INSTALL_LIBDIR)/fpc/$(FPC_VERSION) --unitinstalldir=$(INSTALL_UNITDIR) -ie -fsp 0
else
$(LOCALFPMAKE) install $(FPMAKE_OPT) --prefix=$(INSTALL_BASEDIR) --baseinstalldir=$(INSTALL_BASEDIR) --unitinstalldir=$(INSTALL_UNITDIR) -ie -fsp 0
endif
zipinstall: fpmake$(SRCEXEEXT)
$(LOCALFPMAKE) zipinstall $(FPMAKE_OPT) --zipprefix=$(DIST_DESTDIR)/$(ZIPPREFIX)
zipdistinstall: fpmake$(SRCEXEEXT)
$(LOCALFPMAKE) zipinstall $(FPMAKE_OPT) --zipprefix=$(DIST_DESTDIR)/$(ZIPPREFIX) -ie -fsp 0
zipsourceinstall: fpmake$(SRCEXEEXT)
ifdef UNIXHier
$(LOCALFPMAKE) archive $(FPMAKE_OPT) --zipprefix=$(DIST_DESTDIR)/$(ZIPPREFIX) --prefix=share/src/fpc-\$$\(PACKAGEVERSION\)/$(INSTALL_FPCSUBDIR)/\$$\(PACKAGEDIRECTORY\)
else
$(LOCALFPMAKE) archive $(FPMAKE_OPT) --zipprefix=$(DIST_DESTDIR)/$(ZIPPREFIX) --prefix=source\\$(INSTALL_FPCSUBDIR)\\\$$\(PACKAGEDIRECTORY\)
endif

2
packages/tosunits/README.txt Normal file
View File

@ -0,0 +1,2 @@
This package contains interface units for Atari TOS/GEM, the operating system
of Atari ST/STE/TT/Falcon machines and clones and compatibles.

37
packages/tosunits/fpmake.pp Normal file
View File

@ -0,0 +1,37 @@
{$ifndef ALLPACKAGES}
{$mode objfpc}{$H+}
program fpmake;
uses fpmkunit;
Var
P : TPackage;
T : TTarget;
begin
With Installer do
begin
{$endif ALLPACKAGES}
P:=AddPackage('tosunits');
P.Author := 'FPC core team';
P.License := 'LGPL with modification';
P.HomepageURL := 'www.freepascal.org';
P.Description := 'tosunits, OS interface units for Atari TOS/GEM';
{$ifdef ALLPACKAGES}
P.Directory:=ADirectory;
{$endif ALLPACKAGES}
P.Version:='3.1.1';
P.SourcePath.Add('src');
P.OSes:=[atari];
T:=P.Targets.AddUnit('gemdos.pas');
T:=P.Targets.AddUnit('xbios.pas');
{$ifndef ALLPACKAGES}
Run;
end;
end.
{$endif ALLPACKAGES}

169
packages/tosunits/src/gemdos.pas Normal file
View File

@ -0,0 +1,169 @@
{
Copyright (c) 2016 by Free Pascal development team
GEMDOS interface unit for Atari TOS
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
unit gemdos;
interface
{ The API description of this file is based on the information available
online at: http://toshyp.atari.org }
const
E_OK = 0; // OK. No error has arisen
EINVFN = -32; // Unknown function number
EFILNF = -33; // File not found
EPTHNF = -34; // Directory (folder) not found
ENHNDL = -35; // No more handles available
EACCDN = -36; // Access denied
EIHNDL = -37; // Invalid file handle
ENSMEM = -39; // Insufficient memory
EIMBA = -40; // Invalid memory block address
EDRIVE = -46; // Invalid drive specification
ECWD = -47; // Current directory cannot be deleted
ENSAME = -48; // Files on different logical drives
ENMFIL = -49; // No more files can be opened
ELOCKED = -58; // Segment of a file is protected (network)
ENSLOCK = -59; // Invalid lock removal request
ERANGE = -64; // File pointer in invalid segment (see also FreeMiNT message -88)
EINTRN = -65; // Internal error of GEMDOS
EPLFMT = -66; // Invalid program load format
EGSBF = -67; // Allocated memory block could not be enlarged
EBREAK = -68; // Program termination by Control-C
EXCPT = -69; // 68000 exception (bombs)
EPTHOV = -70; // Path overflow
ELOOP = -80; // Endless loop with symbolic links
EPIPE = -81; // Write to broken pipe.
// as used by fseek
const
SEEK_FROM_START = 0;
SEEK_FROM_CURRENT = 1;
SEEK_FROM_END = 2;
// as used by fcreate and fattrib
const
ATTRIB_WRITE_PROT = ( 1 shl 0 );
ATTRIB_HIDDEN = ( 1 shl 1 );
ATTRIB_SYSTEM = ( 1 shl 2 );
ATTRIB_VOLUME_LABEL = ( 1 shl 3 );
ATTRIB_DIRECTORY = ( 1 shl 4 );
ATTRIB_ARCHIVE = ( 1 shl 5 );
// as used by fopen
const
OPEN_READ_ONLY = ( 1 shl 0 );
OPEN_WRITE_ONLY = ( 1 shl 1 );
OPEN_READ_WRITE = ( 1 shl 2 );
// as used by fattrib
const
FLAG_GET = 0;
FLAG_SET = 1;
type
PDTA = ^TDTA;
TDTA = packed record
d_reserved: array[0..20] of shortint; {* Reserved for GEMDOS *}
d_attrib: byte; {* File attributes *}
d_time: word; {* Time *}
d_date: word; {* Date *}
d_length: dword; {* File length *}
d_fname: array[0..13] of char; {* Filename *}
end;
type
PDISKINFO = ^TDISKINFO;
TDISKINFO = record
b_free: dword; {* Number of free clusters *}
b_total: dword; {* Total number of clusters *}
b_secsiz: dword; {* Bytes per sector *}
b_clsiz: dword; {* Sector per cluster *}
end;
type
PDOSTIME = ^TDOSTIME;
TDOSTIME = record
time: word; {* Time like Tgettime *}
date: word; {* Date like Tgetdate *}
end;
type
PPD = ^TPD;
TPD = record
p_lowtpa: pointer; {* Start address of the TPA *}
p_hitpa: pointer; {* First byte after the end of the TPA *}
p_tbase: pointer; {* Start address of the program code *}
p_tlen: longint; {* Length of the program code *}
p_dbase: pointer; {* Start address of the DATA segment *}
p_dlen: longint; {* Length of the DATA section *}
p_bbase: pointer; {* Start address of the BSS segment *}
p_blen: longint; {* Length of the BSS section *}
p_dta: PDTA; {* Pointer to the default DTA *}
{* Warning: Points first to the *}
{* command line ! *}
p_parent: PPD; {* Pointer to the basepage of the *}
{* calling processes *}
p_resrvd0: longint; {* Reserved *}
p_env: pchar; {* Address of the environment string *}
p_resrvd1: array[0..79] of char; {* Reserved *}
p_cmdlin: array[0..127] of char; {* Command line *}
end;
TBASEPAGE = TPD; {* alias types... *}
PBASEPAGE = ^TBASEPAGE;
procedure gemdos_cconws(p: pchar); syscall 1 9;
function gemdos_dsetdrv(drv: smallint): longint; syscall 1 14;
function gemdos_dgetdrv: smallint; syscall 1 25;
procedure gemdos_setdta(buf: PDTA); syscall 1 26;
function gemdos_tgetdate: longint; syscall 1 42;
function gemdos_tgettime: longint; syscall 1 44;
function gemdos_getdta: PDTA; syscall 1 47;
function gemdos_sversion: smallint; syscall 1 48;
function gemdos_dfree(buf: PDISKINFO; driveno: smallint): smallint; syscall 1 54;
function gemdos_dcreate(const path: pchar): longint; syscall 1 57;
function gemdos_ddelete(const path: pchar): longint; syscall 1 58;
function gemdos_dsetpath(path: pchar): smallint; syscall 1 59;
function gemdos_fcreate(fname: pchar; attr: smallint): smallint; syscall 1 60;
function gemdos_fopen(fname: pchar; mode: smallint): longint; syscall 1 61;
function gemdos_fclose(handle: smallint): smallint; syscall 1 62;
function gemdos_fread(handle: smallint; count: longint; buf: pointer): longint; syscall 1 63;
function gemdos_fwrite(handle: smallint; count: longint; buf: pointer): longint; syscall 1 64;
function gemdos_fdelete(fname: pchar): smallint; syscall 1 65;
function gemdos_fseek(offset: longint; handle: smallint; seekmode: smallint): longint; syscall 1 66;
function gemdos_fattrib(filename: pchar; wflag: smallint; attrib: smallint): smallint; syscall 1 67;
function gemdos_dgetpath(path: pchar; driveno: smallint): smallint; syscall 1 71;
function gemdos_malloc(number: dword): pointer; syscall 1 72;
function gemdos_free(block: pointer): dword; syscall 1 73;
function gemdos_mshrink(zero: word; block: pointer; newsiz: longint): longint; syscall 1 74;
function gemdos_pexec(mode: word; name: pchar; cmdline: pchar; env: pchar): longint; syscall 1 75;
procedure gemdos_pterm(returncode: smallint); syscall 1 76;
function gemdos_fsfirst(filename: pchar; attr: smallint): longint; syscall 1 78;
function gemdos_fsnext: smallint; syscall 1 79;
function gemdos_frename(zero: word; oldname: pchar; newname: pchar): longint; syscall 1 86;
procedure gemdos_fdatime(timeptr: PDOSTIME; handle: smallint; wflag: smallint); syscall 1 87;
implementation
end.

26
packages/tosunits/src/xbios.pas Normal file
View File

@ -0,0 +1,26 @@
{
Copyright (c) 2016 by Free Pascal development team
XBIOS interface unit for Atari TOS
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
unit xbios;
interface
{ The API description of this file is based on the information available
online at: http://toshyp.atari.org }
function xbios_random: longint; syscall 14 17;
implementation
end.