Changeset 13148 in project


Ignore:
Timestamp:
02/02/09 08:17:31 (11 years ago)
Author:
Kon Lovett
Message:

distribution/manifest : added lolevel test
tests/lolevel-tests.scm : new lolevel test (incomplete)
runtime.c : MacOS X is-a BSD
lolevel.scm : better arg checks, grouping, added record-instance procs.
chicken.h : grouped like, comments, swig-pointer is now special
manual/Unit lolevel : discussion of pointer-like & vector-like
chicken-primitive-inlines.scm : wrond identifier for unbound value predicate

Location:
chicken/trunk
Files:
1 added
7 edited

Legend:

Unmodified
Added
Removed
  • chicken/trunk/chicken-primitive-inlines.scm

    r13146 r13148  
    4848;; Unbound (the unbound value, not is a symbol unbound)
    4949
    50 (define-inline (%unbound? x) (##core#inline "C_unboundp" x))
     50(define-inline (%unbound? x) (##core#inline "C_unboundvaluep" x))
    5151
    5252;; Block (anything not immediate)
  • chicken/trunk/chicken.h

    r13041 r13148  
    99;
    1010;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
    11 ;     disclaimer. 
     11;     disclaimer.
    1212;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
    13 ;     disclaimer in the documentation and/or other materials provided with the distribution. 
     13;     disclaimer in the documentation and/or other materials provided with the distribution.
    1414;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
    15 ;     products derived from this software without specific prior written permission. 
     15;     products derived from this software without specific prior written permission.
    1616;
    1717; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
     
    2828/* Configuration: */
    2929
     30/*
     31 * The Watcom (__WATCOMC__), Metroworks (__MWERKS__), and Delorie (__DJGPP__)
     32 * compilers are not currently supported but existing references remain,
     33 * just in case.
     34 */
     35
    3036#ifndef ___CHICKEN
    3137#define ___CHICKEN
     
    4046#endif
    4147
    42 #if !defined(__GNUC__)
     48
     49/* Kind of platform */
     50
     51#ifndef C_SIXTY_FOUR
     52# if defined (__alpha__) || defined (__sparc_v9__) || defined (__sparcv9) || defined(__ia64__) || defined(__x86_64__) || defined(__LP64__) || defined(__powerpc64__)
     53#   define C_SIXTY_FOUR
     54# elif defined(__mips64) && (!defined(__GNUC__) || _MIPS_SZPTR == 64)
     55#   define C_SIXTY_FOUR
     56# endif
     57#endif
     58
     59#if defined(__APPLE__) && defined(__MACH__)
     60# define C_MACOSX
     61#endif
     62
     63#if defined(C_MACOSX) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) || defined(__OpenBSD__)
     64# define C_XXXBSD
     65#endif
     66
     67#if /*defined(__GNUC__) &&*/ (defined(__linux__) || defined(C_XXXBSD))
     68# define C_GNU_ENV
     69#endif
     70
     71#if defined(_MSC_VER) || defined(__MINGW32__) || defined(__WATCOMC__) || defined(__MWERKS__) || defined(__DJGPP__)
     72# define C_NONUNIX
     73#endif
     74
     75
     76/* Headers */
     77
     78#include <stdio.h>
     79#include <stdlib.h>
     80#include <stdarg.h>
     81#include <ctype.h>
     82#include <string.h>
     83#include <setjmp.h>
     84#include <limits.h>
     85#include <time.h>
     86
     87#if !defined(C_NONUNIX) || defined(__MINGW32__) || defined(__WATCOMC__)
     88# include <unistd.h>
     89# include <inttypes.h>
     90# include <sys/types.h>
     91#endif
     92
     93/* Byteorder in machine word */
     94
     95#if defined(__MINGW32__)
     96# include <sys/param.h>
     97#elif defined(__CYGWIN__)
     98# include <endian.h>
     99#elif defined(__linux__)
     100# include <endian.h>
     101#elif defined(C_XXXBSD)
     102# include <machine/endian.h>
     103#elif defined(__hpux__)
     104# include <arpa/nameser.h>
     105#elif defined(_AIX)
     106# include <sys/machine.h>
     107#elif defined(__sun__)
     108# include <sys/isa_defs.h>
     109#elif defined(__svr4__)
     110# include <sys/byteorder.h>
     111#endif
     112
     113#if defined(_MSC_VER) || defined(__MINGW32__) || defined(__WATCOMC__)
     114# include <malloc.h>
     115#endif
     116
     117#ifdef _MSC_VER
     118# include <io.h>
     119#endif
     120
     121/* Much better with stack allocation API */
     122
     123#if defined(_MSC_VER)
     124# if HAVE_ALLOCA_H
     125#  define alloca            _alloca
     126# endif
     127#elif !defined(__GNUC__) && !defined(__WATCOMC__)
    43128# if HAVE_ALLOCA_H
    44129#  include <alloca.h>
    45 # else
    46 #  ifdef _AIX
     130# elif defined(_AIX)
    47131#   pragma alloca
    48 #  else
    49 #   ifndef alloca /* predefined by HP cc +Olibcalls */
    50 char *alloca ();
    51 #   endif
    52 #  endif
     132# elif !defined(alloca) /* predefined by HP cc +Olibcalls */
     133    char *alloca ();
    53134# endif
    54135#elif (defined(__sun__) && defined(__svr4__)) || defined(__sgi__)
     
    58139#endif
    59140
     141
     142/* Chicken Core C API */
     143
     144#if defined(__BYTE_ORDER) && __BYTE_ORDER == __BIG_ENDIAN
     145# define C_BIG_ENDIAN
     146#elif defined(BYTE_ORDER) && defined(BIG_ENDIAN) && BYTE_ORDER == BIG_ENDIAN
     147# define C_BIG_ENDIAN
     148#elif defined(__BIG_ENDIAN__)
     149# define C_BIG_ENDIAN
     150#elif defined(__sparc__) || defined(__POWERPC__) || defined(__MC68K__) || defined(__mips__)
     151# define C_BIG_ENDIAN
     152#endif
     153
     154#if defined(__BYTE_ORDER) && defined(__LITTLE_ENDIAN) && __BYTE_ORDER == __LITTLE_ENDIAN
     155# define C_LITTLE_ENDIAN
     156#elif defined(BYTE_ORDER) && defined(LITTLE_ENDIAN) && BYTE_ORDER == LITTLE_ENDIAN
     157# define C_LITTLE_ENDIAN
     158#elif defined(__LITTLE_ENDIAN__)
     159# define C_LITTLE_ENDIAN
     160#elif defined (__alpha__) || defined(_M_IX86) || defined(__i386__) || defined(__x86_64__) || defined(__ia64__)
     161# define C_LITTLE_ENDIAN
     162#endif
     163
     164/* Make sure some common C identifiers are availble w/ Windows */
     165
     166#ifdef _MSC_VER
     167# define strncasecmp       strnicmp
     168# define isatty            _isatty
     169typedef __int8             int8_t;
     170typedef unsigned __int8    uint8_t;
     171typedef __int16            int16_t;
     172typedef unsigned  __int16  uint16_t;
     173typedef __int32            int32_t;
     174typedef unsigned __int32   uint32_t;
     175typedef __int64            int64_t;
     176typedef unsigned __int64   uint64_t;
     177# pragma warning(disable: 4101)
     178#endif
     179
     180/* Could be used by C++ source */
     181
    60182#ifdef __cplusplus
    61183# define C_extern                  extern "C"
     
    67189# define C_END_C_DECLS
    68190#endif
    69  
     191
     192
     193/* Function declaration modes */
     194
     195/* Visibility */
    70196#define C_varextern                C_extern
    71197#define C_fctimport
     
    116242#endif
    117243
     244/* Language specifics: */
     245#if defined(__GNUC__) || defined(__INTEL_COMPILER)
     246# ifndef __cplusplus
     247#  define C_cblock                ({
     248#  define C_cblockend             })
     249#  define C_noret                 __attribute__ ((noreturn))
     250#  define C_noret_decl(name)
     251#  define C_aligned               __attribute__ ((aligned))
     252# endif
     253# ifdef __i386__
     254#  define C_regparm               __attribute__ ((regparm(3)))
     255# endif
     256#elif defined(_MSC_VER)
     257# define C_fcall                  __fastcall
     258#elif defined(__WATCOMC__)
     259# define C_ccall                  __cdecl
     260#endif
     261
     262#ifndef C_cblock
     263# define C_cblock                 do{
     264# define C_cblockend              }while(0)
     265# define C_noret
     266# define C_noret_decl(name)
     267#endif
     268
     269#ifndef C_regparm
     270# define C_regparm
     271#endif
     272
     273#ifndef C_fcall
     274# define C_fcall
     275#endif
     276
     277#ifndef C_ccall
     278# define C_ccall
     279#endif
     280
     281#ifndef C_aligned
     282# define C_aligned
     283#endif
     284
     285#define C_c_regparm
     286
     287/* Thread Local Stoarage */
    118288#ifdef C_ENABLE_TLS
    119289# if defined(__GNUC__)
     
    127297# define C_TLS
    128298#endif
     299
     300
     301/* Stack growth direction; used to compute stack addresses */
    129302
    130303#ifndef C_STACK_GROWS_DOWNWARD
     
    142315#endif
    143316
     317/* Have a GUI? */
     318
    144319#if defined(C_WINDOWS_GUI)
    145320# define C_MICROSOFT_WINDOWS
     
    148323#endif
    149324
     325/* Needed for pre-emptive threading */
     326
    150327#define C_TIMER_INTERRUPTS
    151 
    152 #ifdef C_DEFAULT_TARGET_STACK_SIZE
    153 # define C_resize_stack(n)           C_do_resize_stack(C_DEFAULT_TARGET_STACK_SIZE)
    154 #else
    155 # define C_resize_stack(n)           C_do_resize_stack(n)
    156 #endif
    157 
    158 #ifndef C_SIXTY_FOUR
    159 # if defined (__alpha__) || defined (__sparc_v9__) || defined (__sparcv9) || defined(__ia64__) || defined(__x86_64__) || defined(__LP64__) || defined(__powerpc64__)
    160 #   define C_SIXTY_FOUR
    161 # elif defined(__mips64) && (!defined(__GNUC__) || _MIPS_SZPTR == 64)
    162 #   define C_SIXTY_FOUR
    163 # endif
    164 #endif
    165 
    166 #if defined(__APPLE__) && defined(__MACH__)
    167 # define C_MACOSX
    168 #endif
    169 
    170 #if defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) || defined(__OpenBSD__)
    171 # define C_XXXBSD
    172 #endif
    173 
    174 #if defined(C_MACOSX) || defined(__linux__) || defined(C_XXXBSD)
    175 # define C_GNU_ENV
    176 #endif
    177 
    178 #if defined(_MSC_VER) || defined(__MINGW32__)
    179 # define C_NONUNIX
    180 #endif
    181 
    182 #include <stdio.h>
    183 #include <stdlib.h>
    184 #include <stdarg.h>
    185 #include <ctype.h>
    186 #include <string.h>
    187 #include <setjmp.h>
    188 #include <limits.h>
    189 #include <time.h>
    190 
    191 #if !defined(C_NONUNIX) || defined(__MINGW32__) || defined(__WATCOMC__)
    192 # include <unistd.h>
    193 # include <inttypes.h>
    194 # include <sys/types.h>
    195 #endif
    196 
    197 #if defined(__MINGW32__)
    198 # include <sys/param.h>
    199 #elif defined(__CYGWIN__)
    200 # include <endian.h>
    201 #elif defined(__linux__)
    202 # include <endian.h>
    203 #elif defined(C_MACOSX) || defined(C_XXXBSD)
    204 # include <machine/endian.h>
    205 #elif defined(__hpux__)
    206 # include <arpa/nameser.h>
    207 #elif defined(_AIX)
    208 # include <sys/machine.h>
    209 #elif defined(__sun__)
    210 # include <sys/isa_defs.h>
    211 #elif defined(__svr4__)
    212 # include <sys/byteorder.h>
    213 #endif
    214 
    215 #if defined(__BYTE_ORDER) && __BYTE_ORDER == __BIG_ENDIAN
    216 # define C_BIG_ENDIAN
    217 #elif defined(BYTE_ORDER) && defined(BIG_ENDIAN) && BYTE_ORDER == BIG_ENDIAN
    218 # define C_BIG_ENDIAN
    219 #elif defined(__BIG_ENDIAN__)
    220 # define C_BIG_ENDIAN
    221 #elif defined(__sparc__) || defined(__POWERPC__) || defined(__MC68K__) || defined(__mips__)
    222 # define C_BIG_ENDIAN
    223 #endif
    224 
    225 #if defined(__BYTE_ORDER) && defined(__LITTLE_ENDIAN) && __BYTE_ORDER == __LITTLE_ENDIAN
    226 # define C_LITTLE_ENDIAN
    227 #elif defined(BYTE_ORDER) && defined(LITTLE_ENDIAN) && BYTE_ORDER == LITTLE_ENDIAN
    228 # define C_LITTLE_ENDIAN
    229 #elif defined(__LITTLE_ENDIAN__)
    230 # define C_LITTLE_ENDIAN
    231 #elif defined (__alpha__) || defined(_M_IX86) || defined(__i386__) || defined(__x86_64__) || defined(__ia64__)
    232 # define C_LITTLE_ENDIAN
    233 #endif
    234 
    235 #ifdef __MINGW32__
    236 # include <malloc.h>
    237 #endif
    238 
    239 #ifdef _MSC_VER
    240 # include <malloc.h>
    241 # include <io.h>
    242 # define alloca            _alloca
    243 # define strncasecmp       strnicmp
    244 # define isatty            _isatty
    245 typedef __int8             int8_t;
    246 typedef unsigned __int8    uint8_t;
    247 typedef __int16            int16_t;
    248 typedef unsigned  __int16  uint16_t;
    249 typedef __int32            int32_t;
    250 typedef unsigned __int32   uint32_t;
    251 typedef __int64            int64_t;
    252 typedef unsigned __int64   uint64_t;
    253 # pragma warning(disable: 4101)
    254 #endif
    255 
    256 #ifdef __WATCOMC__
    257 # include <malloc.h>
    258 #endif
    259328
    260329/* For the easy FFI: */
     
    336405# define C_CLOSURE_TYPE           (0x0400000000000000L | C_SPECIALBLOCK_BIT)
    337406# define C_FLONUM_TYPE            (0x0500000000000000L | C_BYTEBLOCK_BIT | C_8ALIGN_BIT)
    338 # define C_UNUSED_TYPE            (0x0600000000000000L)
     407/*       unused                   (0x0600000000000000L ...) */
    339408# define C_PORT_TYPE              (0x0700000000000000L | C_SPECIALBLOCK_BIT)
    340409# define C_STRUCTURE_TYPE         (0x0800000000000000L)
    341410# define C_POINTER_TYPE           (0x0900000000000000L | C_SPECIALBLOCK_BIT)
    342 # define C_BUCKET_TYPE            (0x0f00000000000000L)
    343411# define C_LOCATIVE_TYPE          (0x0a00000000000000L | C_SPECIALBLOCK_BIT)
    344412# define C_TAGGED_POINTER_TYPE    (0x0b00000000000000L | C_SPECIALBLOCK_BIT)
    345 # define C_SWIG_POINTER_TYPE      (0x0c00000000000000L | C_BYTEBLOCK_BIT)
     413# define C_SWIG_POINTER_TYPE      (0x0c00000000000000L | C_SPECIALBLOCK_BIT)
    346414# define C_LAMBDA_INFO_TYPE       (0x0d00000000000000L | C_BYTEBLOCK_BIT)
     415/*       unused                   (0x0e00000000000000L ...) */
     416# define C_BUCKET_TYPE            (0x0f00000000000000L)
    347417#else
    348418# define C_INT_SIGN_BIT           0x80000000
     
    361431# define C_CLOSURE_TYPE           (0x04000000 | C_SPECIALBLOCK_BIT)
    362432# ifdef C_DOUBLE_IS_32_BITS
    363 #  define C_FLONUM_TYPE            (0x05000000 | C_BYTEBLOCK_BIT)
     433#  define C_FLONUM_TYPE           (0x05000000 | C_BYTEBLOCK_BIT)
    364434# else
    365 #  define C_FLONUM_TYPE            (0x05000000 | C_BYTEBLOCK_BIT | C_8ALIGN_BIT)
     435#  define C_FLONUM_TYPE           (0x05000000 | C_BYTEBLOCK_BIT | C_8ALIGN_BIT)
    366436# endif
    367 # define C_UNUSED_TYPE            (0x06000000)
     437/*       unused                   (0x06000000 ...) */
    368438# define C_PORT_TYPE              (0x07000000 | C_SPECIALBLOCK_BIT)
    369439# define C_STRUCTURE_TYPE         (0x08000000)
    370440# define C_POINTER_TYPE           (0x09000000 | C_SPECIALBLOCK_BIT)
    371 # define C_BUCKET_TYPE            (0x0f000000)
    372441# define C_LOCATIVE_TYPE          (0x0a000000 | C_SPECIALBLOCK_BIT)
    373442# define C_TAGGED_POINTER_TYPE    (0x0b000000 | C_SPECIALBLOCK_BIT)
    374 # define C_SWIG_POINTER_TYPE      (0x0c000000 | C_BYTEBLOCK_BIT)
     443# define C_SWIG_POINTER_TYPE      (0x0c000000 | C_SPECIALBLOCK_BIT)
    375444# define C_LAMBDA_INFO_TYPE       (0x0d000000 | C_BYTEBLOCK_BIT)
     445/*       unused                   (0x0e000000 ...) */
     446# define C_BUCKET_TYPE            (0x0f000000)
    376447#endif
    377448
     
    488559
    489560
    490 /* Language specifics: */
    491 #if defined(__GNUC__) || defined(__INTEL_COMPILER)
    492 # ifndef __cplusplus
    493 #  define C_cblock                ({
    494 #  define C_cblockend             })
    495 #  define C_noret                 __attribute__ ((noreturn))
    496 #  define C_noret_decl(name)
    497 #  define C_aligned               __attribute__ ((aligned))
    498 # endif
    499 # ifdef __i386__
    500 #  define C_regparm               __attribute__ ((regparm(3)))
    501 # endif
    502 #elif defined(_MSC_VER)
    503 # define C_fcall                  __fastcall
    504 #elif defined(__WATCOMC__)
    505 # define C_ccall                  __cdecl
    506 #endif
    507 
    508 #ifndef C_cblock
    509 # define C_cblock                 do{
    510 # define C_cblockend              }while(0)
    511 # define C_noret
    512 # define C_noret_decl(name)
    513 #endif
    514 
    515 #ifndef C_regparm
    516 # define C_regparm
    517 #endif
    518 
    519 #ifndef C_fcall
    520 # define C_fcall
    521 #endif
    522 
    523 #ifndef C_ccall
    524 # define C_ccall
    525 #endif
    526 
    527 #ifndef C_aligned
    528 # define C_aligned
    529 #endif
    530 
    531 #define C_c_regparm
    532 
    533561/* Types: */
    534562
     
    563591# define C_AMD64_ABI_WEIRDNESS      , ...
    564592#else
    565 # define C_AMD64_ABI_WEIRDNESS     
     593# define C_AMD64_ABI_WEIRDNESS
    566594#endif
    567595
     
    730758#define C_return(x)                return(x)
    731759
     760#ifdef C_DEFAULT_TARGET_STACK_SIZE
     761# define C_resize_stack(n)           C_do_resize_stack(C_DEFAULT_TARGET_STACK_SIZE)
     762#else
     763# define C_resize_stack(n)           C_do_resize_stack(n)
     764#endif
     765
    732766#define C_memcpy_slots(t, f, n)    C_memcpy((t), (f), (n) * sizeof(C_word))
    733767#define C_block_header(x)          (((C_SCHEME_BLOCK *)(x))->header)
     
    808842#define C_zero_length_p(x)        C_mk_bool(C_header_size(x) == 0)
    809843#define C_boundp(x)               C_mk_bool(((C_SCHEME_BLOCK *)(x))->data[ 0 ] != C_SCHEME_UNBOUND)
     844#define C_unboundvaluep(x)        C_mk_bool((x) == C_SCHEME_UNBOUND)
    810845#define C_blockp(x)               C_mk_bool(!C_immediatep(x))
    811846#define C_forwardedp(x)           C_mk_bool((C_block_header(x) & C_GC_FORWARDING_BIT) != 0)
     
    916951#define C_update_pointer(p, ptr)        (C_set_block_item(ptr, 0, C_num_to_unsigned_int(p)), C_SCHEME_UNDEFINED)
    917952#define C_copy_pointer(from, to)        (C_set_block_item(to, 0, C_u_i_car(from)), C_SCHEME_UNDEFINED)
     953#define C_pointer_to_object(ptr)        ((C_word*)C_block_item(ptr, 0))
    918954
    919955#define C_direct_return(dk, x)          (C_kontinue(dk, x), C_SCHEME_UNDEFINED)
     
    11141150
    11151151C_varextern C_TLS time_t C_startup_time_seconds;
    1116 C_varextern C_TLS C_word 
     1152C_varextern C_TLS C_word
    11171153  *C_temporary_stack,
    11181154  *C_temporary_stack_bottom,
     
    11431179  C_trace_buffer_size,
    11441180  C_main_argc;
    1145 C_varextern C_TLS C_uword 
     1181C_varextern C_TLS C_uword
    11461182  C_heap_growth,
    11471183  C_heap_shrinkage;
    1148 C_varextern C_TLS char 
     1184C_varextern C_TLS char
    11491185  **C_main_argv,
    11501186  *C_dlerror;
     
    14751511C_fctexport C_word C_fcall C_string_to_pbytevector(C_word x) C_regparm;
    14761512C_fctexport C_word C_fcall C_i_null_pointerp(C_word x) C_regparm;
    1477 C_fctexport C_word C_fcall C_i_fixnum_arithmetic_shift(C_word n, C_word c) C_regparm; 
     1513C_fctexport C_word C_fcall C_i_fixnum_arithmetic_shift(C_word n, C_word c) C_regparm;
    14781514C_fctexport C_word C_fcall C_i_locative_set(C_word loc, C_word x) C_regparm;
    14791515C_fctexport C_word C_fcall C_i_locative_to_object(C_word loc) C_regparm;
  • chicken/trunk/distribution/manifest

    r13146 r13148  
    227227tests/test-irregex.scm
    228228tests/re-tests.txt
     229tests/lolevel-tests.scm
    229230tweaks.scm
    230231utils.scm
  • chicken/trunk/lolevel.scm

    r13140 r13148  
    3030  (usual-integrations)
    3131  (disable-warning var redef)
    32   (hide ipc-hook-0 xproc-tag)
     32  (hide ipc-hook-0 xproc-tag
     33   ##sys#check-block
     34   ##sys#check-become-alist
     35   ##sys#check-generic-structure
     36   ##sys#check-generic-vector )
    3337  (foreign-declare #<<EOF
    3438#if defined(__FreeBSD__) || defined(__NetBSD__) || defined(__OpenBSD__)
     
    3943#endif
    4044
    41 #define C_pointer_to_object(ptr)   ((C_word*)C_block_item(ptr, 0))
    4245#define C_w2b(x)                   C_fix(C_wordstobytes(C_unfix(x)))
    4346#define C_pointer_eqp(x, y)        C_mk_bool(C_c_pointer_nn(x) == C_c_pointer_nn(y))
     
    5356    (no-procedure-checks-for-usual-bindings)
    5457    (bound-to-procedure
     58     ##sys#check-pointer ##sys#check-closure ##sys#check-integer ##sys#check-special
     59     ##sys#error ##sys#signal-hook
     60     ##sys#error-not-a-proper-list
    5561     ##sys#hash-table-ref ##sys#hash-table-set!
    56      ##sys#make-locative ##sys#become!
    57      ##sys#make-string
    58      make-property-condition make-composite-condition signal ##sys#set-pointer-address! ##sys#make-vector
    59      ##sys#make-pointer make-string make-byte-vector ##sys#error-not-a-proper-list ##sys#check-pointer
    60      ##sys#locative? ##sys#bytevector?
    61      extend-procedure ##sys#lambda-decoration ##sys#decorate-lambda ##sys#make-tagged-pointer ##sys#check-special
    62      ##sys#vector->closure! ##sys#error ##sys#signal-hook ##sys#address->pointer ##sys#pointer->address) ) ] )
     62     ##sys#make-pointer ##sys#make-tagged-pointer ##sys#make-locative ##sys#locative?
     63     ##sys#become!
     64     ##sys#make-string ##sys#make-vector ##sys#vector->closure!
     65     make-property-condition make-composite-condition signal
     66     ##sys#generic-structure?
     67     ##sys#set-pointer-address! ##sys#address->pointer ##sys#pointer->address
     68     ##sys#lambda-decoration ##sys#decorate-lambda
     69     extend-procedure ) ) ] )
    6370
    6471(include "unsafe-declarations.scm")
    6572
    6673(register-feature! 'lolevel)
     74
     75
     76;;; Helpers:
     77
     78(define-inline (%pointer? x)
     79  (and (##core#inline "C_blockp" x) (##core#inline "C_anypointerp" x)) )
     80
     81(define-inline (%generic-pointer? x)
     82  (or (%pointer? x)
     83      (##core#inline "C_locativep" x) ) )
     84
     85(define-inline (%special-block? x)
     86  ; generic-pointer, port, closure
     87  (and (##core#inline "C_blockp" x) (##core#inline "C_specialp" x)) )
     88
     89(define-inline (%generic-vector? x)
     90  (and (##core#inline "C_blockp" x)
     91       (not (or (##core#inline "C_specialp" x)
     92                (##core#inline "C_byteblockp" x)))) )
     93
     94(define-inline (%record-structure? x)
     95  (and (##core#inline "C_blockp" x) (##core#inline "C_structurep" x)) )
     96
     97
     98
     99;;; Argument checking:
     100
     101(define (##sys#check-block x . loc)
     102  (unless (##core#inline "C_blockp" x)
     103    (##sys#error-hook
     104     (foreign-value "C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR" int) (and (pair? loc) (car loc))
     105     x) ) )
     106
     107(define (##sys#check-become-alist x loc)
     108  (##sys#check-list x loc)
     109  (let loop ([lst x])
     110    (cond [(null? lst) ]
     111          [(pair? lst)
     112           (let ([a (car lst)])
     113             (##sys#check-pair a loc)
     114             (##sys#check-block (car a) loc)
     115             (##sys#check-block (cdr a) loc)
     116             (loop (cdr lst)) ) ]
     117          [else
     118           (##sys#signal-hook
     119            #:type-error loc
     120            "bad argument type - not an a-list of non-immediate objects" x) ] ) ) )
     121
     122(define (##sys#check-generic-structure x . loc)
     123  (unless (%record-structure? x)
     124    (##sys#signal-hook
     125     #:type-error (and (pair? loc) (car loc))
     126     "bad argument type - not a structure" x) ) )
     127
     128;; Vector, Structure, Pair, and Symbol
     129
     130(define (##sys#check-generic-vector x . loc)
     131  (unless (%generic-vector? x)
     132    (##sys#signal-hook
     133     #:type-error (and (pair? loc) (car loc))
     134     "bad argument type - not a vector-like object" x) ) )
     135
     136(define (##sys#check-pointer x . loc)
     137  (unless (%pointer? x)
     138    (##sys#error-hook
     139     (foreign-value "C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR" int)
     140     (and (pair? loc) (car loc))
     141     "bad argument type - not a pointer" x) ) )
     142
     143(cond-expand
     144  [unsafe
     145   (define-syntax ##sys#check-pointer
     146     (syntax-rules ()
     147       ((_ . _) (##core#undefined))))
     148   (define-syntax ##sys#check-block
     149     (syntax-rules ()
     150       ((_ . _) (##core#undefined))))
     151   (define-syntax ##sys#check-become-alist
     152     (syntax-rules ()
     153       ((_ . _) (##core#undefined))))
     154   (define-syntax ##sys#check-generic-structure
     155     (syntax-rules ()
     156       ((_ . _) (##core#undefined))))
     157   (define-syntax ##sys#check-generic-vector
     158     (syntax-rules ()
     159       ((_ . _) (##core#undefined)))) ]
     160  [else] )
    67161
    68162
     
    74168        [memmove3 (foreign-lambda void "C_memmove_o" scheme-pointer c-pointer int int int)]
    75169        [memmove4 (foreign-lambda void "C_memmove_o" scheme-pointer scheme-pointer int int int)]
    76         [slot1structs '(mmap u8vector u16vector u32vector s8vector s16vector s32vector f32vector f64vector)] )
     170        [typerr (lambda (x)
     171                  (##sys#error-hook
     172                   (foreign-value "C_BAD_ARGUMENT_TYPE_ERROR" int)
     173                   'move-memory! x))]
     174        [slot1structs '(mmap
     175                        u8vector u16vector u32vector s8vector s16vector s32vector
     176                        f32vector f64vector)] )
    77177    (lambda (from to #!optional n (foffset 0) (toffset 0))
    78       (define (err) (##sys#error 'move-memory! "need number of bytes to move" from to))
    79       (define (xerr x) (##sys#signal-hook #:type-error 'move-memory! "invalid argument type" x))
    80       (define (checkn n nmax off)
     178      ;
     179      (define (nosizerr)
     180        (##sys#error 'move-memory! "need number of bytes to move" from to))
     181      ;
     182      (define (sizerr . args)
     183        (apply ##sys#error 'move-memory! "number of bytes to move too large" from to args)
     184      ;
     185      (define (checkn1 n nmax off)
    81186        (if (cond-expand [unsafe #t] [else (fx<= n (fx- nmax off))])
    82187            n
    83             (##sys#error 'move-memory! "number of bytes to move too large" from to n nmax) ) )
     188            (sizerr n nmax) ) )
     189      ;
    84190      (define (checkn2 n nmax nmax2 off1 off2)
    85191        (if (cond-expand [unsafe #t] [else (and (fx<= n (fx- nmax off1)) (fx<= n (fx- nmax2 off2)))])
    86192            n
    87             (##sys#error 'move-memory! "number of bytes to move too large" from to n nmax nmax2) ) )
     193            (sizerr n nmax nmax2) ) )
     194      ;
     195      (##sys#check-block from 'move-memory!)
     196      (##sys#check-block to 'move-memory!)
    88197      (let move ([from from] [to to])
    89198        (cond [(##sys#generic-structure? from)
    90199               (if (memq (##sys#slot from 0) slot1structs)
    91200                   (move (##sys#slot from 1) to)
    92                    (xerr from) ) ]
     201                   (typerr from) ) ]
    93202              [(##sys#generic-structure? to)
    94203               (if (memq (##sys#slot to 0) slot1structs)
    95204                   (move from (##sys#slot to 1))
    96                    (xerr to) ) ]
    97               [(or (##sys#pointer? from) (##sys#locative? from))
    98                (cond [(or (##sys#pointer? to) (##sys#locative? to))
    99                       (memmove1 to from (or n (err)) toffset foffset)]
     205                   (typerr to) ) ]
     206              [(%generic-pointer? from)
     207               (cond [(%generic-pointer? to)
     208                      (memmove1 to from (or n (nosizerr)) toffset foffset)]
    100209                     [(or (##sys#bytevector? to) (string? to))
    101                       (memmove3 to from (checkn (or n (err)) (##sys#size to) toffset) toffset foffset) ]
    102                      [else (xerr to)] ) ]
     210                      (memmove3 to from (checkn1 (or n (nosizerr)) (##sys#size to) toffset) toffset foffset) ]
     211                     [else
     212                      (typerr to)] ) ]
    103213              [(or (##sys#bytevector? from) (string? from))
    104214               (let ([nfrom (##sys#size from)])
    105                  (cond [(or (##sys#pointer? to) (##sys#locative? to))
    106                         (memmove2 to from (checkn (or n nfrom) nfrom foffset) toffset foffset)]
     215                 (cond [(%generic-pointer? to)
     216                        (memmove2 to from (checkn1 (or n nfrom) nfrom foffset) toffset foffset)]
    107217                       [(or (##sys#bytevector? to) (string? to))
    108218                        (memmove4 to from (checkn2 (or n nfrom) nfrom (##sys#size to) foffset toffset)
    109219                                  toffset foffset) ]
    110                        [else (xerr to)] ) ) ]
    111               [else (xerr from)] ) ) ) ) )
     220                       [else
     221                        (typerr to)] ) ) ]
     222              [else
     223               (typerr from)] ) ) ) ) ) )
     224
     225
     226;;; Copy arbitrary object:
     227
     228(define (object-copy x)
     229  (let copy ([x x])
     230    (cond [(not (##core#inline "C_blockp" x)) x]
     231          [(symbol? x) (##sys#intern-symbol (##sys#slot x 1))]
     232          [else
     233            (let* ([n (##sys#size x)]
     234                   [words (if (##core#inline "C_byteblockp" x) (##core#inline "C_words" n) n)]
     235                   [y (##core#inline "C_copy_block" x (##sys#make-vector words))] )
     236              (unless (or (##core#inline "C_byteblockp" x) (symbol? x))
     237                (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
     238                    [(fx>= i n)]
     239                  (##sys#setslot y i (copy (##sys#slot y i))) ) )
     240              y) ] ) ) )
    112241
    113242
    114243;;; Pointer operations:
    115244
    116 (define (##sys#check-pointer ptr loc)
    117   (unless (and (##core#inline "C_blockp" ptr)
    118                (or (##core#inline "C_pointerp" ptr)
    119                    (##core#inline "C_swigpointerp" ptr)
    120                    (##core#inline "C_taggedpointerp" ptr) ) )
    121     (##sys#signal-hook #:type-error loc "bad argument type - not a pointer" ptr) ) )
    122 
    123 (define null-pointer ##sys#null-pointer)
    124 
    125 (define (pointer? x)
    126   (and (##core#inline "C_blockp" x)
    127        (or (##core#inline "C_pointerp" x)
    128            (##core#inline "C_taggedpointerp" x) ) ) )
     245(define allocate (foreign-lambda c-pointer "C_malloc" int))
     246(define free (foreign-lambda void "C_free" c-pointer))
     247
     248(define (pointer? x) (%pointer? x))
     249
     250(define (pointer-like? x) (%special-block? x))
    129251
    130252(define (address->pointer addr)
    131   (cond-expand
    132    [(not unsafe)
    133     (when (not (integer? addr))
    134       (##sys#signal-hook #:type-error 'address->pointer "bad argument type - not an integer" addr) ) ]
    135    [else] )
     253  (##sys#check-integer addr 'address->pointer)
    136254  (##sys#address->pointer addr) )
    137255
     
    140258  (##sys#pointer->address ptr) )
    141259
     260(define null-pointer ##sys#null-pointer)
     261
    142262(define (null-pointer? ptr)
    143263  (##sys#check-special ptr 'null-pointer?)
     
    146266(define (object->pointer x)
    147267  (and (##core#inline "C_blockp" x)
    148        ((foreign-lambda* nonnull-c-pointer ((scheme-object x))
    149           "return((void *)x);")
    150         x) ) )
     268       ((foreign-lambda* nonnull-c-pointer ((scheme-object x)) "return((void *)x);") x) ) )
    151269
    152270(define (pointer->object ptr)
     
    159277  (##core#inline "C_pointer_eqp" p1 p2) )
    160278
    161 (define allocate (foreign-lambda c-pointer "C_malloc" int))
    162 (define free (foreign-lambda void "C_free" c-pointer))
     279(define pointer-offset
     280  (foreign-lambda* nonnull-c-pointer ([c-pointer ptr] [integer off])
     281    "return((unsigned char *)ptr + off);") )
    163282
    164283(define align-to-word
    165284  (let ([align (foreign-lambda integer "C_align" integer)])
    166285    (lambda (x)
    167       (cond [(number? x) (align x)]
    168             [(and (##core#inline "C_blockp" x) (##core#inline "C_specialp" x))
     286      (cond [(integer? x)
     287             (align x)]
     288            [(%special-block? x)
    169289             (##sys#address->pointer (align (##sys#pointer->address x))) ]
    170             [else (##sys#signal-hook #:type-error 'align-to-word "bad argument type - not a pointer or fixnum" x)] ) ) ) )
    171 
    172 (define pointer-offset
    173   (foreign-lambda* nonnull-c-pointer ([c-pointer ptr] [integer off])
    174     "return((unsigned char *)ptr + off);") )
     290            [else
     291             (##sys#signal-hook
     292              #:type-error 'align-to-word
     293              "bad argument type - not a pointer or integer" x)] ) ) ) )
    175294
    176295(define pointer-u8-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((unsigned char *)p) = n;"))
     
    223342   pointer-f64-set!) )
    224343
     344
     345;;; Tagged-pointers:
     346
    225347(define (tag-pointer ptr tag)
    226348  (let ([tp (##sys#make-tagged-pointer tag)])
    227     (if (and (##core#inline "C_blockp" ptr) (##core#inline "C_specialp" ptr))
     349    (if (%special-block? ptr)
    228350        (##core#inline "C_copy_pointer" ptr tp)
    229         (##sys#signal-hook #:type-error 'tag-pointer "bad argument type - not a pointer" ptr) )
     351        (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR" int) 'tag-pointer ptr) )
    230352    tp) )
    231353
    232 (define (tagged-pointer? x tag)
    233   (and (##core#inline "C_blockp" x)
    234        (##core#inline "C_taggedpointerp" x)
    235        (equal? tag (##sys#slot x 1)) ) )
     354(define (tagged-pointer? x #!optional tag)
     355  (and (##core#inline "C_blockp" x)  (##core#inline "C_taggedpointerp" x)
     356       (or (not tag)
     357           (equal? tag (##sys#slot x 1)) ) ) )
    236358
    237359(define (pointer-tag x)
    238   (if (and (##core#inline "C_blockp" x) (##core#inline "C_specialp" x))
     360  (if (%special-block? x)
    239361      (and (##core#inline "C_taggedpointerp" x)
    240362           (##sys#slot x 1) )
    241       (##sys#signal-hook #:type-error 'pointer-tag "bad argument type - not a pointer" x) ) )
     363      (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR" int) 'pointer-tag x) ) )
     364
     365
     366;;; locatives:
     367
     368;; Locative layout:
     369;
     370; 0     Object-address + Byte-offset (address)
     371; 1     Byte-offset (fixnum)
     372; 2     Type (fixnum)
     373;       0       vector or pair          (C_SLOT_LOCATIVE)
     374;       1       string                  (C_CHAR_LOCATIVE)
     375;       2       u8vector                (C_U8_LOCATIVE)
     376;       3       s8vector or blob        (C_U8_LOCATIVE)
     377;       4       u16vector               (C_U16_LOCATIVE)
     378;       5       s16vector               (C_S16_LOCATIVE)
     379;       6       u32vector               (C_U32_LOCATIVE)
     380;       7       s32vector               (C_S32_LOCATIVE)
     381;       8       f32vector               (C_F32_LOCATIVE)
     382;       9       f64vector               (C_F64_LOCATIVE)
     383; 3     Object or #f, if weak (C_word)
     384
     385(define (make-locative obj . index)
     386  (##sys#make-locative obj (optional index 0) #f 'make-locative) )
     387
     388(define (make-weak-locative obj . index)
     389  (##sys#make-locative obj (optional index 0) #t 'make-weak-locative) )
     390
     391(define (locative-set! x y) (##core#inline "C_i_locative_set" x y))
     392(define locative-ref (getter-with-setter (##core#primitive "C_locative_ref") locative-set!))
     393(define (locative->object x) (##core#inline "C_i_locative_to_object" x))
     394(define (locative? x) (and (##core#inline "C_blockp" x) (##core#inline "C_locativep" x)))
    242395
    243396
    244397;;; Procedures extended with data:
    245398
     399; Unique id for extended-procedures
    246400(define xproc-tag (vector 'extended))
    247401
    248402(define (extend-procedure proc data)
    249   #+(not unsafe)
    250   (unless (##core#inline "C_closurep" proc)
    251     (##sys#signal-hook #:type-error 'extend-procedure "bad argument type - not a procedure" proc) )
     403  (##sys#check-closure proc 'extend-procedure)
    252404  (##sys#decorate-lambda
    253405   proc
    254406   (lambda (x) (and (pair? x) (eq? xproc-tag (##sys#slot x 0))))
    255    (lambda (x i)
    256      (##sys#setslot x i (cons xproc-tag data))
    257      x) ) )
     407   (lambda (x i) (##sys#setslot x i (cons xproc-tag data)) x) ) )
     408
     409(define-inline (%procedure-data proc)
     410  (##sys#lambda-decoration proc (lambda (x) (and (pair? x) (eq? xproc-tag (##sys#slot x 0))))) )
    258411
    259412(define (extended-procedure? x)
    260   (and (##core#inline "C_blockp" x)
    261        (##core#inline "C_closurep" x)
    262        (##sys#lambda-decoration x (lambda (x) (and (pair? x) (eq? xproc-tag (##sys#slot x 0)))))
     413  (and (##core#inline "C_blockp" x) (##core#inline "C_closurep" x)
     414       (%procedure-data x)
    263415       #t) )
    264416
    265417(define (procedure-data x)
    266   (and (##core#inline "C_blockp" x)
    267        (##core#inline "C_closurep" x)
    268        (and-let* ((d (##sys#lambda-decoration x (lambda (x) (and (pair? x) (eq? xproc-tag (##sys#slot x 0)))))))
     418  (and (##core#inline "C_blockp" x) (##core#inline "C_closurep" x)
     419       (and-let* ([d (%procedure-data x)])
    269420         (##sys#slot d 1) ) ) )
    270421
     
    275426        (if (eq? p2 proc)
    276427            proc
    277             (##sys#signal-hook #:type-error 'set-procedure-data! "bad argument type - not an extended procedure" proc) ) ) ) ) )
    278 
    279 
    280 ;;; Accessors for arbitrary block objects:
     428            (##sys#signal-hook
     429             #:type-error 'set-procedure-data!
     430             "bad argument type - not an extended procedure" proc) ) ) ) ) )
     431
     432
     433;;; Accessors for arbitrary vector-like block objects:
    281434
    282435(define block-set! ##sys#block-set!)
    283436(define block-ref (getter-with-setter ##sys#block-ref ##sys#block-set!))
    284437
    285 (define number-of-slots
    286   (lambda (x)
    287     (when (or (not (##core#inline "C_blockp" x))
    288               (##core#inline "C_specialp" x)
    289               (##core#inline "C_byteblockp" x) )
    290       (##sys#signal-hook #:type-error 'number-of-slots "slots not accessible" x) )
    291     (##sys#size x) ) )
     438(define (vector-like? x)
     439  (%generic-vector? x) )
     440
     441(define (number-of-slots x)
     442  (##sys#check-generic-vector x 'number-of-slots)
     443  (##sys#size x) )
    292444
    293445(define (number-of-bytes x)
    294446  (cond [(not (##core#inline "C_blockp" x))
    295          (##sys#signal-hook #:type-error 'number-of-bytes "cannot compute number of bytes of immediate object" x) ]
    296         [(##core#inline "C_byteblockp" x) (##sys#size x)]
    297         [else (##core#inline "C_w2b" (##sys#size x))] ) )
     447         (##sys#signal-hook
     448          #:type-error 'number-of-bytes
     449          "cannot compute number of bytes of immediate object" x) ]
     450        [(##core#inline "C_byteblockp" x)
     451         (##sys#size x)]
     452        [else
     453         (##core#inline "C_w2b" (##sys#size x))] ) )
    298454
    299455
    300456;;; Record objects:
     457
     458;; Record layout:
     459;
     460; 0     Tag (symbol)
     461; 1..N  Slot (object)
    301462
    302463(define (make-record-instance type . args)
     
    304465  (apply ##sys#make-structure type args) )
    305466
    306 (define (record-instance? x)
    307   (and (##core#inline "C_blockp" x)
    308        (##core#inline "C_structurep" x) ) )
     467(define (record-instance? x #!optional type)
     468  (and (%record-structure? x)
     469       (or (not type)
     470           (eq? type (##sys#slot x 0)))) )
     471
     472(define (record-instance-type x)
     473  (##sys#check-generic-structure x 'record-instance-type)
     474  (##sys#slot x 0) )
     475
     476(define (record-instance-length x)
     477  (##sys#check-generic-structure x 'record-instance-length)
     478  (fx- (##sys#size x) 1) )
     479
     480(define (record-instance-slot-set! x i y)
     481  (##sys#check-generic-structure x 'record-instance-slot-set!)
     482  (##sys#check-range i 0 (fx- (##sys#size x) 1) 'record-instance-slot-set!)
     483  (##sys#setslot x (fx+ i 1) y) )
     484
     485(define record-instance-slot
     486  (getter-with-setter
     487   (lambda (x i)
     488     (##sys#check-generic-structure x 'record-instance-slot)
     489     (##sys#check-range i 0 (fx- (##sys#size x) 1) 'record-instance-slot)
     490     (##sys#slot x (fx+ i 1)) )
     491   record-instance-slot-set!))
    309492
    310493(define (record->vector x)
    311   (if (and (not (##sys#immediate? x)) (##sys#generic-structure? x))
    312       (let* ([n (##sys#size x)]
    313              [v (##sys#make-vector n)] )
    314         (do ([i 0 (fx+ i 1)])
    315             ((fx>= i n) v)
    316           (##sys#setslot v i (##sys#slot x i)) ) )
    317       (##sys#signal-hook #:type-error 'record->vector "bad argument type - not a record structure" x) ) )
    318 
    319 
    320 ;;; Copy arbitrary object:
    321 
    322 (define (object-copy x)
    323   (let copy ([x x])
    324     (cond [(not (##core#inline "C_blockp" x)) x]
    325           [(symbol? x) (##sys#intern-symbol (##sys#slot x 1))]
     494  (##sys#check-generic-structure x 'record->vector)
     495  (let* ([n (##sys#size x)]
     496         [v (##sys#make-vector n)] )
     497    (do ([i 0 (fx+ i 1)])
     498         [(fx>= i n) v]
     499      (##sys#setslot v i (##sys#slot x i)) ) ) )
     500
     501
     502
     503;;; Evict objects into static memory:
     504
     505(define-constant evict-table-size 301)
     506
     507(define (object-evicted? x) (##core#inline "C_permanentp" x))
     508
     509(define (object-evict x . allocator)
     510  (let ([allocator
     511         (if (pair? allocator) (car allocator) (foreign-lambda c-pointer "C_malloc" int) ) ]
     512        [tab (##sys#make-vector evict-table-size '())] )
     513    (##sys#check-closure allocator 'object-evict)
     514    (let evict ([x x])
     515      (cond [(not (##core#inline "C_blockp" x)) x ]
     516            [(##sys#hash-table-ref tab x) ]
     517            [else
     518             (let* ([n (##sys#size x)]
     519                    [bytes (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))]
     520                    [y (##core#inline "C_evict_block" x (allocator (fx+ bytes (##core#inline "C_bytes" 1))))] )
     521               (when (symbol? x) (##sys#setislot y 0 (void)))
     522               (##sys#hash-table-set! tab x y)
     523               (unless (##core#inline "C_byteblockp" x)
     524                 (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)])
     525                     [(fx>= i n)]
     526                   ;; Note the use of `##sys#setislot' to avoid an entry in the mutations-table:
     527                   (##sys#setislot y i (evict (##sys#slot x i))) ) )
     528               y ) ] ) ) ) )
     529
     530(define (object-evict-to-location x ptr . limit)
     531  (cond-expand [(not unsafe) (##sys#check-special ptr 'object-evict-to-location)] [else])
     532  (let* ([limit (and (pair? limit)
     533                     (let ([limit (car limit)])
     534                       (##sys#check-exact limit 'object-evict-to-location)
     535                       limit)) ]
     536         [ptr2 (##sys#address->pointer (##sys#pointer->address ptr))]
     537         [tab (##sys#make-vector evict-table-size '())]
     538         [x2
     539          (let evict ([x x])
     540            (cond [(not (##core#inline "C_blockp" x)) x ]
     541                  [(##sys#hash-table-ref tab x) ]
     542                  [else
     543                   (let* ([n (##sys#size x)]
     544                          [bytes
     545                           (fx+ (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))
     546                                (##core#inline "C_bytes" 1) ) ] )
     547                     (when limit
     548                       (set! limit (fx- limit bytes))
     549                       (when (fx< limit 0)
     550                         (signal
     551                          (make-composite-condition
     552                           (make-property-condition
     553                            'exn 'location 'object-evict-to-location
     554                            'message "cannot evict object - limit exceeded"
     555                            'arguments (list x limit))
     556                           (make-property-condition 'evict 'limit limit) ) ) ) )
     557                   (let ([y (##core#inline "C_evict_block" x ptr2)])
     558                     (when (symbol? x) (##sys#setislot y 0 (void)))
     559                     (##sys#set-pointer-address! ptr2 (+ (##sys#pointer->address ptr2) bytes))
     560                     (##sys#hash-table-set! tab x y)
     561                     (unless (##core#inline "C_byteblockp" x)
     562                       (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)] )
     563                           [(fx>= i n)]
     564                         (##sys#setislot y i (evict (##sys#slot x i))) ) ) ; see above
     565                     y) ) ] ) ) ] )
     566    (values x2 ptr2) ) )
     567
     568(define (object-release x . releaser)
     569  (let ([free (if (pair? releaser)
     570                  (car releaser)
     571                  (foreign-lambda void "C_free" c-pointer) ) ]
     572        [released '() ] )
     573    (let release ([x x])
     574      (cond [(not (##core#inline "C_blockp" x)) x ]
     575            [(not (##core#inline "C_permanentp" x)) x ]
     576            [(memq x released) x ]
     577            [else
     578             (let ([n (##sys#size x)])
     579               (set! released (cons x released))
     580               (unless (##core#inline "C_byteblockp" x)
     581                 (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
     582                     [(fx>= i n)]
     583                   (release (##sys#slot x i))) )
     584               (free (##sys#address->pointer (##core#inline_allocate ("C_block_address" 4) x))) ) ] ) ) ) )
     585
     586(define (object-size x)
     587  (let ([tab (##sys#make-vector evict-table-size '())])
     588    (let evict ([x x])
     589      (cond [(not (##core#inline "C_blockp" x)) 0 ]
     590            [(##sys#hash-table-ref tab x) 0 ]
     591            [else
     592             (let* ([n (##sys#size x)]
     593                    [bytes
     594                     (fx+ (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))
     595                          (##core#inline "C_bytes" 1) ) ] )
     596               (##sys#hash-table-set! tab x #t)
     597               (unless (##core#inline "C_byteblockp" x)
     598                 (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)])
     599                     [(fx>= i n)]
     600                   (set! bytes (fx+ (evict (##sys#slot x i)) bytes)) ) )
     601               bytes) ] ) ) ) )
     602
     603(define (object-unevict x #!optional full)
     604  (let ([tab (##sys#make-vector evict-table-size '())])
     605    (let copy ([x x])
     606    (cond [(not (##core#inline "C_blockp" x)) x ]
     607          [(not (##core#inline "C_permanentp" x)) x ]
     608          [(##sys#hash-table-ref tab x) ]
     609          [(##core#inline "C_byteblockp" x)
     610           (if full
     611               (let ([y (##core#inline "C_copy_block" x (##sys#make-string (##sys#size x)))])
     612                 (##sys#hash-table-set! tab x y)
     613                 y)
     614               x) ]
     615          [(symbol? x)
     616           (let ([y (##sys#intern-symbol (##sys#slot x 1))])
     617             (##sys#hash-table-set! tab x y)
     618             y) ]
    326619          [else
    327             (let* ([n (##sys#size x)]
    328                    [words (if (##core#inline "C_byteblockp" x) (##core#inline "C_words" n) n)]
    329                    [y (##core#inline "C_copy_block" x (##sys#make-vector words))] )
    330               (unless (or (##core#inline "C_byteblockp" x) (symbol? x))
    331                 (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
    332                     ((fx>= i n))
    333                   (##sys#setslot y i (copy (##sys#slot y i))) ) )
    334               y) ] ) ) )
    335 
    336 
    337 ;;; Evict objects into static memory:
    338 
    339 (define-constant evict-table-size 301)
    340 
    341 (define (object-evicted? x) (##core#inline "C_permanentp" x))
    342 
    343 (define object-evict
    344     (lambda (x . allocator)
    345       (let ([allocator
    346              (if (pair? allocator)
    347                  (car allocator)
    348                  (foreign-lambda c-pointer "C_malloc" int) ) ]
    349             [tab (##sys#make-vector evict-table-size '())] )
    350         (let evict ([x x])
    351           (cond [(not (##core#inline "C_blockp" x)) x]
    352                 [(##sys#hash-table-ref tab x)]
    353                 [else
    354                  (let* ([n (##sys#size x)]
    355                         [bytes (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))]
    356                         [y (##core#inline "C_evict_block" x (allocator (fx+ bytes (##core#inline "C_bytes" 1))))] )
    357                    (when (symbol? x) (##sys#setislot y 0 (##core#undefined)))
    358                    (##sys#hash-table-set! tab x y)
    359                    (unless (##core#inline "C_byteblockp" x)
    360                      (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)])
    361                          ((fx>= i n))
    362                        ;; Note the use of `##sys#setislot' to avoid an entry in the mutations-table:
    363                        (##sys#setislot y i (evict (##sys#slot x i))) ) )
    364                    y) ] ) ) ) ) )
    365 
    366 (define object-release
    367   (lambda (x . releaser)
    368     (let ((free (if (pair? releaser)
    369                     (car releaser)
    370                     (foreign-lambda void "C_free" c-pointer) ) )
    371           (released '()))
    372       (let release ([x x])
    373         (cond [(not (##core#inline "C_blockp" x)) x]
    374               [(not (##core#inline "C_permanentp" x)) x]
    375               ((memq x released) x)
    376               [else
    377                (let ([n (##sys#size x)])
    378                  (set! released (cons x released))
    379                  (unless (##core#inline "C_byteblockp" x)
    380                    (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
    381                        ((fx>= i n))
    382                      (release (##sys#slot x i))) )
    383                  (free (##sys#address->pointer (##core#inline_allocate ("C_block_address" 4) x))) ) ] ) ) ) ) )
    384 
    385 (define object-evict-to-location
    386     (lambda (x ptr . limit)
    387       (cond-expand
    388        [(not unsafe)
    389         (when (not (and (##core#inline "C_blockp" ptr) (##core#inline "C_specialp" ptr)))
    390           (##sys#signal-hook #:type-error 'object-evict-to-location "bad argument type - not a pointer" ptr) ) ]
    391        [else] )
    392       (let* ([limit
    393               (if (pair? limit)
    394                   (let ([limit (car limit)])
    395                     (##sys#check-exact limit 'object-evict-to-location)
    396                     limit)
    397                   #f) ]
    398              [ptr2 (##sys#address->pointer (##sys#pointer->address ptr))]
    399              [tab (##sys#make-vector evict-table-size '())]
    400              [x2
    401               (let evict ([x x])
    402                 (cond [(not (##core#inline "C_blockp" x)) x]
    403                       [(##sys#hash-table-ref tab x)]
    404                       [else
    405                        (let* ([n (##sys#size x)]
    406                               [bytes
    407                                (fx+ (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))
    408                                     (##core#inline "C_bytes" 1) ) ] )
    409                          (when limit
    410                            (set! limit (fx- limit bytes))
    411                            (when (fx< limit 0)
    412                              (signal
    413                               (make-composite-condition
    414                                (make-property-condition
    415                                 'exn 'location 'object-evict-to-location
    416                                 'message "cannot evict object - limit exceeded"
    417                                 'arguments (list x limit))
    418                                (make-property-condition 'evict 'limit limit) ) ) ) )
    419                          (let ([y (##core#inline "C_evict_block" x ptr2)])
    420                            (when (symbol? x) (##sys#setislot y 0 (##core#undefined)))
    421                            (##sys#set-pointer-address! ptr2 (+ (##sys#pointer->address ptr2) bytes))
    422                            (##sys#hash-table-set! tab x y)
    423                            (unless (##core#inline "C_byteblockp" x)
    424                              (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x))
    425                                          1
    426                                          0)
    427                                      (fx+ i 1) ] )
    428                                  ((fx>= i n))
    429                                (##sys#setislot y i (evict (##sys#slot x i))) ) ) ; see above
    430                            y) ) ] ) ) ] )
    431         (values x2 ptr2) ) ) )
    432 
    433 (define object-size
    434     (lambda (x)
    435       (let ([tab (##sys#make-vector evict-table-size '())])
    436         (let evict ([x x])
    437           (cond [(not (##core#inline "C_blockp" x)) 0]
    438                 [(##sys#hash-table-ref tab x) 0]
    439                 [else
    440                  (let* ([n (##sys#size x)]
    441                         [bytes
    442                          (fx+ (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))
    443                               (##core#inline "C_bytes" 1) ) ] )
    444                    (##sys#hash-table-set! tab x #t)
    445                    (unless (##core#inline "C_byteblockp" x)
    446                      (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x))
    447                                  1
    448                                  0)
    449                              (fx+ i 1) ] )
    450                          ((fx>= i n))
    451                        (set! bytes (fx+ (evict (##sys#slot x i)) bytes)) ) )
    452                    bytes) ] ) ) ) ) )
    453 
    454 (define object-unevict
    455     (lambda (x #!optional (full #f))
    456       (define (err x)
    457         (##sys#signal-hook #:type-error 'object-unevict "cannot copy object" x) )
    458       (let ([tab (##sys#make-vector evict-table-size '())])
    459         (let copy ([x x])
    460           (cond [(not (##core#inline "C_blockp" x)) x]
    461                 [(not (##core#inline "C_permanentp" x)) x]
    462                 [(##sys#hash-table-ref tab x)]
    463                 [(##core#inline "C_byteblockp" x)
    464                  (if full
    465                      (let ([y (##core#inline "C_copy_block" x (##sys#make-string (##sys#size x)))])
    466                        (##sys#hash-table-set! tab x y)
    467                        y)
    468                      x) ]
    469                 [(symbol? x)
    470                  (let ([y (##sys#intern-symbol (##sys#slot x 1))])
    471                    (##sys#hash-table-set! tab x y)
    472                    y) ]
    473                 [else
    474                  (let* ([words (##sys#size x)]
    475                         [y (##core#inline "C_copy_block" x (##sys#make-vector words))] )
    476                    (##sys#hash-table-set! tab x y)
    477                    (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
    478                        ((fx>= i words))
    479                      (##sys#setslot y i (copy (##sys#slot y i))) )
    480                    y) ] ) ) ) ) )
     620           (let* ([words (##sys#size x)]
     621                  [y (##core#inline "C_copy_block" x (##sys#make-vector words))] )
     622             (##sys#hash-table-set! tab x y)
     623             (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
     624                 ((fx>= i words))
     625               (##sys#setslot y i (copy (##sys#slot y i))) )
     626             y) ] ) ) ) )
    481627
    482628
    483629;;; `become':
    484630
    485 (define object-become!
    486   (cond-expand
    487    [unsafe ##sys#become!]
    488    [else
    489     (lambda (lst)
    490       (##sys#check-list lst 'object-become!)
    491       (let loop ([lst lst])
    492         (cond [(null? lst)]
    493               [(pair? lst)
    494                (let ([a (##sys#slot lst 0)])
    495                  (##sys#check-pair a 'object-become!)
    496                  (unless (##core#inline "C_blockp" (##sys#slot a 0))
    497                    (##sys#signal-hook #:type-error 'object-become! "bad argument type - old item is immediate" a) )
    498                  (unless (##core#inline "C_blockp" (##sys#slot a 1))
    499                    (##sys#signal-hook #:type-error 'object-become! "bad argument type - new item is immediate" a) )
    500                  (loop (##sys#slot lst 1)) ) ]
    501               [else (##sys#signal-hook #:type-error 'object-become! "bad argument type - not an a-list")] ) )
    502       (##sys#become! lst) ) ] ) )
     631(define (object-become! alst)
     632  (cond-expand [(not unsafe) (##sys#check-become-alist alst 'object-become!)] [else])
     633  (##sys#become! alst) )
    503634
    504635(define (mutate-procedure old proc)
    505   (unless (##core#check (procedure? old))
    506     (##sys#signal-hook #:type-error 'mutate-procedure "bad argument type - not a procedure" old))
    507   (let* ((n (##sys#size old))
    508          (words (##core#inline "C_words" n))
    509          (y (##core#inline "C_copy_block" old (##sys#make-vector words))) )
    510     (##sys#become! (list (cons old (proc y))))
    511     y) )
    512 
    513 
    514 ;;; locatives:
    515 
    516 (define (make-locative obj . index)
    517   (##sys#make-locative obj (optional index 0) #f 'make-locative) )
    518 
    519 (define (make-weak-locative obj . index)
    520   (##sys#make-locative obj (optional index 0) #t 'make-weak-locative) )
    521 
    522 (define (locative-set! x y) (##core#inline "C_i_locative_set" x y))
    523 (define locative-ref (getter-with-setter (##core#primitive "C_locative_ref") locative-set!))
    524 (define (locative->object x) (##core#inline "C_i_locative_to_object" x))
    525 (define (locative? x) (and (##core#inline "C_blockp" x) (##core#inline "C_locativep" x)))
     636  (##sys#check-closure old 'mutate-procedure)
     637  (##sys#check-closure proc 'mutate-procedure)
     638  (let* ([n (##sys#size old)]
     639         [words (##core#inline "C_words" n)]
     640         [new (##core#inline "C_copy_block" old (##sys#make-vector words))] )
     641    (##sys#become! (list (cons old (proc new))))
     642    new ) )
    526643
    527644
     
    531648
    532649(define (set-invalid-procedure-call-handler! proc)
    533   (unless (procedure? proc)
    534     (##sys#signal-hook #:type-error 'set-invalid-procedure-call-handler! "bad argument type - not a procedure" proc) )
     650  (##sys#check-closure proc 'set-invalid-procedure-call-handler!)
    535651  (set! ipc-hook-0 proc)
    536652  (set! ##sys#invalid-procedure-call-hook
     
    541657  (set! ##sys#unbound-variable-value-hook
    542658    (and (pair? val)
    543          (vector (car val)) ) ) )
     659         (vector (car val)))) )
    544660
    545661
     
    561677  (##sys#check-symbol sym 'global-make-unbound!)
    562678  (##sys#setslot sym 0 (##sys#slot '##sys#arbitrary-unbound-symbol 0))
    563   sym)
     679  sym )
  • chicken/trunk/manual/Unit lolevel

    r10804 r13148  
    55== Unit lolevel
    66
    7 
    87This unit provides a number of handy low-level operations. '''Use
    98at your own risk.'''
    109
    11 
    1210This unit uses the {{srfi-4}} and {{extras}} units.
    1311
     12
     13
    1414=== Foreign pointers
    1515
     16The abstract class of ''pointer'' is divided into 2 categories:
     17
     18; ''pointer object'' : is a foreign pointer object, a tagged foreign pointer object (see {{Tagged pointers}}), or a SWIG-pointer.
     19
     20; ''pointer-like object'' " is a closure, port, locative (see {{Locatives}}, or a pointer object.
     21
     22SWIG-pointers are currently an issue due to "bitrot" in the SWIG Chicken
     23translator. While they are considered a pointer object unexpected results are
     24possible.
     25
     26Note that Locatives, while technically pointers, are not considered a ''pointer
     27object'', but a ''pointer-like object''. The distinction is artificial.
    1628
    1729
     
    2840 [procedure] (allocate BYTES)
    2941
    30 Returns a pointer to a freshly allocated region of static memory.
     42Returns a foreign pointer object to a freshly allocated region of static
     43memory.
     44
    3145This procedure could be defined as follows:
    3246
     
    4054 [procedure] (free POINTER)
    4155
    42 Frees the memory pointed to by {{POINTER}}.  This procedure could
    43 be defined as follows:
    44 
    45 <enscript highlight=scheme>
    46 (define free (foreign-lambda c-pointer "free" integer))
     56Frees the memory pointed to by {{POINTER}}.
     57
     58This procedure could be defined as follows:
     59
     60<enscript highlight=scheme>
     61(define free (foreign-lambda void "free" c-pointer))
    4762</enscript>
    4863
     
    5772==== null-pointer?
    5873
    59  [procedure] (null-pointer? PTR)
    60 
    61 Returns {{#t}} if {{PTR}} contains a {{NULL}} pointer,
     74 [procedure] (null-pointer? POINTER*)
     75
     76Returns {{#t}} if the pointer-like object {{POINTER*}} contains a {{NULL}} pointer,
    6277or {{#f}} otherwise.
    6378
     
    6782 [procedure] (object->pointer X)
    6883
    69 Returns a pointer pointing to the Scheme object X, which should be a
    70 non-immediate object.  Note that data in the garbage collected heap
    71 moves during garbage collection.
    72 
     84Returns a foreign pointer object pointing to the Scheme object X, which should
     85be a non-immediate object. ("foreign" here is a bit of a misnomer.)
     86
     87Note that data in the garbage collected heap moves during garbage collection.
     88
     89
     90==== pointer->object
     91
     92 [procedure] (pointer->object POINTER)
     93
     94Returns the Scheme object pointed to by the pointer object {{POINTER}}.
     95
     96Whether the {{POINTER}} actually points to a Scheme object is not guaranteed. Use
     97at your own risk.
    7398
    7499==== pointer?
     
    76101 [procedure] (pointer? X)
    77102
    78 Returns {{#t}} if {{X}} is a foreign pointer object, and
    79 {{#f}} otherwise.
     103Returns {{#t}} if {{X}} is a pointer object, or {{#f}} otherwise.
     104
     105
     106==== pointer-like?
     107
     108 [procedure] (pointer-like? X)
     109
     110Returns {{#t}} if {{X}} is a pointer-like object, or {{#f}} otherwise.
     111
    80112
    81113==== pointer=?
    82114
    83  [procedure] (pointer=? PTR1 PTR2)
    84 
    85 Returns {{#t}} if the pointer-like objects {{PTR1}} and {{PTR2}} point
    86 to the same address.
    87 
     115 [procedure] (pointer=? POINTER*1 POINTER*2)
     116
     117Returns {{#t}} if the pointer-like objects {{POINTER*1}} and {{POINTER*2}} point
     118to the same address, or {{#f}} otherwise.
    88119
    89120
    90121==== pointer->address
    91122
    92  [procedure] (pointer->address PTR)
    93 
    94 Returns the address, to which the pointer {{PTR}} points.
    95 
    96 
    97 ==== pointer->object
    98 
    99  [procedure] (pointer->object PTR)
    100 
    101 Returns the Scheme object pointed to by the pointer {{PTR}}.
     123 [procedure] (pointer->address POINTER*)
     124
     125Returns the address, to which the pointer-like object {{POINTER*}} points.
    102126
    103127
    104128==== pointer-offset
    105129
    106  [procedure] (pointer-offset PTR N)
    107 
    108 Returns a new pointer representing the pointer {{PTR}} increased
    109 by {{N}}.
    110 
     130 [procedure] (pointer-offset POINTER* N)
     131
     132Returns a new foreign pointer object representing the pointer-like object
     133{{POINTER*}} address value increased by the byte-offset {{N}}.
     134
     135Use of anything other than a pointer object as an argument is questionable.
     136
     137
     138==== align-to-word
     139
     140 [procedure] (align-to-word POINTER*-OR-INT)
     141
     142Accepts either a pointer-like object or an integer as the argument and returns
     143a new foreign pointer or integer aligned to the native word size of the host
     144platform.
     145
     146Use of anything other than an integer or pointer object as an argument is
     147questionable.
     148
     149
     150
     151=== SRFI-4 Foreign pointers
     152
     153These procedures actually accept a pointer-like object as the {{POINTER}} argument.
     154However, as usual, use of anything other than a pointer object is questionable.
    111155
    112156==== pointer-u8-ref
    113157
    114  [procedure] (pointer-u8-ref PTR)
    115 
    116 Returns the unsigned byte at the address designated by {{PTR}}.
     158 [procedure] (pointer-u8-ref POINTER)
     159
     160Returns the unsigned byte at the address designated by {{POINTER}}.
    117161
    118162
    119163==== pointer-s8-ref
    120164
    121  [procedure] (pointer-s8-ref PTR)
    122 
    123 Returns the signed byte at the address designated by {{PTR}}.
     165 [procedure] (pointer-s8-ref POINTER)
     166
     167Returns the signed byte at the address designated by {{POINTER}}.
    124168
    125169
    126170==== pointer-u16-ref
    127171
    128  [procedure] (pointer-u16-ref PTR)
    129 
    130 Returns the unsigned 16-bit integer at the address designated by {{PTR}}.
     172 [procedure] (pointer-u16-ref POINTER)
     173
     174Returns the unsigned 16-bit integer at the address designated by {{POINTER}}.
    131175
    132176
    133177==== pointer-s16-ref
    134178
    135  [procedure] (pointer-s16-ref PTR)
    136 
    137 Returns the signed 16-bit integer at the address designated by {{PTR}}.
     179 [procedure] (pointer-s16-ref POINTER)
     180
     181Returns the signed 16-bit integer at the address designated by {{POINTER}}.
    138182
    139183
    140184==== pointer-u32-ref
    141185
    142  [procedure] (pointer-u32-ref PTR)
    143 
    144 Returns the unsigned 32-bit integer at the address designated by {{PTR}}.
     186 [procedure] (pointer-u32-ref POINTER)
     187
     188Returns the unsigned 32-bit integer at the address designated by {{POINTER}}.
    145189
    146190
    147191==== pointer-s32-ref
    148192
    149  [procedure] (pointer-s32-ref PTR)
    150 
    151 Returns the signed 32-bit integer at the address designated by {{PTR}}.
     193 [procedure] (pointer-s32-ref POINTER)
     194
     195Returns the signed 32-bit integer at the address designated by {{POINTER}}.
    152196
    153197
    154198==== pointer-f32-ref
    155199
    156  [procedure] (pointer-f32-ref PTR)
    157 
    158 Returns the 32-bit float at the address designated by {{PTR}}.
     200 [procedure] (pointer-f32-ref POINTER)
     201
     202Returns the 32-bit float at the address designated by {{POINTER}}.
    159203
    160204
    161205==== pointer-f64-ref
    162206
    163  [procedure] (pointer-f64-ref PTR)
    164 
    165 Returns the 64-bit double at the address designated by {{PTR}}.
     207 [procedure] (pointer-f64-ref POINTER)
     208
     209Returns the 64-bit double at the address designated by {{POINTER}}.
    166210
    167211
    168212==== pointer-u8-set!
    169213
    170  [procedure] (pointer-u8-set! PTR N)
    171  [procedure] (set! (pointer-u8-ref PTR) N)
    172 
    173 Stores the unsigned byte {{N}} at the address designated by {{PTR}}.
     214 [procedure] (pointer-u8-set! POINTER N)
     215 [procedure] (set! (pointer-u8-ref POINTER) N)
     216
     217Stores the unsigned byte {{N}} at the address designated by {{POINTER}}.
    174218
    175219
    176220==== pointer-s8-set!
    177221
    178  [procedure] (pointer-s8-set! PTR N)
    179  [procedure] (set! (pointer-s8-ref PTR) N)
    180 
    181 Stores the signed byte {{N}} at the address designated by {{PTR}}.
     222 [procedure] (pointer-s8-set! POINTER N)
     223 [procedure] (set! (pointer-s8-ref POINTER) N)
     224
     225Stores the signed byte {{N}} at the address designated by {{POINTER}}.
    182226
    183227
    184228==== pointer-u16-set!
    185229
    186  [procedure] (pointer-u16-set! PTR N)
    187  [procedure] (set! (pointer-u16-ref PTR) N)
    188 
    189 Stores the unsigned 16-bit integer {{N}} at the address designated by {{PTR}}.
     230 [procedure] (pointer-u16-set! POINTER N)
     231 [procedure] (set! (pointer-u16-ref POINTER) N)
     232
     233Stores the unsigned 16-bit integer {{N}} at the address designated by {{POINTER}}.
    190234
    191235
    192236==== pointer-s16-set!
    193237
    194  [procedure] (pointer-s16-set! PTR N)
    195  [procedure] (set! (pointer-s16-ref PTR) N)
    196 
    197 Stores the signed 16-bit integer {{N}} at the address designated by {{PTR}}.
     238 [procedure] (pointer-s16-set! POINTER N)
     239 [procedure] (set! (pointer-s16-ref POINTER) N)
     240
     241Stores the signed 16-bit integer {{N}} at the address designated by {{POINTER}}.
    198242
    199243
    200244==== pointer-u32-set!
    201245
    202  [procedure] (pointer-u32-set! PTR N)
    203  [procedure] (set! (pointer-u32-ref PTR) N)
    204 
    205 Stores the unsigned 32-bit integer {{N}} at the address designated by {{PTR}}.
     246 [procedure] (pointer-u32-set! POINTER N)
     247 [procedure] (set! (pointer-u32-ref POINTER) N)
     248
     249Stores the unsigned 32-bit integer {{N}} at the address designated by {{POINTER}}.
    206250
    207251
    208252==== pointer-s32-set!
    209253
    210  [procedure] (pointer-s32-set! PTR N)
    211  [procedure] (set! (pointer-s32-ref PTR) N)
    212 
    213 Stores the 32-bit integer {{N}} at the address designated by {{PTR}}.
     254 [procedure] (pointer-s32-set! POINTER N)
     255 [procedure] (set! (pointer-s32-ref POINTER) N)
     256
     257Stores the 32-bit integer {{N}} at the address designated by {{POINTER}}.
    214258
    215259
    216260==== pointer-f32-set!
    217261
    218  [procedure] (pointer-f32-set! PTR N)
    219  [procedure] (set! (pointer-f32-ref PTR) N)
    220 
    221 Stores the 32-bit floating-point number {{N}} at the address designated by {{PTR}}.
     262 [procedure] (pointer-f32-set! POINTER N)
     263 [procedure] (set! (pointer-f32-ref POINTER) N)
     264
     265Stores the 32-bit floating-point number {{N}} at the address designated by {{POINTER}}.
    222266
    223267
    224268==== pointer-f64-set!
    225269
    226  [procedure] (pointer-f64-set! PTR N)
    227  [procedure] (set! (pointer-f64-ref PTR) N)
    228 
    229 Stores the 64-bit floating-point number {{N}} at the address designated by {{PTR}}.
    230 
    231 
    232 ==== align-to-word
    233 
    234  [procedure] (align-to-word PTR-OR-INT)
    235 
    236 Accepts either a machine pointer or an integer as argument and returns
    237 a new pointer or integer aligned to the native word size of the host
    238 platform.
    239 
    240 
     270 [procedure] (pointer-f64-set! POINTER N)
     271 [procedure] (set! (pointer-f64-ref POINTER) N)
     272
     273Stores the 64-bit floating-point number {{N}} at the address designated by {{POINTER}}.
    241274
    242275
     
    247280
    248281
    249 
    250282==== tag-pointer
    251283
    252  [procedure] (tag-pointer PTR TAG)
    253 
    254 Creates a new tagged pointer object from the foreign pointer {{PTR}} with the
    255 tag {{TAG}}, which may an arbitrary Scheme object.
    256 
     284 [procedure] (tag-pointer POINTER* TAG)
     285
     286Creates a new tagged foreign pointer object from the pointer-like object
     287{{POINTER*}} with the tag {{TAG}}, which may an arbitrary Scheme object.
     288
     289Use of anything other than a pointer object is questionable.
    257290
    258291==== tagged-pointer?
    259292
    260  [procedure] (tagged-pointer? X TAG)
    261 
    262 Returns {{#t}}, if {{X}} is a tagged pointer object with the tag {{TAG}}
    263 (using an {{eq?}} comparison), or {{#f}} otherwise.
     293 [procedure] (tagged-pointer? X [TAG])
     294
     295Returns {{#t}} if {{X}} is a tagged foreign pointer object, or {{#f}} otherwise.
     296
     297Further, returns {{#t}} when {{X}} has the optional tag {{TAG}} (using an
     298{{equal?}} comparison), or {{#f}} otherwise.
    264299
    265300
    266301==== pointer-tag
    267302
    268  [procedure] (pointer-tag PTR)
    269 
    270 If {{PTR}} is a tagged pointer object, its tag is returned. If {{PTR}} is a normal,
    271 untagged foreign pointer object {{#f}} is returned. Otherwise an error is signalled.
    272 
    273 
     303 [procedure] (pointer-tag POINTER*)
     304
     305If {{POINTER}} is a tagged foreign pointer object, its tag is returned. If {{POINTER*}}
     306is any other kind of pointer-like object {{#f}} is returned. Otherwise an
     307error is signalled.
     308
     309
     310
     311=== Locatives
     312
     313
     314A ''locative'' is an object that points to an element of a containing object,
     315much like a ''pointer'' in low-level, imperative programming languages like ''C''. The element can
     316be accessed and changed indirectly, by performing access or change operations
     317on the locative. The container object can be computed by calling the
     318{{location->object}} procedure.
     319
     320Locatives may be passed to foreign procedures that expect pointer arguments.
     321The effect of creating locatives for evicted data (see {{object-evict}}) is undefined.
     322
     323
     324==== make-locative
     325
     326 [procedure] (make-locative OBJ [INDEX])
     327
     328Creates a locative that refers to the element of the non-immediate object
     329{{OBJ}} at position {{INDEX}}. {{OBJ}} may be a vector, pair, string, blob,
     330SRFI-4 number-vector, or record structure. {{INDEX}} should be a fixnum.
     331{{INDEX}} defaults to 0.
     332
     333
     334==== make-weak-locative
     335
     336 [procedure] (make-weak-locative OBJ [INDEX])
     337
     338Creates a ''weak'' locative. Even though the locative refers to an element of a container object,
     339the container object will still be reclaimed by garbage collection if no other references
     340to it exist.
     341
     342
     343==== locative?
     344
     345 [procedure] (locative? X)
     346
     347Returns {{#t}} if {{X}} is a locative, or {{#f}} otherwise.
     348
     349
     350==== locative-ref
     351
     352 [procedure] (locative-ref LOC)
     353
     354Returns the element to which the locative {{LOC}} refers. If the containing
     355object has been reclaimed by garbage collection, an error is signalled.
     356
     357 (locative-ref (make-locative "abc" 1)) ==> #\b
     358
     359==== locative-set!
     360
     361 [procedure] (locative-set! LOC X)
     362 [procedure] (set! (locative-ref LOC) X)
     363
     364Changes the element to which the locative {{LOC}} refers to {{X}}.
     365If the containing
     366object has been reclaimed by garbage collection, an error is signalled.
     367
     368
     369==== locative->object
     370
     371 [procedure] (locative->object LOC)
     372
     373Returns the object that contains the element referred to by {{LOC}} or
     374{{#f}} if the container has been reclaimed by garbage collection.
     375
     376 (locative->object (make-locative "abc" 1)) ==> "abc"
    274377
    275378
     
    278381
    279382
    280 
    281 
    282383==== extend-procedure
    283384
    284385 [procedure] (extend-procedure PROCEDURE X)
    285386
    286 Returns a copy of the procedure {{PROCEDURE}} which contains an
    287 additional data slot initialized to {{X}}. If {{PROCEDURE}}
    288 is already an extended procedure, then its data slot is changed to
    289 contain {{X}} and the same procedure is returned.
     387Returns a copy of the procedure {{PROCEDURE}} which contains an additional data
     388slot initialized to {{X}}. If {{PROCEDURE}} is already an extended procedure,
     389then its data slot is changed to contain {{X}} and the same procedure is
     390returned. Signals an error when {{PROCEDURE}} is not a procedure.
    290391
    291392
     
    302403 [procedure] (procedure-data PROCEDURE)
    303404
    304 Returns the data object contained in the extended procedure {{PROCEDURE}},
    305 or {{#f}} if it is not an extended procedure.
     405Returns the data object contained in the extended procedure {{PROCEDURE}}, or
     406{{#f}} if it is not an extended procedure.
    306407
    307408
     
    310411 [procedure] (set-procedure-data! PROCEDURE X)
    311412
    312 Changes the data object contained in the extended procedure
    313 {{PROCEDURE}} to {{X}}.
     413Changes the data object contained in the extended procedure {{PROCEDURE}} to
     414{{X}}. Signals an error when {{PROCEDURE}} is not an extended procedure.
    314415
    315416<enscript highlight=scheme>
     
    326427
    327428
     429=== Low-level data access
     430
     431These procedures operate with what are known as {{vector-like objects}}. A
     432{{vector-like object}} is a vector, record structure, pair, symbol or keyword.
     433
     434Note that strings and blobs are not considered vector-like.
     435
     436
     437==== vector-like?
     438
     439 [procedure] (vector-like? X)
     440
     441Returns {{#t}} when {{X}} is a vector-like object, returns {{#f}}
     442otherwise.
     443
     444
     445==== block-ref
     446
     447 [procedure] (block-ref VECTOR* INDEX)
     448
     449Returns the contents of the {{INDEX}}th slot of the vector-like object
     450{{VECTOR*}}.
     451
     452
     453==== block-set!
     454
     455 [procedure] (block-set! VECTOR* INDEX X)
     456 [procedure] (set! (block-ref VECTOR* INDEX) X)
     457
     458Sets the contents of the {{INDEX}}th slot of the vector-like object {{VECTOR*}}
     459to the value of {{X}}.
     460
     461==== number-of-slots
     462
     463 [procedure] (number-of-slots VECTOR*)
     464
     465Returns the number of slots that the vector-like object {{VECTOR*}} contains.
     466
     467
     468==== number-of-bytes
     469
     470 [procedure] (number-of-bytes BLOCK)
     471
     472Returns the number of bytes that the object {{BLOCK}} contains. {{BLOCK}} may
     473be any non-immediate value.
     474
     475
     476==== object-copy
     477
     478 [procedure] (object-copy X)
     479
     480Copies {{X}} recursively and returns the fresh copy. Objects allocated in
     481static memory are copied back into garbage collected storage.
     482
     483
     484==== move-memory!
     485
     486 [procedure] (move-memory! FROM TO [BYTES [FROM-OFFSET [TO-OFFSET]])
     487
     488Copies {{BYTES}} bytes of memory from {{FROM}} to {{TO}}. {{FROM}} and {{TO}}
     489may be strings, blobs, SRFI-4 number-vectors (see: @ref{Unit srfi-4}), memory
     490mapped files, foreign pointers (as obtained from a call to {{foreign-lambda}},
     491for example), tagged-pointers or locatives. if {{BYTES}} is not given and the
     492size of the source or destination operand is known then the maximal number of
     493bytes will be copied. Moving memory to the storage returned by locatives will
     494cause havoc, if the locative refers to containers of non-immediate data, like
     495vectors or pairs.
     496
     497The additional fourth and fifth argument specify starting offsets (in bytes)
     498for the source and destination arguments.
     499
     500Signals an error if any of the above constraints is violated.
     501
     502
     503
    328504=== Data in unmanaged memory
    329505
    330506
    331 
    332 
    333507==== object-evict
    334508
    335509 [procedure] (object-evict X [ALLOCATOR])
    336510
    337 Copies the object {{X}} recursively into the memory pointed
    338 to by the foreign pointer object returned by {{ALLOCATOR}},
    339 which should be a procedure of a single argument (the number of bytes
    340 to allocate). The freshly copied object is returned.  This facility
    341 allows moving arbitrary objects into static memory, but care should be
    342 taken when mutating evicted data: setting slots in evicted vector-like
    343 objects to non-evicted data is not allowed. It '''is''' possible to
     511Copies the object {{X}} recursively into the memory pointed to by the foreign
     512pointer object returned by {{ALLOCATOR}}, which should be a procedure of a
     513single argument (the number of bytes to allocate). The freshly copied object is
     514returned.
     515
     516This facility allows moving arbitrary objects into static memory, but care
     517should be taken when mutating evicted data: setting slots in evicted
     518vector-like objects to non-evicted data is not allowed. It '''is''' possible to
    344519set characters/bytes in evicted strings or byte-vectors, though.  It is
    345 advisable '''not''' to evict ports, because they might be mutated by
    346 certain file-operations.  {{object-evict}} is able to handle circular and
    347 shared structures, but evicted symbols are no longer unique: a fresh
    348 copy of the symbol is created, so
     520advisable '''not''' to evict ports, because they might be mutated by certain
     521file-operations.  {{object-evict}} is able to handle circular and shared
     522structures, but evicted symbols are no longer unique: a fresh copy of the
     523symbol is created, so
    349524
    350525<enscript highlight=scheme>
     
    362537==== object-evict-to-location
    363538
    364  [procedure] (object-evict-to-location X PTR [LIMIT])
     539 [procedure] (object-evict-to-location X POINTER* [LIMIT])
    365540
    366541As {{object-evict}} but moves the object at the address pointed to by
    367 the machine pointer {{PTR}}. If the number of copied bytes exceeds
     542the pointer-like object {{POINTER*}}. If the number of copied bytes exceeds
    368543the optional {{LIMIT}} then an error is signalled (specifically a composite
    369544condition of types {{exn}} and {{evict}}. The latter provides
     
    372547free address after the evicted object.
    373548
     549Use of anything other than a pointer object as the {{POINTER*}} argument is
     550questionable.
    374551
    375552==== object-evicted?
     
    377554 [procedure] (object-evicted? X)
    378555
    379 Returns {{#t}} if {{X}} is a non-immediate evicted data object,
    380 or {{#f}} otherwise.
    381 
    382 
    383 ==== object-size
    384 
    385  [procedure] (object-size X)
    386 
    387 Returns the number of bytes that would be needed to evict the data
    388 object {{X}}.
     556Returns {{#t}} if {{X}} is a non-immediate evicted data object, or {{#f}}
     557otherwise.
    389558
    390559
     
    403572 [procedure] (object-unevict X [FULL])
    404573
    405 Copies the object {{X}} and nested objects back into the normal
    406 Scheme heap.  Symbols are re-interned into the symbol table. Strings
    407 and byte-vectors are '''not''' copied, unless {{FULL}} is given and
    408 not {{#f}}.
    409 
    410 
    411 
    412 
    413 
    414 === Locatives
    415 
    416 
    417 A ''locative'' is an object that points to an element of a containing object,
    418 much like a ''pointer'' in low-level, imperative programming languages like ''C''. The element can
    419 be accessed and changed indirectly, by performing access or change operations
    420 on the locative. The container object can be computed by calling the
    421 {{location->object}} procedure.
    422 
    423 Locatives may be passed to foreign procedures that expect pointer arguments.
    424 The effect of creating locatives for evicted data (see {{object-evict}}) is undefined.
    425 
    426 
    427 
    428 ==== make-locative
    429 
    430  [procedure] (make-locative EXP [INDEX])
    431 
    432 Creates a locative that refers to the element of the non-immediate object {{EXP}}
    433 at position {{INDEX}}. {{EXP}} may be a vector, pair, string, blob,
    434 SRFI-4 number-vector, or record. {{INDEX}} should be a fixnum. {{INDEX}} defaults to 0.
    435 
    436 
    437 ==== make-weak-locative
    438 
    439  [procedure] (make-weak-locative EXP [INDEX])
    440 
    441 Creates a ''weak'' locative. Even though the locative refers to an element of a container object,
    442 the container object will still be reclaimed by garbage collection if no other references
    443 to it exist.
    444 
    445 
    446 ==== locative?
    447 
    448  [procedure] (locative? X)
    449 
    450 Returns {{#t}} if {{X}} is a locative, or {{#f}} otherwise.
    451 
    452 
    453 ==== locative-ref
    454 
    455  [procedure] (locative-ref LOC)
    456 
    457 Returns the element to which the locative {{LOC}} refers. If the containing
    458 object has been reclaimed by garbage collection, an error is signalled.
    459 
    460 
    461 ==== locative-set!
    462 
    463  [procedure] (locative-set! LOC X)
    464  [procedure] (set! (locative-ref LOC) X)
    465 
    466 Changes the element to which the locative {{LOC}} refers to {{X}}.
    467 If the containing
    468 object has been reclaimed by garbage collection, an error is signalled.
    469 
    470 
    471 ==== locative->object
    472 
    473  [procedure] (locative->object LOC)
    474 
    475 Returns the object that contains the element referred to by {{LOC}} or
    476 {{#f}} if the container has been reclaimed by garbage collection.
    477 
    478 
     574Copies the object {{X}} and nested objects back into the normal Scheme heap.
     575Symbols are re-interned into the symbol table. Strings and byte-vectors are
     576'''not''' copied, unless {{FULL}} is given and not {{#f}}.
     577
     578
     579==== object-size
     580
     581 [procedure] (object-size X)
     582
     583Returns the number of bytes that would be needed to evict the data object
     584{{X}}.
    479585
    480586
    481587
    482588=== Accessing toplevel variables
    483 
    484 
    485589
    486590
     
    514618
    515619
    516 
    517 
    518 === Low-level data access
    519 
    520 
    521 ==== block-ref
    522 
    523  [procedure] (block-ref BLOCK INDEX)
    524 
    525 Returns the contents of the {{INDEX}}th slot of the object
    526 {{BLOCK}}.  {{BLOCK}} may be a vector, record structure,
    527 pair or symbol.
    528 
    529 
    530 ==== block-set!
    531 
    532  [procedure] (block-set! BLOCK INDEX X)
    533  [procedure] (set! (block-ref BLOCK INDEX) X)
    534 
    535 Sets the contents of the {{INDEX}}th slot of the object
    536 {{BLOCK}} to the value of {{X}}.  {{BLOCK}} may be a
    537 vector, record structure, pair or symbol.
    538 
    539 
    540 ==== object-copy
    541 
    542  [procedure] (object-copy X)
    543 
    544 Copies {{X}} recursively and returns the fresh copy. Objects
    545 allocated in static memory are copied back into garbage collected storage.
     620=== Record instance
    546621
    547622
     
    575650
    576651
    577 ==== move-memory!
    578 
    579  [procedure] (move-memory! FROM TO [BYTES [FROM-OFFSET [TO-OFFSET]])
    580 
    581 Copies {{BYTES}} bytes of memory from {{FROM}} to {{TO}}.
    582 {{FROM}} and {{TO}} may be strings, primitive byte-vectors,
    583 SRFI-4 byte-vectors (see: @ref{Unit srfi-4}), memory mapped files, foreign
    584 pointers (as obtained from a call to {{foreign-lambda}}, for
    585 example) or locatives. if {{BYTES}} is not given and the size of the source
    586 or destination operand is known then the maximal number of bytes will
    587 be copied. Moving memory to the storage returned by locatives will cause havoc,
    588 if the locative refers to containers of non-immediate data, like vectors
    589 or pairs.
    590 
    591 The additional fourth and fifth argument specify starting offsets
    592 (in bytes) for the source and destination arguments.
    593 
    594 
    595 ==== number-of-bytes
    596 
    597  [procedure] (number-of-bytes BLOCK)
    598 
    599 Returns the number of bytes that the object {{BLOCK}} contains.
    600 {{BLOCK}} may be any non-immediate value.
    601 
    602 
    603 ==== number-of-slots
    604 
    605  [procedure] (number-of-slots BLOCK)
    606 
    607 Returns the number of slots that the object {{BLOCK}} contains.
    608 {{BLOCK}} may be a vector, record structure, pair or symbol.
    609 
    610 
    611652==== record-instance?
    612653
    613  [procedure] (record-instance? X)
    614 
    615 Returns {{#t}} if {{X}} is an instance of a record type.
    616 See also: {{make-record-instance}}.
     654 [procedure] (record-instance? X [SYMBOL])
     655
     656Returns {{#t}} if {{X}} is a record structure, or {{#f}} otherwise.
     657
     658Further, returns {{#t}} if {{X}} is of type {{SYMBOL}}, or {{#f}} otherwise.
     659
     660
     661==== record-instance-type
     662
     663 [procedure] (record-instance-type RECORD)
     664
     665Returns type symbol of the record structure {{RECORD}}. Signals an error if
     666{{RECORD}} is not a record structure.
     667
     668
     669==== record-instance-length
     670
     671 [procedure] (record-instance-length RECORD)
     672
     673Returns number of slots for the record structure {{RECORD}}. The
     674record-instance type is not counted. Signals an error if
     675{{RECORD}} is not a record structure.
     676
     677
     678==== record-instance-slot
     679
     680 [procedure] (record-instance-slot RECORD INDEX)
     681
     682Returns the contents of the {{INDEX}}th slot of the record structure
     683{{RECORD}}. The slot index range is the open interval (([0
     684record-instance-length)}}. Signals an error if {{RECORD}} is not a record
     685structure.
     686
     687
     688==== record-instance-slot-set!
     689
     690 [procedure] (record-instance-slot-set! RECORD INDEX X)
     691 [procedure] (set! (record-instance-slot RECORD INDEX) X)
     692
     693Sets the {{INDEX}}th slot of the record structure {{RECORD}} to {{X}}. The slot
     694index range is the open interval (([0 record-instance-length)}}. Signals an
     695error if {{RECORD}} is not a record structure.
    617696
    618697
    619698==== record->vector
    620699
    621  [procedure] (record->vector BLOCK)
    622 
    623 Returns a new vector with the type and the elements of the record {{BLOCK}}.
     700 [procedure] (record->vector RECORD)
     701
     702Returns a new vector with the type and the elements of the record structure
     703{{RECORD}}. Signals an error if {{RECORD}} is not a record structure.
    624704
    625705
     
    632712 [procedure] (set-invalid-procedure-call-handler! PROC)
    633713
    634 Sets an internal hook that is invoked when a call to an object other than a procedure
    635 is executed at runtime. The procedure {{PROC}} will in that case be called
    636 with two arguments: the object being called and a list of the passed arguments.
     714Sets an internal hook that is invoked when a call to an object other than a
     715procedure is executed at runtime. The procedure {{PROC}} will in that case be
     716called with two arguments: the object being called and a list of the passed
     717arguments.
    637718
    638719<enscript highlight=scheme>
     
    655736 [procedure] (unbound-variable-value [X])
    656737
    657 Defines the value that is returned for unbound variables. Normally an error
    658 is signalled, use this procedure to override the check and return {{X}}
    659 instead. To set the default behavior (of signalling an error), call
     738Defines the value that is returned for unbound variables. Normally an error is
     739signalled, use this procedure to override the check and return {{X}} instead.
     740To set the default behavior (of signalling an error), call
    660741{{unbound-variable-value}} with no arguments.
    661742
     
    664745
    665746
    666 
    667 
    668747=== Magic
    669748
     
    673752 [procedure] (object-become! ALIST)
    674753
    675 Changes the identity of the value of the car of each pair in
    676 {{ALIST}} to the value of the cdr. Both values may not be immediate
    677 (i.e. exact integers, characters, booleans or the empty list).
     754Changes the identity of the value of the car of each pair in {{ALIST}} to the
     755value of the cdr. Both values may not be immediate (i.e. exact integers,
     756characters, booleans or the empty list).
    678757
    679758<enscript highlight=scheme>
     
    697776
    698777Replaces the procedure {{OLD}} with the result of calling the one-argument
    699 procedure {{PROC}}. {{PROC}} will receive a copy of {{OLD}} that will
    700 be identical in behaviour to the result of {{PROC}}:
     778procedure {{PROC}}. {{PROC}} will receive a copy of {{OLD}} that will be
     779identical in behaviour to the result of {{PROC}}:
    701780
    702781<enscript highlight=scheme>
    703782;;; Replace arbitrary procedure with tracing one:
    704783
    705 (mutate-procedure my-proc 
    706   (lambda (new) 
     784(mutate-procedure my-proc
     785  (lambda (new)
    707786    (lambda args
    708787      (printf "~s called with arguments: ~s~%" new args)
     
    714793
    715794Next: [[Interface to external functions and variables]]
    716 
  • chicken/trunk/runtime.c

    r13138 r13148  
    82928292  a = C_alloc(2 + C_bytestowords(7));
    82938293  s = C_string2(&a, "windows");
    8294 #elif defined(__unix__) || defined(C_MACOSX) || defined(C_XXXBSD)
     8294#elif defined(__unix__) || defined(C_XXXBSD)
    82958295  a = C_alloc(2 + C_bytestowords(4));
    82968296  s = C_string2(&a, "unix");
  • chicken/trunk/tests/path-tests.scm

    r11038 r13148  
    1 (require-extension utils)
    2 (define-syntax test
    3   (syntax-rules ()
    4     ((_ x) `(printf "~s\t=> ~s~%" ',x ,x))))
    5 (test (pathname-directory "/"))
    6 (test (pathname-directory "/abc"))
    7 (test (pathname-directory "abc/"))
    8 (test (pathname-directory "abc/def"))
    9 (test (pathname-directory "abc/def.ghi"))
    10 (test (pathname-directory "abc/.def.ghi"))
    11 (test (pathname-directory "abc/.ghi"))
    12 (test (pathname-directory "/abc/"))
    13 (test (pathname-directory "/abc/def"))
    14 (test (pathname-directory "/abc/def.ghi"))
    15 (test (pathname-directory "/abc/.def.ghi"))
    16 (test (pathname-directory "/abc/.ghi"))
    17 (test (pathname-directory "q/abc/"))
    18 (test (pathname-directory "q/abc/def"))
    19 (test (pathname-directory "q/abc/def.ghi"))
    20 (test (pathname-directory "q/abc/.def.ghi"))
    21 (test (pathname-directory "q/abc/.ghi"))
     1(use files)
     2
     3(assert (equal? "/" (pathname-directory "/")))
     4(assert (equal? "/" (pathname-directory "/abc")))
     5(assert (equal? "abc" (pathname-directory "abc/")))
     6(assert (equal? "abc" (pathname-directory "abc/def")))
     7(assert (equal? "abc" (pathname-directory "abc/def.ghi")))
     8(assert (equal? "abc" (pathname-directory "abc/.def.ghi")))
     9(assert (equal? "abc" (pathname-directory "abc/.ghi")))
     10(assert (equal? "/abc" (pathname-directory "/abc/")))
     11(assert (equal? "/abc" (pathname-directory "/abc/def")))
     12(assert (equal? "/abc" (pathname-directory "/abc/def.ghi")))
     13(assert (equal? "/abc" (pathname-directory "/abc/.def.ghi")))
     14(assert (equal? "/abc" (pathname-directory "/abc/.ghi")))
     15(assert (equal? "q/abc" (pathname-directory "q/abc/")))
     16(assert (equal? "q/abc" (pathname-directory "q/abc/def")))
     17(assert (equal? "q/abc" (pathname-directory "q/abc/def.ghi")))
     18(assert (equal? "q/abc" (pathname-directory "q/abc/.def.ghi")))
     19(assert (equal? "q/abc" (pathname-directory "q/abc/.ghi")))
Note: See TracChangeset for help on using the changeset viewer.