source: project/release/3/slang/trunk/slang.scm @ 18200

Last change on this file since 18200 was 3163, checked in by Tony Sidaway, 14 years ago

Add more functions, and make others more Scheme-like.

File size: 14.1 KB
Line 
1; Copyright (c) 2007 Tony Sidaway <tonysidaway@gmail.com>
2;
3; Permission is hereby granted, free of charge, to any person obtaining
4; a copy of this software and associated documentation files (the
5; "Software"), to deal in the Software without restriction, including without
6; limitation the rights to use, copy, modify, merge, publish, distribute,
7; sublicense, and/or sell copies of the Software, and to permit persons to
8; whom the Software is furnished to do so, subject to the following conditions:
9;
10; The above copyright notice and this permission notice shall be included
11; in all copies or substantial portions of the Software.
12;
13; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
14; OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
15; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
16; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
17; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
18; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
19; DEALINGS IN THE SOFTWARE.
20;
21#>
22#include <slang.h>
23<#
24(define-macro (def rt name . ats)
25  `(define ,name (foreign-lambda ,rt ,(->string name) ,@ats)) )
26
27(define-macro (defc rt name . ats)
28  `(define ,(string->symbol (string-append (->string name) "_c")) (foreign-lambda ,rt ,(->string name) ,@ats)) )
29
30(define-macro (deferr name)
31  `(define ,name (foreign-value ,(->string name) int)) )
32
33(define-macro (defvalue name type)
34  `(define ,name (foreign-value ,(->string name) ,type)))
35
36(defvalue SLSMG_HLINE_CHAR int)
37(defvalue SLSMG_VLINE_CHAR int)
38(defvalue SLSMG_ULCORN_CHAR int)
39(defvalue SLSMG_URCORN_CHAR int)
40(defvalue SLSMG_LLCORN_CHAR int)
41(defvalue SLSMG_LRCORN_CHAR int)
42(defvalue SLSMG_RTEE_CHAR int)
43(defvalue SLSMG_LTEE_CHAR int)
44(defvalue SLSMG_UTEE_CHAR int)
45(defvalue SLSMG_DTEE_CHAR int)
46(defvalue SLSMG_PLUS_CHAR int)
47(defvalue SLSMG_CKBRD_CHAR int)
48(defvalue SLSMG_DIAMOND_CHAR int)
49(defvalue SLSMG_DEGREE_CHAR int)
50(defvalue SLSMG_PLMINUS_CHAR int)
51(defvalue SLSMG_BULLET_CHAR int)
52(defvalue SLSMG_LARROW_CHAR int)
53(defvalue SLSMG_RARROW_CHAR int)
54(defvalue SLSMG_DARROW_CHAR int)
55(defvalue SLSMG_UARROW_CHAR int)
56(defvalue SLSMG_BOARD_CHAR int)
57(defvalue SLSMG_BLOCK_CHAR int)
58
59
60(deferr SL_Any_Error)
61(deferr SL_Index_Error)               
62(deferr SL_OS_Error)
63(deferr SL_Parse_Error)               
64(deferr SL_Malloc_Error)
65(deferr SL_Syntax_Error)               
66(deferr SL_IO_Error)
67(deferr SL_DuplicateDefinition_Error) 
68(deferr SL_Write_Error)
69(deferr SL_UndefinedName_Error)       
70(deferr SL_Read_Error)
71(deferr SL_Usage_Error)               
72(deferr SL_Open_Error)
73(deferr SL_Application_Error)         
74(deferr SL_RunTime_Error)
75(deferr SL_Internal_Error)             
76(deferr SL_InvalidParm_Error)
77(deferr SL_NotImplemented_Error)       
78(deferr SL_TypeMismatch_Error)
79(deferr SL_LimitExceeded_Error)       
80(deferr SL_UserBreak_Error)
81(deferr SL_Forbidden_Error)
82(deferr SL_Stack_Error)
83(deferr SL_Math_Error)                 
84(deferr SL_StackOverflow_Error)
85(deferr SL_DivideByZero_Error)
86(deferr SL_StackUnderflow_Error)
87(deferr SL_ArithOverflow_Error)
88(deferr SL_ReadOnly_Error)
89(deferr SL_ArithUnderflow_Error)
90(deferr SL_VariableUninitialized_Error)
91(deferr SL_Domain_Error)
92(deferr SL_NumArgs_Error)
93(deferr SL_Data_Error)
94(deferr SL_Unknown_Error)
95(deferr SL_Unicode_Error)
96(deferr SL_Import_Error)
97(deferr SL_InvalidUTF8_Error)
98
99; Error handling
100
101(def int SLang_set_error int)
102
103(define-foreign-variable SLang_Error_Hook c-pointer "SLang_Error_Hook")
104(define (slang-error-hook) SLang_Error_Hook)
105(define (slang-error-hook-set! f) (set! SLang_Error_Hook f))
106
107(define-foreign-variable SLang_Exit_Error_Hook c-pointer "SLang_Exit_Error_Hook")
108(define (slang-exit-error-hook) SLang_Exit_Error_Hook)
109(define (slang-exit-error-hook-set! f) (set! SLang_Exit_Error_Hook f))
110
111(define-foreign-variable SLtt_Screen_Rows int "SLtt_Screen_Rows")
112(define (sltt-screen-rows) SLtt_Screen_Rows)
113(define (sltt-screen-rows-set! n) (set! SLtt_Screen_Rows n))
114
115(define-foreign-variable SLtt_Screen_Cols int "SLtt_Screen_Cols")
116(define (sltt-screen-cols) SLtt_Screen_Cols)
117(define (sltt-screen-cols-set! n) (set! SLtt_Screen_Cols n))
118
119(define-foreign-variable SLsmg_Tab_Width int "SLsmg_Tab_Width")
120(define (slang-tt-baud-rate) SLsmg_Tab_Width)
121(define (slang-tt-baud-rate-set! n) (set! SLsmg_Tab_Width n))
122
123(define-foreign-variable SLsmg_Display_Eight_Bit int "SLsmg_Display_Eight_Bit")
124(define (slsmg-display-eight-bit) SLsmg_Display_Eight_Bit)
125(define (slsmg-display-eight-bit-set! n) (set! SLsmg_Display_Eight_Bit n))
126
127(define-foreign-variable SLtt_Use_Ansi_Colors int "SLtt_Use_Ansi_Colors")
128(define (sltt-use-ansi-colors) SLtt_Use_Ansi_Colors)
129(define (sltt-use-ansi-colors-set! n) (set! SLtt_Use_Ansi_Colors n))
130
131(define-foreign-variable SLtt_Term_Cannot_Scroll int "SLtt_Term_Cannot_Scroll")
132(define (sltt-term-cannot-scroll) SLtt_Term_Cannot_Scroll)
133(define (sltt-term-cannot-scroll-set! n) (set! SLtt_Term_Cannot_Scroll n))
134
135(define-foreign-variable SLKeyBoard_Quit int "SLKeyBoard_Quit")
136(define (sl-keyboard-quit) SLKeyBoard_Quit)
137(define (sl-keyboard-quit-set! f) (set! SLKeyBoard_Quit f))
138
139(define-foreign-variable SLang_Ignore_User_Abort int "SLang_Ignore_User_Abort")
140(define (slang-ignore-user-abort) SLang_Ignore_User_Abort)
141(define (slang-ignore-user-abort-set! n) (set! SLang_Ignore_User_Abort n))
142
143
144(define-foreign-variable SLang_TT_Baud_Rate int "SLang_TT_Baud_Rate")
145(define (slang-tt-baud-rate) SLang_TT_Baud_Rate)
146(define (slang-tt-baud-rate-set! n) (set! SLang_TT_Baud_Rate n))
147
148(def int SLang_get_error)
149
150; UTF-8 is off by default
151
152(def int SLutf8_enable int)
153(def int SLtt_utf8_enable int)
154(def int SLtt_is_utf8_mode)
155(def int SLinterp_utf8_enable int)
156(def int SLinterp_is_utf8_mode)
157(def int SLutf8_is_utf8_mode)
158
159; Interpreter
160
161(def int SLang_init_slang)
162
163(def int SLang_init_all)
164(def int SLang_init_slmath)
165(def int SLang_init_array)
166(def int SLang_init_stdio)
167(def int SLang_init_ospath)
168(def int SLang_init_posix_dir)
169(def int SLang_init_posix_process)
170(def int SLang_init_posix_io)
171(def int SLang_init_signal)
172
173
174(def int SLang_load_file c-string)
175
176(def int SLns_load_file c-string c-string)
177
178(def int SLang_load_string c-string)
179
180; Keyboard interface
181
182(def int SLang_init_tty int int int)
183
184(def void SLang_reset_tty)
185
186(def void SLang_restart int)
187
188(def void SLtt_get_terminfo)
189
190(def int SLkp_init)
191
192;;;(def void SLang_doerror c-string)
193
194(def void SLang_set_abort_signal c-pointer)
195
196(def unsigned-int SLang_getkey)
197
198(def void SLang_ungetkey int)
199
200(def void SLang_ungetkey_string c-string unsigned-int)
201
202(def void SLang_buffer_keystring c-string unsigned-int)
203
204(def int SLang_input_pending int)
205
206(def int SLkp_getkey)
207
208(defvalue SL_KEY_ERR int)
209
210(defvalue SL_KEY_UP int)
211(defvalue SL_KEY_DOWN int)
212(defvalue SL_KEY_LEFT int)
213(defvalue SL_KEY_RIGHT int)
214(defvalue SL_KEY_PPAGE int)
215(defvalue SL_KEY_NPAGE int)
216(defvalue SL_KEY_HOME int)
217(defvalue SL_KEY_END int)
218(defvalue SL_KEY_A1 int)
219(defvalue SL_KEY_A3 int)
220(defvalue SL_KEY_B2 int)
221(defvalue SL_KEY_C1 int)
222(defvalue SL_KEY_C3 int)
223(defvalue SL_KEY_REDO int)
224(defvalue SL_KEY_UNDO int)
225(defvalue SL_KEY_BACKSPACE int)
226(defvalue SL_KEY_ENTER int)
227(defvalue SL_KEY_IC int)
228(defvalue SL_KEY_DELETE int)
229(defvalue SL_KEY_F0 int)
230
231(define (SL_KEY_F x) (+ SL_KEY_F0 x))
232
233(def void SLang_flush_input)
234
235(def int SLsmg_init_smg)
236(def void SLsmg_reset_smg)
237(def int SLsmg_reinit_smg)
238(def void SLsmg_refresh)
239(def void SLsmg_gotorc int int)
240
241; Some slang functions use C pointers instead of value arguments and we approach this by producing a
242; wrapping of the original C function under NAME_c, and then we produce a wrapper than conceals all
243; the pointy stuff and presents a nicer, cleaner interface that uses value arguments.
244(defc void SLsmg_set_screen_start c-pointer c-pointer)
245(define (SLsmg_set_screen_start row col)
246#>
247static int screen_start_row;
248static int *p_screen_start_row = &screen_start_row;
249static int screen_start_col;
250static int *p_screen_start_col = &screen_start_col;
251<#
252  (define-foreign-variable screen_start_row int "screen_start_row")
253  (define-foreign-variable screen_start_col int "screen_start_col")
254  (define-foreign-variable p_screen_start_row c-pointer "p_screen_start_row")
255  (define-foreign-variable p_screen_start_col c-pointer "p_screen_start_col")
256  (set! screen_start_row row)
257  (set! screen_start_col col)
258  (SLsmg_set_screen_start_c p_screen_start_row p_screen_start_col))
259
260(def void SLsmg_write_char int)
261(def void SLsmg_write_nchars c-string int)
262(def void SLsmg_write_string c-string)
263(def void SLsmg_write_nstring c-string int)
264(def void SLsmg_erase_eol)
265(def void SLsmg_erase_eos)
266(def void SLsmg_cls)
267
268(def void SLtt_set_color int c-string c-string c-string)
269(def void SLtt_set_color_object int unsigned-long)
270(def void SLtt_set_mono int c-string unsigned-long)
271
272(def void SLsmg_set_color int)
273(def void SLsmg_normal_video)
274(def void SLsmg_reverse_video)
275(def void SLsmg_set_char_set int)
276(def void SLsmg_draw_hline int)
277(def void SLsmg_draw_vline int)
278(def void SLsmg_draw_box int int int int)
279(def int SLsmg_get_column)
280(def int SLsmg_get_row)
281(def void SLsmg_forward int)
282
283(def void SLsmg_fill_region int int unsigned-int unsigned-int unsigned-int32);
284(def int SLsmg_suspend_smg)
285(def int SLsmg_resume_smg)
286
287(def void SLsmg_touch_lines int int)
288(def void SLsmg_touch_screen)
289(def int SLsmg_char_at c-pointer)
290(def void SLsmg_draw_object int int int)
291(def void SLsmg_draw_box int int unsigned-int unsigned-int)
292
293(def int SLsig_block_signals)
294(def int SLsig_unblock_signals)
295
296(def c-pointer SLrline_open int unsigned-int)
297
298(defvalue SL_RLINE_NO_ECHO unsigned-int)
299(defvalue SL_RLINE_USE_ANSI unsigned-int)
300(defvalue SL_RLINE_BLINK_MATCH unsigned-int)
301(defvalue SL_RLINE_UTF8_MODE unsigned-int)
302
303(def void SLrline_close c-pointer)
304
305(defc c-string SLrline_read_line c-pointer c-string c-pointer)
306(define (SLrline_read_line rline prompt)
307#>
308static int n_readline;
309static int *p_n_readline=&n_readline;
310<#
311  (define-foreign-variable p_n_readline c-pointer "p_n_readline")
312  (SLrline_read_line_c rline prompt p_n_readline))
313   
314
315(def int SLrline_bol c-pointer)
316(def int SLrline_eol c-pointer)
317(def int SLrline_del c-pointer unsigned-int)
318(def int SLrline_ins c-pointer c-string unsigned-int)
319
320(def int SLrline_set_echo c-pointer int)
321(def int SLrline_set_tab c-pointer unsigned-int)
322(def int SLrline_set_point c-pointer unsigned-int)
323(def int SLrline_set_line c-pointer c-string)
324(def int SLrline_set_hscroll c-pointer unsigned-int)
325(def int SLrline_set_display_width c-pointer unsigned-int)
326
327(defc int SLrline_get_echo c-pointer c-pointer)
328(define (SLrline_get_echo rline)
329#>
330static unsigned int echo;
331static unsigned int *p_echo = &echo;
332<#
333  (define-foreign-variable echo unsigned-int "echo")
334  (define-foreign-variable p_echo c-pointer "p_echo")
335
336  (SLrline_get_echo_c rline p_echo)
337  echo)
338
339(defc int SLrline_get_tab c-pointer c-pointer)
340(define (SLrline_get_tab rline)
341#>
342static unsigned int tab;
343static unsigned int *p_tab = &tab;
344<#
345  (define-foreign-variable tab unsigned-int "tab")
346  (define-foreign-variable p_tab c-pointer "p_tab")
347  (SLrline_get_tab_c rline p_tab)
348  tab)
349
350(def int SLrline_get_point c-pointer c-pointer)
351(define (SLrline_get_point rline)
352#>
353static unsigned int point;
354static unsigned int *p_point = &point;
355<#
356  (define-foreign-variable point unsigned-int "point")
357  (define-foreign-variable p_point c-pointer "p_point")
358  (SLrline_get_point_c rline p_point)
359  point)
360
361(def c-string SLrline_get_line c-pointer)
362
363(defc int SLrline_get_hscroll c-pointer c-pointer)
364(define (SLrline_get_hscroll rline)
365#>
366static unsigned int hscroll;
367static unsigned int *p_hscroll = &hscroll;
368<#
369  (define-foreign-variable hscroll unsigned-int "hscroll")
370  (define-foreign-variable p_hscroll c-pointer "p_hscroll")
371  (SLrline_get_hscroll_c rline p_hscroll)
372  hscroll)
373
374(defc int SLrline_get_display_width c-pointer c-pointer)
375(define (SLrline_get_display_width rline)
376#>
377static unsigned int display_width;
378static unsigned int *p_display_width = &display_width;
379<#
380  (define-foreign-variable display_width unsigned-int "display_width")
381  (define-foreign-variable p_display_width c-pointer "p_display_width")
382  (SLrline_get_display_width_c rline p_display_width)
383  display_width)
384
385(def int SLrline_set_update_hook c-pointer c-pointer c-pointer)
386(def c-pointer SLrline_get_keymap c-pointer)
387(def void SLrline_redraw c-pointer)
388(def int SLrline_save_line c-pointer)
389(def int SLrline_add_to_history c-pointer c-string)
390(def void SLtt_get_screen_size)
391(def int SLtt_set_cursor_visibility int)
392(def void SLtty_set_suspend_state int)
393
394(define-foreign-record (sl-scroll-window SLscroll_Window_Type)
395  (constructor: make-sl-scroll-window)
396  (destructor: delete-sl-scroll-window)
397  (unsigned-int flags)
398  (c-pointer top_window_line)
399  (c-pointer bot_window_line)
400  (c-pointer current_line)
401  (c-pointer lines)
402  (unsigned-int nrows)
403  (unsigned-int hidden_mask)
404  (unsigned-int line_num)
405  (unsigned-int num_lines)
406  (unsigned-int window_row)
407  (unsigned-int border)
408  (int cannot_scroll))
409
410(define-foreign-record (sl-scroll SLscroll_Type)
411  (constructor: make-sl-scroll)
412  (destructor: delete-sl-scroll)
413  (c-pointer next)
414  (c-pointer prev)
415  (unsigned-int flags))
416
417(def int SLkm_define_key c-string c-pointer c-pointer)
418(def int SLang_define_key c-string c-string c-pointer)
419(def int SLkm_define_keysym c-string unsigned-int c-pointer)
420(def int SLkm_define_slkey c-string c-pointer c-pointer)
421(def void SLang_undefine_key c-string c-pointer)
422(def c-pointer SLang_create_keymap c-string c-pointer)
423(def c-string SLang_process_keystring c-string)
424
425(define-foreign-record (sl-keymap-type SLkeymap_Type)
426  (constructor: make-sl-keymap-type)
427  (destructor: delete-sl-keymap-type)
428  (c-string name)
429  (c-pointer keymap)
430  (c-pointer functions)
431  (c-pointer next))
432
433(def int SLkp_define_keysym c-string unsigned-int)
434
435(def int SLscroll_find_top c-pointer)
436(def int SLscroll_find_line_num c-pointer)
437(def unsigned-int SLscroll_next_n c-pointer unsigned-int)
438(def unsigned-int SLscroll_prev_n c-pointer unsigned-int)
439(def int SLscroll_pageup c-pointer)
440(def int SLscroll_pagedown c-pointer)
441(def void SLtt_beep)
442(def int SLtt_set_mouse_mode int int)
443(def void SLsmg_write_wrapped_string c-string int int unsigned-int unsigned-int int)
444(def void SLsmg_set_color_in_region int int int unsigned-int unsigned-int)
445
Note: See TracBrowser for help on using the repository browser.