cpas.pas

delphi编的不错的贪吃蛇

(*==============================================================================
   Copyright (C) 2002 THallium Software

   This program is free software; you can redistribute it and/or
   modify it under the terms of the GNU General Public License
   as published by the Free Software Foundation; either version 2
   of the License, or (at your option) any later version.

   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

   See the GNU General Public License for more details.
==============================================================================*)

(*==============================================================================
   THallium Software
       Author  : Thomas Lavergne ([e-mail])
       Version : 0.1.0 alpha

   History :
       16/01/2001 : v0.1.0 alpha, mostly untested
       04/07/2002 : (Juha Hartikainen) Fixed memcmp and strcmp functions

   Bug :
       none (most of this file was untested)
==============================================================================*)

(*==============================================================================
   CPas try to help you to convert C programs to Pascal.
   It provide consts, types and functions commonly used in C.
   A big part of this project is a translation of the c standard lib.

   Some of functions in this file was present in recent version of SysUtils,
   but I don't want to include SysUtils, I try to provide most C functions I
   can without any other unit.

   Some of these function was not optimised, in first time I prefer add two
   slow functions rather than one optimised.
==============================================================================*)

(*==============================================================================
   Todo
     - Make a lot of tests.
     - Convert stdio.h : a lot of work, I do this in three part
         first I convert printf and similar
         second I convert file handling
         finally all the other (not a lot of stuff here)
     - Optimise code : I don't known if I can really optimise a lot if keep
         code in pascal, but some function could be rewritten in asm.
==============================================================================*)
unit CPas;

interface

//==============================================================================
// Basic types and pointers
//==============================================================================
  (*
type
  // Basic C types
  short             = SmallInt;
  shortint          = SmallInt;
  signedshort       = SmallInt;
  signedshortint    = SmallInt;
  unsignedshort     = Word;
  unsignedshortint  = Word;
  int               = Integer;
  signed            = Integer;
  signedint         = Integer;
  unsigned          = Cardinal;
  unsignedint       = Cardinal;
  long              = LongInt;
  signedlong        = LongInt;
  signedlongint     = LongInt;
  unsignedlong      = LongWord;
  unsignedlongint   = LongWord;
  unsignedchar      = Char;
  signedchar        = SmallInt;
  float             = Single;

  // Pointers to basic C types
  Pshort            = ^SmallInt;
  Pshortint         = ^SmallInt;
  Psignedshort      = ^SmallInt;
  Psignedshortint   = ^SmallInt;
  Punsignedshort    = ^Word;
  Punsignedshortint = ^Word;
  Pint              = ^Integer;
  Psigned           = ^Integer;
  Psignedint        = ^Integer;
  Punsigned         = ^Cardinal;
  Punsignedint      = ^Cardinal;
  Plong             = ^LongInt;
  Plongint          = ^LongInt;
  Psignedlong       = ^LongInt;
  Psignedlongint    = ^LongInt;
  Punsignedlong     = ^LongWord;
  Punsignedlongint  = ^LongWord;
  Punsignedchar     = ^Char;
  Psignedchar       = ^SmallInt;
  Pfloat            = ^Single;

  // Somme Pointer to array (usefull for working on buffers);
//  PByteArray = ^TByteArray;
//  TByteArray = array[0..32767] of Byte;

  PWordArray = ^TWordArray;
  TWordArray = array[0..0] of Word;

  PLongWordArray = ^TLongWordArray;
  TLongWordArray = array[0..0] of Word;
  *)

//==============================================================================
// Stddef.h
//==============================================================================
type
  ptrdiff_t = Integer;
  size_t = Integer;

const
  NULL = nil;

  //==============================================================================
  // Stdlib.h
  //==============================================================================
type
  div_t = packed record
    quot, rem: Integer;
  end;
  ldiv_t = packed record
    quot, rem: LongInt;
  end;

const
  EXIT_SUCCESS = 0;
  EXIT_FAILURE = 1;

function calloc(nb_blocs, size: size_t): Pointer;
function malloc(size: size_t): Pointer;
procedure realloc(adr: Pointer; size: size_t);
procedure free(adr: Pointer);

procedure abort_;
procedure exit_(state: Integer);

function div_(num, den: Integer): div_t;
function ldiv(num, den: LongInt): ldiv_t;

//==============================================================================
// stdlib.h
//==============================================================================

function rand: Integer;

//==============================================================================
// Ctype.h
//==============================================================================
function isalnum(c: Integer): integer;
function isalpha(c: Integer): integer;
function iscntrl(c: Integer): integer;
function isdigit(c: Integer): integer;
function isgraph(c: Integer): integer;
function islower(c: Integer): integer;
function isprint(c: Integer): integer;
function ispunct(c: Integer): integer;
function isspace(c: Integer): integer;
function isupper(c: Integer): integer;
function isxdigit(c: Integer): integer;

//==============================================================================
// String.h
//==============================================================================
function memcpy(dst: Pointer; const src: Pointer; len: size_t): Pointer;
function memmove(dst: Pointer; const src: Pointer; len: size_t): Pointer;
function strcpy(dst: PChar; const src: PChar): PChar;
function strncpy(dst: PChar; const src: PChar; len: size_t): PChar;

function strcat(dst: PChar; const src: PChar): PChar;
function strncat(dst: PChar; const src: PChar; len: size_t): PChar;

function memcmp(const buf1, buf2: Pointer; len: size_t): Integer;
function strcmp(const str1, str2: PChar): Integer;
function strcoll(const str1, str2: PChar): Integer;
function strncmp(const str1, str2: PChar; len: size_t): Integer;
function strxfrm(dst: PChar; const src: PChar; len: size_t): size_t;

