examples/strtol.cl

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          getenv.cl
   6 ;;;; Purpose:       UFFI Example file to strtol
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Mar 2002
   9 ;;;;
  10 ;;;; Copyright (c) 2002 Kevin M. Rosenberg
  11 ;;;;
  12 ;;;; $Id: strtol.cl,v 1.1 2002/03/09 19:55:33 kevin Exp $
  13 ;;;;
  14 ;;;; This file is part of UFFI.
  15 ;;;;
  16 ;;;; UFFI is free software; you can redistribute it and/or modify
  17 ;;;; it under the terms of the GNU General Public License (version 2) as
  18 ;;;; published by the Free Software Foundation.
  19 ;;;;
  20 ;;;; UFFI is distributed in the hope that it will be useful,
  21 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  22 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  23 ;;;; GNU General Public License for more details.
  24 ;;;;
  25 ;;;; You should have received a copy of the GNU General Public License
  26 ;;;; along with UFFI; if not, write to the Free Software Foundation, Inc.,
  27 ;;;; 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  28 ;;;; *************************************************************************
  29
  30 (in-package :cl-user)
  31
  32 (uffi:def-type char-ptr (* :char))
  33
  34 ;; This example does not use :c-string to pass the input string since
  35 ;; the routine needs to do pointer arithmetic to see how many characters
  36 ;; were parsed
  37
  38 (uffi:def-routine ("strtol" c-strtol)
  39     ((nptr (* :char))
  40      (endptr (* char-ptr))
  41      (base :int))
  42   :returning :long)
  43
  44 (defun strtol (str &optional (base 10))
  45   "Returns a long int from a string. Returns number and condition flag.
  46 Condition flag is T if all of string parses as a long, NIL if
  47 their was no string at all, or an integer indicating position in string
  48 of first non-valid character"
  49   (let* ((str-native (uffi:convert-to-foreign-string str))
  50          (endptr (uffi:allocate-foreign-object char-ptr))
  51          (value (c-strtol str-native endptr base))
  52          (endptr-value (uffi:deref-pointer endptr 'char-ptr))
  53          (next-char-value (uffi:deref-pointer endptr-value :char))
  54          (chars-parsed (- (uffi:pointer-address endptr-value)
  55                           (uffi:pointer-address str-native))))
  56     (uffi:free-foreign-object str-native)
  57     (uffi:free-foreign-object endptr)
  58     (cond
  59      ((zerop chars-parsed)
  60       (values nil nil))
  61      ((uffi:null-char-p next-char-value)
  62       (values value t))
  63      (t
  64       (values value chars-parsed)))))
  65