From e571bd869376b0cfac853f82a15513f86bf899ed Mon Sep 17 00:00:00 2001
From: Karoly Balogh <karoly@freepascal.org>
Date: Mon, 22 Jul 2024 00:52:54 +0200
Subject: [PATCH] h68units: added an initial version of an  IOCS API unit with
 some graphics related calls, and an example program using it

---
 packages/h68units/examples/gradient.pas       | 71 +++++++++++++++++++
 packages/h68units/fpmake.pp                   |  4 ++
 .../h68units/namespaced/Human68kApi.IOCS.pas  |  3 +
 packages/h68units/src/h68kiocs.pas            | 63 ++++++++++++++++
 4 files changed, 141 insertions(+)
 create mode 100644 packages/h68units/examples/gradient.pas
 create mode 100644 packages/h68units/namespaced/Human68kApi.IOCS.pas
 create mode 100644 packages/h68units/src/h68kiocs.pas

diff --git a/packages/h68units/examples/gradient.pas b/packages/h68units/examples/gradient.pas
new file mode 100644
index 0000000000..fa7746172d
--- /dev/null
+++ b/packages/h68units/examples/gradient.pas
@@ -0,0 +1,71 @@
+{
+    Copyright (c) 2024 Karoly Balogh
+
+    32K color gradients on a 256x256 screen
+    Example program for Free Pascal's Human 68k bindings
+
+    This example program is in the Public Domain under the terms of
+    Unlicense: http://unlicense.org/
+
+ **********************************************************************}
+
+program gradient;
+
+uses
+  h68kdos, h68kiocs;
+
+const
+  GVRAM_START = $C00000;
+  COMPONENT_MASK = %11111000;
+
+var
+  super: longint;
+  lastmode: longint;
+
+procedure gfx_init;
+begin
+  lastmode:=_iocs_crtmod(-1);
+  _iocs_crtmod(14);  { 256x256, 64k, 31Khz }
+  _iocs_vpage(0);
+  _iocs_g_clr_on;
+  _iocs_b_curoff;
+end;
+
+procedure gfx_done;
+begin
+  writeln('Press Enter...');
+  readln;
+  _iocs_crtmod(lastmode);
+  _iocs_b_curon;
+end;
+
+procedure gfx_gradient;
+var
+  addr: pword;
+  x,y: longint;
+  r,b: longint;
+begin
+  addr:=pword(GVRAM_START);
+  super:=h68kdos_super(0);
+
+  for y:=0 to 255 do
+    begin
+      r:=(y and COMPONENT_MASK) shl 3;
+      b:=((255-y) and COMPONENT_MASK) shr 2;
+      for x:=0 to 255 do
+        begin
+          addr^:=((x and COMPONENT_MASK) shl 8) or
+                 r or b or 1;
+          inc(addr);
+        end;
+      inc(addr,256);
+    end;
+
+  h68kdos_super(super);
+end;
+
+begin
+  gfx_init;
+  gfx_gradient;
+  gfx_done;
+end.
diff --git a/packages/h68units/fpmake.pp b/packages/h68units/fpmake.pp
index e4087ccf8c..a7db80317d 100644
--- a/packages/h68units/fpmake.pp
+++ b/packages/h68units/fpmake.pp
@@ -34,6 +34,10 @@ begin
       begin
         AddInclude('h68kdos.inc');
       end;
+    T:=P.Targets.AddUnit('h68kiocs.pas');
+
+    P.ExamplePath.Add('examples');
+    T:=P.Targets.AddExampleProgram('gradient.pas');
 
     P.Sources.AddDoc('README.md');
 
diff --git a/packages/h68units/namespaced/Human68kApi.IOCS.pas b/packages/h68units/namespaced/Human68kApi.IOCS.pas
new file mode 100644
index 0000000000..ea993cc14f
--- /dev/null
+++ b/packages/h68units/namespaced/Human68kApi.IOCS.pas
@@ -0,0 +1,3 @@
+unit Human68kApi.IOCS;
+{$DEFINE FPC_DOTTEDUNITS}
+{$i h68kiocs.pas}
diff --git a/packages/h68units/src/h68kiocs.pas b/packages/h68units/src/h68kiocs.pas
new file mode 100644
index 0000000000..9395b40b57
--- /dev/null
+++ b/packages/h68units/src/h68kiocs.pas
@@ -0,0 +1,63 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 20243 by Free Pascal development team
+
+    IOCS API unit for Human 68k (Sharp X68000)
+
+    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.
+
+ **********************************************************************}
+
+{$IFNDEF FPC_DOTTEDUNITS}
+unit h68kiocs;
+{$ENDIF FPC_DOTTEDUNITS}
+
+interface
+
+procedure _iocs_b_curon;
+procedure _iocs_b_curoff;
+function _iocs_crtmod(mode: longint): longint;
+procedure _iocs_g_clr_on;
+function _iocs_vpage(page: longint): longint;
+
+
+implementation
+
+procedure _iocs_b_curon; assembler; nostackframe;
+asm
+  moveq.l #$1e,d0
+  trap #15
+end;
+
+procedure _iocs_b_curoff; assembler; nostackframe;
+asm
+  moveq.l #$1f,d0
+  trap #15
+end;
+
+function _iocs_crtmod(mode: longint): longint; assembler; nostackframe;
+asm
+  move.l d0,d1
+  moveq.l #$10,d0
+  trap #15
+end;
+
+procedure _iocs_g_clr_on; assembler; nostackframe;
+asm
+  moveq.l #$ffffff90,d0
+  trap #15
+end;
+
+function _iocs_vpage(page: longint): longint; assembler; nostackframe;
+asm
+  move.l d0,d1
+  moveq.l #$ffffffb2,d0
+  trap #15
+end;
+
+end.