function memchr(const buf: Pointer; c: Integer; len: size_t): Pointer;
function strchr(const str: PChar; c: Integer): PChar;
function strcspn(const str1, str2: PChar): size_t;
function strpbrk(const str1, str2: PChar): PChar;
function strrchr(const str: PChar; c: Integer): PChar;
function strspn(const str1, str2: PChar): size_t;
function strstr(const str1, str2: PChar): PChar;
function strtok(str: PChar; const tok: PChar): PChar;

function memset(buf: Pointer; c: Integer; len: size_t): Pointer;
function strerror(nb_error: Integer): PChar;
function strlen(const str1: PChar): size_t;

function atoi(s: PChar): Integer;
function atof(s: PChar): Single;
function sscanf(const s: PChar; const fmt: PChar;
  const pointers: array of Pointer): Integer;

type
  QSortCB = function(const arg1, arg2: Pointer): Integer;

procedure qsort(base: Pointer; num: Size_t; width: Size_t; compare: QSortCB);

implementation

uses
  SysUtils;

procedure qsort_int(base: Pointer; width: Integer; compare: QSortCB; Left, Right: Integer; TempBuffer, TempBuffer2: Pointer);
var
  Lo, Hi: Integer;
  P: Pointer;
begin
  Lo := Left;
  Hi := Right;
  P := Pointer(Integer(base) + ((Lo + Hi) div 2) * width);
  Move(P^, TempBuffer2^, width);
  repeat
    while compare(Pointer(Integer(base) + Lo * width), TempBuffer2) < 0 do
      Inc(Lo);
    while compare(Pointer(Integer(base) + Hi * width), TempBuffer2) > 0 do
      Dec(Hi);
    if Lo <= Hi then
    begin
      Move(Pointer(Integer(base) + Lo * width)^, TempBuffer^, width);
      Move(Pointer(Integer(base) + Hi * width)^, Pointer(Integer(base) + Lo * width)^, width);
      Move(TempBuffer^, Pointer(Integer(base) + Hi * width)^, width);
      Inc(Lo);
      Dec(Hi);
    end;
  until Lo > Hi;
  if Hi > Left then
    qsort_int(base, width, compare, Left, Hi, TempBuffer, TempBuffer2);
  if Lo < Right then
    qsort_int(base, width, compare, Lo, Right, TempBuffer, TempBuffer2);
end;

procedure qsort(base: Pointer; num: Size_t; width: Size_t; compare: QSortCB);
var
  tmp1, tmp2: Pointer;
begin
  // Juha: Small tweak to avoid unnnecessary memory allocation.
  if num < 2 then
    exit;
  GetMem(tmp1, width);
  GetMem(tmp2, width);
  try
    qsort_int(base, width, compare, 0, num - 1, tmp1, tmp2);
  finally
    FreeMem(tmp1, width);
    FreeMem(tmp2, width);
  end;
end;

//==============================================================================
// Stdlib.h
//==============================================================================

function calloc(nb_blocs, size: size_t): Pointer;
begin
  Result := malloc(nb_blocs * size);
end;

function malloc(size: size_t): Pointer;
begin
  GetMem(Result, size);
end;

procedure realloc(adr: Pointer; size: size_t);
begin
  ReallocMem(adr, size);
end;

procedure free(adr: Pointer);
begin
  FreeMem(adr);
end;

procedure abort_;
begin
  exit_(EXIT_FAILURE);
end;

procedure exit_(state: Integer);
begin
  Halt(state);
end;

function div_(num, den: Integer): div_t;
begin
  Result.quot := num div den;
  Result.rem := num mod den;
end;

function ldiv(num, den: LongInt): ldiv_t;
begin
  Result.quot := num div den;
  Result.rem := num mod den;
end;

//==============================================================================
// stdlib.h
//==============================================================================

function rand: Integer;
const
  RAND_MAX = $7FFF;
begin
  Result := Random(RAND_MAX);
end;

//==============================================================================
// Ctype.h
//==============================================================================

function isalnum(c: Integer): integer;
begin
  if Chr(c) in ['a'..'z', 'A'..'Z', '0'..'9'] then
    Result := 1
  else
    Result := 0;
end;

function isalpha(c: Integer): integer;
begin
  if Chr(c) in ['a'..'z', 'A'..'Z'] then
    Result := 1
  else
    Result := 0;
end;

function iscntrl(c: Integer): integer;
begin
  if Chr(c) in [#0..#31, #127] then
    Result := 1
  else
    Result := 0;
end;

function isdigit(c: Integer): integer;
begin
  if Chr(c) in ['0'..'9'] then
    Result := 1
  else
    Result := 0;
end;

function isgraph(c: Integer): integer;
begin
  if Chr(c) in [#33..#126, #128..#254] then
    Result := 1
  else
    Result := 0;
end;

function islower(c: Integer): integer;
begin
  if Chr(c) in ['a'..'z'] then
    Result := 1
  else
    Result := 0;
end;

function isprint(c: Integer): integer;
begin
  if Chr(c) in [#32..#126, #128..#254] then
    Result := 1
  else
    Result := 0;
end;

function ispunct(c: Integer): integer;
begin
  Result := 0;
  if isprint(c) = 1 then
    if (isalnum(c) + isspace(c)) = 0 then
      Result := 1;
end;

function isspace(c: Integer): integer;
begin
  if Chr(c) in [#09, #10, #11, #13, #32] then
    Result := 1
  else
    Result := 0;
end;

function isupper(c: Integer): integer;
begin
  if Chr(c) in ['A'..'Z'] then
    Result := 1
  else
    Result := 0;
end;

function isxdigit(c: Integer): integer;
begin
  if Chr(c) in ['a'..'f', 'A'..'F', '0'..'9'] then
    Result := 1
  else
    Result := 0;
end;