integrate the encryption into the client or the server.}
To use @acronym{IMAIL}, you must create an Edwin init file, called
-@file{~/.edwin} on unix machines or @file{edwin.ini} on Windows or OS/2
+@file{~/.edwin} on unix machines or @file{edwin.ini} on Windows
machines. This file contains arbitrary Scheme expressions that are
evaluated in the Edwin environment when Edwin is started. In addition
to any other customizations you put in this file, you must include the
In practice, this means that most unix filenames are written verbatim,
with exceptions for special characters, and with the leading slash
-omitted. However, @acronym{DOS}-style filenames, as used by Windows and
-OS/2, must be specially rewritten to conform to this style.
+omitted. However, @acronym{DOS}-style filenames, as used by Windows,
+must be specially rewritten to conform to this style.
The rewriting rules for @acronym{DOS} file @acronym{URL}s are not
specified by the standard, so consequently @acronym{IMAIL} defines its
point is not on any entity, an error is signalled. If the entity is
encoded, e.g. with quoted-printable or base64 encoding, it is decoded
before it is saved. If the entity is text, it is written to the file in
-text mode (relevant only under Windows and OS/2); otherwise it is
+text mode (relevant only under Windows); otherwise it is
written in binary mode.
@findex imail-mouse-save-mime-entity
do
(cd $directory; ln -s ed-ffi.scm .edwin-ffi)
done
-(cd microcode; scheme -load os2pm.scm < /dev/null)
(cd microcode; etags -r '/^DEF[A-Za-z_ \t(]+"\([^"]+\)"/' *.[ch])
(cd microcode/cmpauxmd; make all)
(cd pcsample; etags *.scm *.c)
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (c) 1993-95 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; File to generate a single loadable file for OS/2 Edwin
-\f
-(if (not (environment-bound? system-global-environment 'PACK-BINARIES))
- (load (merge-pathnames "pack" (directory-pathname (current-load-pathname)))
- '(RUNTIME LOAD)))
-
-(define (pack-edwin #!optional output)
- (pack-binaries (if (default-object? output) "lib/eddel.com" output)
- '(("edwin"
- "make.com"
- "edwinos2.bco"
- "edwin.bld"
- "utils.com"
- "nvector.com"
- "ring.com"
- "strtab.com"
- "strpad.com"
- "macros.com"
- "class.com"
- "clscon.com"
- "clsmac.com"
- "xform.com"
- "paths.com"
- "struct.com"
- "grpops.com"
- "txtprp.com"
- "regops.com"
- "motion.com"
- "search.com"
- "image.com"
- "comman.com"
- "docstr.com"
- "comtab.com"
- "modes.com"
- "buffer.com"
- "bufset.com"
- "undo.com"
- "display.com"
- "screen.com"
- "winren.com"
- "window.com"
- "utlwin.com"
- "bufwin.com"
- "bufwfs.com"
- "bufwiu.com"
- "bufwmc.com"
- "comwin.com"
- "modwin.com"
- "buffrm.com"
- "edtfrm.com"
- "calias.com"
- "edtstr.com"
- "editor.com"
- "curren.com"
- "simple.com"
- "debuge.com"
- "modlin.com"
- "input.com"
- "prompt.com"
- "comred.com"
- "bufinp.com"
- "bufout.com"
- "winout.com"
- "things.com"
- "tparse.com"
- "syntax.com"
- "regexp.com"
- "rgxcmp.com"
- "linden.com"
- "os2.com"
- "dosfile.com"
- "fileio.com"
- "os2term.com"
- "process.com"
- "mousecom.com"
- "os2com.com"
- "debug.com"
- "dired.com"
- "diros2.com"
- "argred.com"
- "autold.com"
- "autosv.com"
- "basic.com"
- "bufcom.com"
- "bufmnu.com"
- "c-mode.com"
- "cinden.com"
- "comhst.com"
- "comint.com"
- "compile.com"
- "dabbrev.com"
- "evlcom.com"
- "filcom.com"
- "fill.com"
- "hlpcom.com"
- "info.com"
- "intmod.com"
- "keymap.com"
- "kilcom.com"
- "kmacro.com"
- "lincom.com"
- "lspcom.com"
- "malias.com"
- "motcom.com"
- "occur.com"
- "outline.com"
- "reccom.com"
- "regcom.com"
- "replaz.com"
- "rmail.com"
- "rmailsum.com"
- "rmailsrt.com"
- "schmod.com"
- "sendmail.com"
- "sercom.com"
- "iserch.com"
- "shell.com"
- "tagutl.com"
- "texcom.com"
- "wincom.com"
- "scrcom.com"
- "modefs.com"
- "rename.com"
- "loadef.com"
- "notify.com"))))
\ No newline at end of file
((WIN32)
((access set-focus (->environment '(win32)))
((access get-handle (->environment '(win32))) 1)))
- ((OS/2)
- (os2-screen/activate! (selected-screen)))
(else
(error "Unsupported graphics type:" name)))))
((DOS NT)
"
Again, use the File Manager to format the floppy.")
- ((OS/2)
- "
-Again, use the Drive object to format the floppy.")
(else "")))
(append-string
"
(write-pixel pixels n-is-1 v)
(write-pixel pixels (fix:+ n-is-1 1) v)
(x-loop (fix:+ px 1) (fix:+ ix h-sf)))
- (y-loop (fix:- py 1)
+ (y-loop (fix:- py 1)
(fix:+ iy-index rect-index-height))))))))
((and (fix:= 3 h-sf) (fix:= 3 v-sf))
(write-pixel pixels (fix:+ row2 1) v)
(write-pixel pixels (fix:+ row2 2) v)
(x-loop (fix:+ px 1) (fix:+ ix h-sf)))
- (y-loop (fix:- py 1)
+ (y-loop (fix:- py 1)
(fix:+ iy-index rect-index-height))))))))
((and (fix:= 4 h-sf) (fix:= 4 v-sf))
(write-pixel pixels (fix:+ row3 2) v)
(write-pixel pixels (fix:+ row3 3) v)
(x-loop (fix:+ px 1) (fix:+ ix h-sf)))
- (y-loop (fix:- py 1)
+ (y-loop (fix:- py 1)
(fix:+ iy-index rect-index-height))))))))
- (else
+ (else
(let y-loop ((py py-max) (iy-index 0))
(if (fix:<= 0 py)
(let ((pic-row (vector-ref pic-data py)))
(m-loop (fix:+ m 1)))
(n-loop (fix:+ n image-width)))))
(x-loop (fix:+ px 1) (fix:+ ix h-sf)))))
- (y-loop (fix:- py 1)
+ (y-loop (fix:- py 1)
(fix:+ iy-index rect-index-height)))))))))
;; Kludge: IMAGE/FILL-FROM-BYTE-VECTOR should take an argument
;; that specifies what color a given byte in PIXELS maps to.
- ;; OS/2 requires this information, so we supply it here.
- (if (eq? 'OS/2 microcode-id/operating-system)
- (os2-image/set-colormap image (os2-image-colormap)))
(image/fill-from-byte-vector image pixels)
(1d-table/put! (graphics-device/properties window) image (cons h-sf v-sf))
image))
\ No newline at end of file
(case name
((X) (make-window/X11 width height x y))
((WIN32) (make-window/win32 width height x y))
- ((OS/2) (make-window/OS2 width height x y))
(else (error "Unsupported graphics type:" name))))))
(graphics-set-coordinate-limits window 0 (- (- height 1)) (- width 1) 0)
(restore-focus-to-editor)
(graphics-operation window 'MOVE-WINDOW x y)
window))
-(define (make-window/OS2 width height x y)
- (let ((window (make-graphics-device 'OS/2 width height)))
- ;; X, Y specify the position of the upper-left corner of the
- ;; window, in coordinates relative to the upper-left corner of the
- ;; display with Y growing down; the OS/2 SET-WINDOW-POSITION
- ;; operation specifies the position of the lower-left corner of
- ;; the window, in coordinates relative to the lower left corner of
- ;; the display, with Y growing up.
- (call-with-values (lambda () (graphics-operation window 'DESKTOP-SIZE))
- (lambda (dx dy)
- dx
- (call-with-values
- (lambda () (graphics-operation window 'WINDOW-FRAME-SIZE))
- (lambda (fx fy)
- fx
- (graphics-operation window 'SET-WINDOW-POSITION
- x
- (- dy (+ y fy)))))))
- window))
-
-(define os2-image-colormap:gray-256
- (make-initialized-vector 256
- (lambda (index)
- (+ (* index #x10000)
- (* index #x100)
- index))))
-
(define (resize-window window width height)
(let ((name (graphics-type-name (graphics-type window))))
(case name
((X WIN32) (graphics-operation window 'RESIZE-WINDOW width height))
- ((OS/2) (graphics-operation window 'SET-WINDOW-SIZE width height))
(else (error "Unsupported graphics type:" name)))))
(define (show-window-size window)
(case name
((X) (n-gray-map/X11 window))
((WIN32) (n-gray-map/win32 window))
- ((OS/2) (n-gray-map/os2 window))
(else (error "Unsupported graphics type:" name)))))
(define n-gray-map/win32
(vector-set! map i i))
(lambda (window) window map)))
-(define n-gray-map/os2
- (let ((map (make-vector 256)))
- (do ((i 0 (fix:+ i 1)))
- ((fix:= i 256))
- (vector-set! map i i))
- (lambda (window) window map)))
-
(define (n-gray-map/X11 window)
(let ((properties (x-display/properties (x-graphics/display window))))
(or (1d-table/get properties '6001-GRAY-MAP #f)
.PHONY: bundle-compiler
bundle-compiler: liarc-bundle-tools
bundle-compiler: compile-compiler
-bundle-compiler: compiler/compiler-os2.c
bundle-compiler: compiler/compiler-unx.c
bundle-compiler: compiler/compiler-w32.c
(cd compiler && $(MAKE) compile-liarc-bundle)
| $(TOOL_SYNTAXER)
# XXX Kludgey bogus rules for liarc.
-compiler/compiler-os2.pkd: compiler/compiler-unx.pkd
compiler/compiler-w32.pkd: compiler/compiler-unx.pkd
# CREF
.PHONY: bundle-cref
bundle-cref: liarc-bundle-tools
bundle-cref: compile-cref
-bundle-cref: cref/cref-os2.c
bundle-cref: cref/cref-unx.c
bundle-cref: cref/cref-w32.c
(cd cref && $(MAKE) compile-liarc-bundle)
| $(TOOL_SYNTAXER)
# XXX Kludgey bogus rules for liarc.
-cref/cref-os2.pkd: cref/cref-unx.pkd
cref/cref-w32.pkd: cref/cref-unx.pkd
# Runtime
@IF_LIARC@all-runtime: bundle-runtime
.PHONY: bundle-runtime
-bundle-runtime: runtime/runtime-os2.c
bundle-runtime: runtime/runtime-unx.c
bundle-runtime: runtime/runtime-w32.c
| $(TOOL_SYNTAXER)
# XXX Kludgey bogus rules for liarc.
-runtime/runtime-os2.pkd: runtime/runtime-unx.pkd
runtime/runtime-w32.pkd: runtime/runtime-unx.pkd
# SF
.PHONY: bundle-sf
bundle-sf: liarc-bundle-tools
bundle-sf: compile-sf
-bundle-sf: sf/sf-os2.c
bundle-sf: sf/sf-unx.c
bundle-sf: sf/sf-w32.c
(cd sf && $(MAKE) compile-liarc-bundle)
| $(TOOL_SYNTAXER)
# XXX Kludgey bogus rules for liarc.
-sf/sf-os2.pkd: sf/sf-unx.pkd
sf/sf-w32.pkd: sf/sf-unx.pkd
### More stuff we build with tools. We could build it with the newly
bundle-edwin: liarc-bundle-tools
bundle-edwin: compile-edwin
bundle-edwin: edwin/edwin.c
-bundle-edwin: edwin/edwin-os2.c
bundle-edwin: edwin/edwin-unx.c
bundle-edwin: edwin/edwin-w32.c
(cd edwin && $(MAKE) compile-liarc-bundle)
| $(TOOL_SYNTAXER)
# XXX Kludgey bogus rules for liarc.
-edwin/edwin-os2.pkd: edwin/edwin-unx.pkd
edwin/edwin-w32.pkd: edwin/edwin-unx.pkd
# FFI
.PHONY: bundle-ffi
bundle-ffi: liarc-bundle-tools
bundle-ffi: compile-ffi
-bundle-ffi: ffi/ffi-os2.c
bundle-ffi: ffi/ffi-unx.c
bundle-ffi: ffi/ffi-w32.c
(cd ffi && $(MAKE) compile-liarc-bundle)
| $(TOOL_SYNTAXER)
# XXX Kludgey bogus rules for liarc.
-ffi/ffi-os2.pkd: ffi/ffi-unx.pkd
ffi/ffi-w32.pkd: ffi/ffi-unx.pkd
# SOS
.PHONY: bundle-sos
bundle-sos: liarc-bundle-tools
bundle-sos: compile-sos
-bundle-sos: sos/sos-os2.c
bundle-sos: sos/sos-unx.c
bundle-sos: sos/sos-w32.c
(cd sos && $(MAKE) compile-liarc-bundle)
| $(TOOL_SYNTAXER)
# XXX Kludgey bogus rules for liarc.
-sos/sos-os2.pkd: sos/sos-unx.pkd
sos/sos-w32.pkd: sos/sos-unx.pkd
# SSP
.PHONY: bundle-ssp
bundle-ssp: liarc-bundle-tools
bundle-ssp: compile-ssp
-bundle-ssp: ssp/ssp-os2.c
bundle-ssp: ssp/ssp-unx.c
bundle-ssp: ssp/ssp-w32.c
(cd ssp && $(MAKE) compile-liarc-bundle)
| $(TOOL_SYNTAXER)
# XXX Kludgey bogus rules for liarc.
-ssp/ssp-os2.pkd: ssp/ssp-unx.pkd
ssp/ssp-w32.pkd: ssp/ssp-unx.pkd
# *PARSER
.PHONY: bundle-star-parser
bundle-star-parser: liarc-bundle-tools
bundle-star-parser: compile-star-parser
-bundle-star-parser: star-parser/parser-os2.c
bundle-star-parser: star-parser/parser-unx.c
bundle-star-parser: star-parser/parser-w32.c
(cd star-parser && $(MAKE) compile-liarc-bundle)
| $(TOOL_SYNTAXER)
# XXX Kludgey bogus rules for liarc.
-star-parser/parser-os2.pkd: star-parser/parser-unx.pkd
star-parser/parser-w32.pkd: star-parser/parser-unx.pkd
# Windows FFI
| $(TOOL_SYNTAXER)
# XXX Kludgey bogus rules for liarc.
-win32/win32-os2.pkd: win32/win32-unx.pkd
win32/win32-w32.pkd: win32/win32-unx.pkd
# XML
.PHONY: bundle-xml
bundle-xml: liarc-bundle-tools
bundle-xml: compile-xml
-bundle-xml: xml/xml-os2.c
bundle-xml: xml/xml-unx.c
bundle-xml: xml/xml-w32.c
(cd xml && $(MAKE) compile-liarc-bundle)
| $(TOOL_SYNTAXER)
# XXX Kludgey bogus rules for liarc.
-xml/xml-os2.pkd: xml/xml-unx.pkd
xml/xml-w32.pkd: xml/xml-unx.pkd
### Cross-compilation finish-up.
.PHONY: bundle-imail
bundle-imail: liarc-bundle-tools
bundle-imail: compile-imail
-bundle-imail: imail/imail-os2.c
bundle-imail: imail/imail-unx.c
bundle-imail: imail/imail-w32.c
(cd imail && $(MAKE) compile-liarc-bundle)
# XXX These depend on imail/imail-unx.pkd intentionally because make
# has no good way to express a rule that generates multiple files at
# once.
-imail/imail-os2.c: imail/imail-unx.pkd
- echo '(cbf "imail/imail-os2.pkd")' | $(TARGET_COMPILER)
imail/imail-unx.c: imail/imail-unx.pkd
echo '(cbf "imail/imail-unx.pkd")' | $(TARGET_COMPILER)
imail/imail-w32.c: imail/imail-unx.pkd
(read-package-model filename os-type))))))
(define os-types
- '(NT OS/2 UNIX))
+ '(NT UNIX))
\f
(define cref/generate-cref
(generate/common
"make"
"nntp"
"nvector"
- "os2term"
"paths"
"rcsparse"
"rename"
"debuge"
"diff"
"dired"
- "diros2"
"dirunx"
"dirw32"
"docstr"
"notify"
"outline"
"occur"
- "os2"
- "os2com"
"paredit"
"pasmod"
"print"
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Directory Editor (OS/2 Customizations)
-;;; package: (edwin dired)
-
-(declare (usual-integrations))
-\f
-(define-key 'dired #\Z 'dired-do-compress)
-(define-key 'dired #\S 'dired-hidden-toggle)
-(define-key 'dired #\M 'dired-chmod)
-
-(define-command dired-do-compress
- "Compress or uncompress marked (or next ARG) files.
-The files are compressed or uncompressed using gzip."
- "P"
- (lambda (argument)
- (let ((n
- (dired-change-files "compress" argument
- (let ((gzip (os/find-program "gzip" #f (ref-variable exec-path)))
- (directory (buffer-default-directory (current-buffer))))
- (lambda (pathname lstart)
- (let ((type (pathname-type pathname))
- (namestring (->namestring pathname)))
- (let ((decompress? (equal? type "gz")))
- (message (if decompress? "Unc" "C")
- "ompressing file `" namestring "'...")
- (run-synchronous-process #f #f directory #f
- gzip
- (if decompress? "-d" "")
- namestring)
- (dired-redisplay
- (pathname-new-type
- pathname
- (and (not decompress?)
- (if (string? type)
- (string-append type ".gz")
- "gz")))
- lstart))))))))
- (if (positive? n)
- (message "Compressed or uncompressed " n " files.")))))
-
-(define-command dired-hidden-toggle
- "Toggle display of hidden/system files on and off."
- ()
- (lambda () (dired-toggle-switch #\a)))
-\f
-(define-command dired-chmod
- "Change mode of this file."
- "sChange to Mode\nP"
- (lambda (spec argument)
- (call-with-values (lambda () (os2/parse-attributes-spec spec))
- (lambda (plus minus)
- (dired-change-files "change attributes of" argument
- (lambda (pathname lstart)
- (set-file-modes! pathname
- (fix:or (fix:andc (file-modes pathname)
- minus)
- plus))
- (dired-redisplay pathname lstart)))))))
-
-(define (os2/parse-attributes-spec spec)
- (let ((end (string-length spec))
- (plus '())
- (minus '()))
- (let loop ((index 0) (state #f))
- (if (< index end)
- (let ((char (char-downcase (string-ref spec index)))
- (index (+ index 1)))
- (case char
- ((#\+ #\-)
- (loop index char))
- ((#\a #\h #\r #\s)
- (set! plus (delv! char plus))
- (set! minus (delv! char minus))
- (case state
- ((#\+)
- (set! plus (cons char plus))
- (loop index state))
- ((#\-)
- (set! minus (cons char minus))
- (loop index state))
- (else #f)))
- (else #f)))
- (values (os2/attribute-letters-to-mask plus)
- (os2/attribute-letters-to-mask minus))))))
-
-(define (os2/attribute-letters-to-mask letters)
- (let ((mask 0))
- (for-each (lambda (letter)
- (set! mask
- (fix:or (case letter
- ((#\a) os2-file-mode/archived)
- ((#\d) os2-file-mode/directory)
- ((#\h) os2-file-mode/hidden)
- ((#\r) os2-file-mode/read-only)
- ((#\s) os2-file-mode/system)
- (else (error "Unknown mode letter:" letter)))
- mask))
- unspecific)
- letters)
- mask))
\ No newline at end of file
("debuge" (edwin))
("diff" (edwin diff))
("dired" (edwin dired))
- ("diros2" (edwin dired))
("dirunx" (edwin dired))
("dirw32" (edwin dired))
("display" (edwin display-type))
("notify" (edwin))
("nvector" (edwin))
("occur" (edwin occurrence))
- ("os2" (edwin))
- ("os2com" (edwin os2-commands))
- ("os2term" (edwin screen os2-screen))
("outline" (edwin))
("paredit" (edwin paredit))
("pasmod" (edwin))
(define string-member? (member-procedure string=?))
(define (boolean-and a b) (and a b))
- (if (memq (lookup 'OS-TYPE) '(UNIX OS/2 NT))
+ (if (memq (lookup 'OS-TYPE) '(UNIX NT))
(begin
(load-option 'SUBPROCESS)
(load-option 'SYNCHRONOUS-SUBPROCESS)))
(load "unix" environment))
((DOS NT)
(load "dos" environment)
- (load "dosfile" environment))
- ((OS/2)
- (load "os2" environment)
(load "dosfile" environment)))
(load "fileio" environment)
- (if (not (eq? 'OS/2 (lookup 'OS-TYPE)))
- (let ((env (->environment '(EDWIN SCREEN CONSOLE-SCREEN))))
- (load-set-and-initialize! '("termcap" "tterm") env)
- (if (memq (lookup 'OS-TYPE) '(DOS NT))
- (begin
- (load "ansi" env)
- (if (load "bios" env)
- ((access bios-initialize-package! env)))))))
+ (let ((env (->environment '(EDWIN SCREEN CONSOLE-SCREEN))))
+ (load-set-and-initialize! '("termcap" "tterm") env)
+ (if (memq (lookup 'OS-TYPE) '(DOS NT))
+ (begin
+ (load "ansi" env)
+ (if (load "bios" env)
+ ((access bios-initialize-package! env))))))
(case (lookup 'OS-TYPE)
((NT)
((UNIX)
(load-set-and-initialize! '("xterm")
(->environment '(EDWIN SCREEN X-SCREEN)))
- (load "key-x11" (->environment '(EDWIN X-KEYS))))
- ((OS/2)
- (load-set-and-initialize! '("os2term")
- (->environment
- '(EDWIN SCREEN OS2-SCREEN)))))
+ (load "key-x11" (->environment '(EDWIN X-KEYS)))))
(load-case 'OS-TYPE
'((UNIX . "process")
- (OS/2 . "process")
(DOS . "dosproc")
(NT . "process"))
(->environment '(EDWIN PROCESS)))
(load "mousecom" environment)
(case (lookup 'OS-TYPE)
((UNIX) (load "xcom" (->environment '(EDWIN X-COMMANDS))))
- ((NT) (load "win32com" (->environment '(EDWIN WIN-COMMANDS))))
- ((OS/2) (load "os2com" (->environment '(EDWIN OS2-COMMANDS)))))
+ ((NT) (load "win32com" (->environment '(EDWIN WIN-COMMANDS)))))
;; debug depends on button1-down defined in mousecom
(load "debug" (->environment '(EDWIN DEBUGGER)))
(load "dired" env)
(case (lookup 'OS-TYPE)
((UNIX) (load "dirunx" env))
- ((OS/2) (load "diros2" env))
((NT) (load "dirw32" env))))
(load "abbrev" environment)
(extend-package (edwin process)
(files "process"))
-
+
(define-package (edwin screen x-screen)
(files "xterm")
(parent (edwin screen))
edwin-command$show-frame-position
edwin-command$show-frame-size)
(export (edwin screen win32)
- update-win32-screen-name!)))
-
- ((os/2)
- (extend-package (edwin)
- (files "os2"
- "dosfile"
- "comint" ; command interpreter process stuff
- "compile" ; compilation subprocess
- "shell" ; shell subprocess commands
- "telnet" ; telnet subprocess commands
- )
- (import (runtime os2-window-primitives)
- os2-clipboard-read-text
- os2-clipboard-write-text))
-
- (extend-package (edwin dired)
- (files "diros2")
- (export (edwin)
- edwin-command$dired-chmod
- edwin-command$dired-do-compress
- edwin-command$dired-hidden-toggle))
-
- (extend-package (edwin process)
- (files "process"))
-
- (define-package (edwin screen os2-screen)
- (files "os2term")
- (parent (edwin screen))
- (export (edwin)
- os2-screen/get-frame-size
- os2-screen/get-position
- os2-screen/activate!
- os2-screen/deactivate!
- os2-screen/hide!
- os2-screen/lower!
- os2-screen/maximize!
- os2-screen/minimize!
- os2-screen/raise!
- os2-screen/restore!
- os2-screen/show!
- os2-screen/set-background-color!
- os2-screen/set-font!
- os2-screen/set-foreground-color!
- os2-screen/set-position!
- os2-screen/set-size!
- os2-screen/set-title!
- os2/desktop-width
- os2/desktop-height
- screen-char-width
- screen-char-height
- screen-pel-width
- screen-pel-height)
- (import (edwin keyboard)
- keyboard-peek-busy-no-hang)
- (import (runtime os2-window-primitives)
- button-event-type:down
- button-event/flags
- button-event/number
- button-event/type
- button-event/x
- button-event/y
- cursor_flash
- cursor_solid
- event-type
- event-type:button
- event-type:close
- event-type:command
- event-type:focus
- event-type:help
- event-type:key
- event-type:paint
- event-type:resize
- event-type:visibility
- event-wid
- focus-event/gained?
- font-metrics/descender
- font-metrics/height
- font-metrics/width
- hwnd_desktop
- idi_edwin
- kc_alt
- kc_ctrl
- kc_virtualkey
- key-event/code
- key-event/flags
- key-event/repeat
- nullhandle
- number-of-event-types
- os2ps-clear
- os2ps-set-colors
- os2ps-set-font
- os2ps-write
- os2win-activate
- os2win-alarm
- os2win-close
- os2win-close-event-qid
- os2win-console-wid
- os2win-desktop-height
- os2win-desktop-width
- os2win-destroy-pointer
- os2win-event-ready?
- os2win-focus?
- os2win-get-event
- os2win-get-frame-size
- os2win-get-pos
- os2win-get-size
- os2win-invalidate
- os2win-load-pointer
- os2win-move-cursor
- os2win-open
- os2win-open-event-qid
- os2win-ps
- os2win-scroll
- os2win-set-grid
- os2win-set-icon
- os2win-set-pos
- os2win-set-size
- os2win-set-state
- os2win-set-title
- os2win-shape-cursor
- os2win-show
- os2win-show-cursor
- paint-event/xh
- paint-event/xl
- paint-event/yh
- paint-event/yl
- resize-event/height
- resize-event/width
- virtual-key-supremum
- visibility-event/shown?
- vk_backspace
- vk_backtab
- vk_break
- vk_button1
- vk_button2
- vk_button3
- vk_clear
- vk_delete
- vk_down
- vk_end
- vk_enddrag
- vk_enter
- vk_ereof
- vk_esc
- vk_f1
- vk_f10
- vk_f11
- vk_f12
- vk_f13
- vk_f14
- vk_f15
- vk_f16
- vk_f17
- vk_f18
- vk_f19
- vk_f2
- vk_f20
- vk_f21
- vk_f22
- vk_f23
- vk_f24
- vk_f3
- vk_f4
- vk_f5
- vk_f6
- vk_f7
- vk_f8
- vk_f9
- vk_home
- vk_insert
- vk_left
- vk_newline
- vk_pa1
- vk_pagedown
- vk_pageup
- vk_pause
- vk_printscrn
- vk_right
- vk_space
- vk_sysrq
- vk_tab
- vk_up
- wa_error
- window-state:bottom
- window-state:hide
- window-state:maximize
- window-state:minimize
- window-state:restore
- window-state:top)
- (initialization (initialize-package!)))
-
- (define-package (edwin os2-commands)
- (files "os2com")
- (parent (edwin))
- (export (edwin)
- edwin-command$define-color-name
- edwin-command$set-background-color
- edwin-command$set-font
- edwin-command$set-foreground-color
- edwin-command$set-frame-name
- edwin-command$set-frame-position
- edwin-command$set-frame-size
- edwin-command$set-screen-position
- edwin-command$set-screen-size
- edwin-command$show-frame-position
- edwin-command$show-frame-size
- edwin-command$show-screen-position
- edwin-command$show-screen-size)
- (export (edwin screen os2-screen)
- update-os2-screen-names!))))
+ update-win32-screen-name!))))
\f
(define-package (edwin diff)
(files "diff")
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; OS/2 Customizations for Edwin
-
-(declare (usual-integrations))
-\f
-(define (os/set-file-modes-writeable! pathname)
- (set-file-modes! pathname
- (fix:andc (file-modes pathname) os2-file-mode/read-only)))
-
-(define (os/restore-modes-to-updated-file! pathname modes)
- (set-file-modes! pathname (fix:or modes os2-file-mode/archived)))
-
-(define (os/scheme-can-quit?)
- #f)
-
-(define (os/quit dir)
- dir
- (error "Can't quit."))
-
-(define (dos/read-dired-files file all-files?)
- (let loop
- ((pathnames
- (let ((pathnames (directory-read file #f)))
- (if all-files?
- pathnames
- (list-transform-positive pathnames
- (let ((mask
- (fix:or os2-file-mode/hidden os2-file-mode/system)))
- (lambda (pathname)
- (fix:= (fix:and (file-modes pathname) mask) 0)))))))
- (result '()))
- (if (null? pathnames)
- result
- (loop (cdr pathnames)
- (let ((attr (file-attributes (car pathnames))))
- (if attr
- (cons (cons (file-namestring (car pathnames)) attr) result)
- result))))))
-\f
-;;;; OS/2 Clipboard Interface
-
-(define (os/interprogram-cut string context)
- context
- (os2-clipboard-write-text
- (let ((string (convert-newline-to-crlf string)))
- ;; Some programs can't handle strings over 64k.
- (if (fix:< (string-length string) #x10000) string ""))))
-
-(define (os/interprogram-paste context)
- context
- (let ((text (os2-clipboard-read-text)))
- (and text
- (convert-crlf-to-newline text))))
-
-(define (convert-newline-to-crlf string)
- (let ((end (string-length string)))
- (let ((n-newlines
- (let loop ((start 0) (n-newlines 0))
- (let ((newline
- (substring-find-next-char string start end #\newline)))
- (if newline
- (loop (fix:+ newline 1) (fix:+ n-newlines 1))
- n-newlines)))))
- (if (fix:= n-newlines 0)
- string
- (let ((copy (make-string (fix:+ end n-newlines))))
- (let loop ((start 0) (cindex 0))
- (let ((newline
- (substring-find-next-char string start end #\newline)))
- (if newline
- (begin
- (%substring-move! string start newline copy cindex)
- (let ((cindex (fix:+ cindex (fix:- newline start))))
- (string-set! copy cindex #\return)
- (string-set! copy (fix:+ cindex 1) #\newline)
- (loop (fix:+ newline 1) (fix:+ cindex 2))))
- (%substring-move! string start end copy cindex))))
- copy)))))
-
-(define (convert-crlf-to-newline string)
- (let ((end (string-length string)))
- (let ((n-crlfs
- (let loop ((start 0) (n-crlfs 0))
- (let ((cr
- (substring-find-next-char string start end #\return)))
- (if (and cr
- (not (fix:= (fix:+ cr 1) end))
- (char=? (string-ref string (fix:+ cr 1)) #\linefeed))
- (loop (fix:+ cr 2) (fix:+ n-crlfs 1))
- n-crlfs)))))
- (if (fix:= n-crlfs 0)
- string
- (let ((copy (make-string (fix:- end n-crlfs))))
- (let loop ((start 0) (cindex 0))
- (let ((cr
- (substring-find-next-char string start end #\return)))
- (if (not cr)
- (%substring-move! string start end copy cindex)
- (let ((cr
- (if (and (not (fix:= (fix:+ cr 1) end))
- (char=? (string-ref string (fix:+ cr 1))
- #\linefeed))
- cr
- (fix:+ cr 1))))
- (%substring-move! string start cr copy cindex)
- (loop (fix:+ cr 1) (fix:+ cindex (fix:- cr start)))))))
- copy)))))
-\f
-;;;; Mail Customization
-
-(define (os/sendmail-program)
- "sendmail")
-
-(define (os/rmail-spool-directory)
- (or (let ((etc (get-environment-variable "ETC")))
- (and etc
- (file-directory? etc)
- (let ((mail
- (merge-pathnames "mail/" (pathname-as-directory etc))))
- (and (file-directory? mail)
- (->namestring mail)))))
- "c:\\mptn\\etc\\mail\\"))
-
-(define (os/rmail-primary-inbox-list system-mailboxes)
- system-mailboxes)
-
-(define (os/rmail-pop-procedure)
- (and (os/find-program "popclient" #f (ref-variable exec-path) #f)
- (lambda (server user-name password directory)
- (os2-pop-client server user-name password directory))))
-
-(define (os2-pop-client server user-name password directory)
- (let ((target
- (->namestring
- (merge-pathnames (if (dos/fs-long-filenames? directory)
- ".popmail"
- "popmail.tmp")
- directory))))
- (let ((buffer (temporary-buffer "*popclient*")))
- (cleanup-pop-up-buffers
- (lambda ()
- (pop-up-buffer buffer #f)
- (let ((status.reason
- (let ((args
- (list "-u" user-name
- "-p" (os2-pop-client-password password)
- "-o" target
- server)))
- (apply run-synchronous-process
- #f (cons (buffer-end buffer) #t) #f #f
- "popclient"
- "-3"
- (if (ref-variable rmail-pop-delete)
- args
- (cons "-k" args))))))
- (if (and (eq? 'EXITED (car status.reason))
- (memv (cdr status.reason) '(0 1)))
- (kill-pop-up-buffer buffer)
- (begin
- (keep-pop-up-buffer buffer)
- (editor-error "Error getting mail from POP server.")))))))
- target))
-
-(define (os2-pop-client-password password)
- (cond ((string? password)
- password)
- ((and (pair? password) (eq? 'FILE (car password)))
- (call-with-input-file (cadr password)
- (lambda (port)
- (read-string (char-set #\newline) port))))
- (else
- (error "Illegal password:" password))))
-
-(define-variable rmail-pop-delete
- "If true, messages are deleted from the POP server after being retrieved.
-Otherwise, messages remain on the server and will be re-fetched later."
- #t
- boolean?)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; OS/2 Presentation Manager Commands
-
-(declare (usual-integrations))
-\f
-(define-command set-foreground-color
- "Set foreground (text) color to COLOR."
- "sSet foreground color"
- (lambda (name)
- (let ((screen (selected-screen)))
- (os2-screen/set-foreground-color! screen (os2/find-color name))
- (update-screen! screen #t))))
-
-(define-command set-background-color
- "Set background (text) color to COLOR."
- "sSet background color"
- (lambda (name)
- (let ((screen (selected-screen)))
- (os2-screen/set-background-color! screen (os2/find-color name))
- (update-screen! screen #t))))
-
-(define-command define-color-name
- "Globally define COLOR-NAME to be COLOR.
-This does not affect any colors on the screen,
-but changes the meaning of COLOR-NAME when it is used in the future."
- "sDefine color\nsDefine color to"
- (lambda (name color)
- (os2/define-color name color)))
-
-(define-command set-font
- "Set font to be used for drawing text."
- "sSet font"
- (lambda (font)
- (let ((screen (selected-screen)))
- (os2-screen/set-font! screen font)
- (update-screen! screen #t))))
-
-(define-command set-frame-size
- "Set size of editor frame to WIDTH x HEIGHT."
- "nFrame width (chars)\nnFrame height (chars)"
- (lambda (width height)
- (os2-screen/set-size! (selected-screen) (max 2 width) (max 2 height))))
-
-(define-command set-frame-position
- "Set position of editor frame to (X,Y)."
- "nFrame X position (pels)\nnFrame Y position (pels)"
- (lambda (x y)
- (os2-screen/set-position! (selected-screen) x y)))
-
-(define-command show-frame-size
- "Show size of editor frame."
- ()
- (lambda ()
- (let ((screen (selected-screen)))
- (message "Frame is "
- (screen-x-size screen)
- " chars wide and "
- (screen-y-size screen)
- " chars high ("
- (screen-pel-width screen)
- "x"
- (screen-pel-height screen)
- " pels)"))))
-
-(define-command show-frame-position
- "Show position of editor frame.
-This is the position of the lower left-hand corner of the frame border
-surrounding the frame, relative to the lower left-hand corner of the
-desktop."
- ()
- (lambda ()
- (call-with-values (lambda () (os2-screen/get-position (selected-screen)))
- (lambda (x y)
- (message "Frame's lower left-hand corner is at (" x "," y ")")))))
-
-;; For upwards compatibility
-(define edwin-command$set-screen-size edwin-command$set-frame-size)
-(define edwin-command$set-screen-position edwin-command$set-frame-position)
-(define edwin-command$show-screen-size edwin-command$show-frame-size)
-(define edwin-command$show-screen-position edwin-command$show-frame-position)
-\f
-(define-command set-frame-name
- "Set name of selected frame to NAME.
-Useful only if `frame-name-format' is false."
- "sSet frame name"
- (lambda (name) (os2-screen/set-title! (selected-screen) name)))
-
-(define (update-os2-screen-names! screen)
- (let ((window
- (if (and (selected-screen? screen) (within-typein-edit?))
- (typein-edit-other-window)
- (screen-selected-window screen))))
- (let ((buffer (window-buffer window)))
- (let ((format (ref-variable frame-name-format buffer))
- (length (ref-variable frame-name-length buffer)))
- (if format
- (os2-screen/set-title!
- screen
- (string-trim-right
- (format-modeline-string window format length))))))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; OS/2 Presentation Manager Interface
-;;; Package: (edwin screen os2-screen)
-
-(declare (usual-integrations))
-(declare (integrate-external "../runtime/os2winp"))
-\f
-(define os2-display-type)
-(define screen-list)
-(define event-queue)
-(define event-descriptor)
-(define virtual-key-table)
-(define signal-interrupts?)
-(define previewer-registration)
-(define reading-event?)
-(define desktop-width)
-(define desktop-height)
-(define hide-console?)
-(define edwin-screen-icon)
-
-(define (initialize-package!)
- (set! os2-display-type
- (make-display-type 'PM
- #t
- (lambda () (initialize-pm-state) #t)
- make-os2-screen
- get-os2-input-operations
- with-editor-interrupts-from-os2
- with-os2-interrupts-enabled
- with-os2-interrupts-disabled))
- (set! virtual-key-table (make-virtual-key-table))
- (set! event-descriptor #f)
- (add-event-receiver! event:before-exit finalize-pm-state))
-
-(define (initialize-pm-state)
- (if (not event-descriptor)
- (begin
- (set! screen-list '())
- (set! event-queue (make-queue))
- (set! event-descriptor (os2win-open-event-qid))
- (set! desktop-width (os2win-desktop-width))
- (set! desktop-height (os2win-desktop-height))
- (set! hide-console? #t)
- (set! edwin-screen-icon
- (os2win-load-pointer HWND_DESKTOP NULLHANDLE IDI_EDWIN))
- unspecific)))
-
-(define (finalize-pm-state)
- (if event-descriptor
- (begin
- (os2win-destroy-pointer edwin-screen-icon)
- (set! edwin-screen-icon)
- (do () ((null? screen-list)) (os2-screen/discard! (car screen-list)))
- (set! event-queue)
- (os2win-close-event-qid event-descriptor)
- (set! event-descriptor #f)
- unspecific)))
-\f
-(define (with-editor-interrupts-from-os2 receiver)
- (fluid-let ((reading-event? #f)
- (signal-interrupts? #t)
- (previewer-registration))
- (dynamic-wind (lambda ()
- (preview-event-stream)
- (if hide-console?
- (begin
- (set! hide-console? #f)
- (os2win-set-state (os2win-console-wid)
- window-state:hide))))
- (lambda ()
- (receiver (lambda (thunk) (thunk)) '()))
- (lambda ()
- (deregister-io-thread-event previewer-registration)))))
-
-(define (with-os2-interrupts-enabled thunk)
- (with-signal-interrupts #t thunk))
-
-(define (with-os2-interrupts-disabled thunk)
- (with-signal-interrupts #f thunk))
-
-(define (with-signal-interrupts enabled? thunk)
- (let ((old))
- (dynamic-wind (lambda ()
- (set! old signal-interrupts?)
- (set! signal-interrupts? enabled?)
- unspecific)
- thunk
- (lambda ()
- (set! enabled? signal-interrupts?)
- (set! signal-interrupts? old)
- unspecific))))
-\f
-(define (make-os2-screen)
- (call-with-values open-window
- (lambda (state x-size y-size)
- (let ((screen
- (make-screen state
- os2-screen/beep
- os2-screen/clear-line!
- os2-screen/clear-rectangle!
- os2-screen/clear-screen!
- os2-screen/discard!
- os2-screen/enter!
- os2-screen/exit!
- os2-screen/flush!
- os2-screen/modeline-event!
- #f
- os2-screen/scroll-lines-down!
- os2-screen/scroll-lines-up!
- os2-screen/wrap-update!
- os2-screen/write-char!
- os2-screen/write-cursor!
- os2-screen/write-substring!
- 8
- x-size
- y-size)))
- (set! screen-list (cons screen screen-list))
- screen))))
-
-(define (open-window)
- (let ((wid (os2win-open event-descriptor "Edwin")))
- (os2win-set-icon wid edwin-screen-icon)
- (let ((metrics
- (if current-font
- (let ((metrics (set-normal-font! wid current-font)))
- (if (not metrics)
- (error "Unknown font name:" current-font))
- metrics)
- (let loop ((fonts initial-font-list))
- (if (null? fonts)
- (error "Unable to find usable font:" initial-font-list))
- (let ((metrics (set-normal-font! wid (car fonts))))
- (if metrics
- (begin
- (set! current-font (car fonts))
- metrics)
- (loop (cdr fonts))))))))
- (os2ps-set-colors (os2win-ps wid)
- (face-foreground-color normal-face)
- (face-background-color normal-face))
- (os2win-show-cursor wid #t)
- (os2win-show wid #t)
- (os2win-activate wid)
- (let ((w.h (os2win-get-size wid)))
- (let ((x-size (fix:quotient (car w.h) (font-metrics/width metrics)))
- (y-size (fix:quotient (cdr w.h) (font-metrics/height metrics))))
- (let ((size (fix:* x-size y-size)))
- (values (make-screen-state wid
- metrics
- (car w.h)
- (cdr w.h)
- (make-string size #\space)
- (make-vector size normal-face))
- x-size
- y-size)))))))
-\f
-(define (os2-screen/beep screen)
- screen
- (os2win-alarm WA_ERROR))
-
-(define (os2-screen/clear-line! screen x y first-unused-x)
- (let ((start (screen-char-index screen x y))
- (end (screen-char-index screen first-unused-x y))
- (face (screen-normal-face screen)))
- (substring-fill! (screen-char-map screen) start end #\space)
- (subvector-fill! (screen-face-map screen) start end face)
- (set-screen-face! screen face))
- (os2ps-clear (screen-psid screen)
- (cxl->xl screen x)
- (cxh->xh screen first-unused-x)
- (cyh->yl screen (fix:+ y 1))
- (cyl->yh screen y)))
-
-(define (os2-screen/clear-rectangle! screen xl xu yl yu highlight)
- (if (fix:< xl xu)
- (let ((char-map (screen-char-map screen))
- (face-map (screen-face-map screen))
- (face (screen-face screen highlight))
- (x-size (screen-x-size screen))
- (width (fix:- xu xl)))
- (do ((y yl (fix:+ y 1))
- (start (screen-char-index screen xl yl) (fix:+ start x-size)))
- ((fix:= y yu))
- (let ((end (fix:+ start width)))
- (substring-fill! char-map start end #\space)
- (subvector-fill! face-map start end face)))
- (set-screen-face! screen face)
- (os2ps-clear (screen-psid screen)
- (cxl->xl screen xl) (cxh->xh screen xu)
- (cyh->yl screen yu) (cyl->yh screen yl)))))
-
-(define (os2-screen/clear-screen! screen)
- (let ((face (screen-normal-face screen)))
- (string-fill! (screen-char-map screen) #\space)
- (vector-fill! (screen-face-map screen) face)
- (set-screen-face! screen face))
- (os2ps-clear (screen-psid screen)
- 0 (screen-pel-width screen)
- 0 (screen-pel-height screen)))
-
-(define (os2-screen/discard! screen)
- (set! screen-list (delq! screen screen-list))
- (os2win-close (screen-wid screen)))
-\f
-(define (os2-screen/enter! screen)
- (os2win-activate (screen-wid screen)))
-
-(define (os2-screen/exit! screen)
- screen
- unspecific)
-
-(define (os2-screen/flush! screen)
- screen
- unspecific)
-
-(define (os2-screen/modeline-event! screen window type)
- screen window type
- unspecific)
-
-(define (os2-screen/wrap-update! screen thunk)
- (let ((finished? #f))
- (dynamic-wind (lambda () unspecific)
- (lambda ()
- (let ((result (thunk)))
- (set! finished? result)
- result))
- (lambda ()
- (set-screen-face! screen (screen-normal-face screen))
- (if finished?
- (update-os2-screen-names! screen))))))
-
-(define (os2-screen/write-cursor! screen x y)
- (os2win-move-cursor (screen-wid screen) (cx->x screen x) (cy->y screen y)))
-
-(define (os2-screen/write-char! screen x y char highlight)
- (let ((char-map (screen-char-map screen))
- (index (screen-char-index screen x y))
- (face (screen-face screen highlight)))
- (string-set! char-map index char)
- (vector-set! (screen-face-map screen) index face)
- (set-screen-face! screen face)
- (os2ps-write (screen-psid screen)
- (cx->x screen x)
- (fix:+ (cy->y screen y) (screen-char-descender screen))
- char-map
- index
- (fix:+ index 1))))
-
-(define (os2-screen/write-substring! screen x y string start end highlight)
- (let ((start* (screen-char-index screen x y))
- (face (screen-face screen highlight)))
- (%substring-move! string start end (screen-char-map screen) start*)
- (subvector-fill! (screen-face-map screen)
- start*
- (fix:+ start* (fix:- end start))
- face)
- (set-screen-face! screen face)
- (os2ps-write (screen-psid screen)
- (cx->x screen x)
- (fix:+ (cy->y screen y) (screen-char-descender screen))
- string start end)))
-\f
-(define use-scrolling? #t)
-
-(define (os2-screen/scroll-lines-down! screen xl xu yl yu amount)
- (and use-scrolling?
- (begin
- (let ((char-map (screen-char-map screen))
- (face-map (screen-face-map screen))
- (x-size (screen-x-size screen))
- (width (fix:- xu xl))
- (y-from (fix:- yu amount)))
- (if (fix:= x-size width)
- (let ((start (fix:* x-size yl))
- (end (fix:* x-size y-from))
- (start* (fix:* x-size (fix:+ yl amount))))
- (%substring-move! char-map start end char-map start*)
- (subvector-move-right! face-map start end face-map start*))
- (let ((delta (fix:* x-size amount))
- (end (screen-char-index screen xl (fix:- yl 1))))
- (do ((from (screen-char-index screen xl (fix:- y-from 1))
- (fix:- from x-size)))
- ((fix:= from end))
- (let ((from-end (fix:+ from width))
- (to (fix:+ from delta)))
- (%substring-move! char-map from from-end char-map to)
- (subvector-move-right! face-map from from-end
- face-map to))))))
- (os2win-scroll (screen-wid screen)
- (cxl->xl screen xl)
- (cxh->xh screen xu)
- (cyh->yl screen (fix:- yu amount))
- (cyl->yh screen yl)
- 0
- (fix:- 0 (fix:* amount (screen-char-height screen))))
- 'CLOBBERED-CURSOR)))
-
-(define (os2-screen/scroll-lines-up! screen xl xu yl yu amount)
- (and use-scrolling?
- (begin
- (let ((char-map (screen-char-map screen))
- (face-map (screen-face-map screen))
- (x-size (screen-x-size screen))
- (width (fix:- xu xl))
- (y-from (fix:+ yl amount)))
- (if (fix:= x-size width)
- (let ((start (fix:* x-size y-from))
- (end (fix:* x-size yu))
- (start* (fix:* x-size yl)))
- (%substring-move! char-map start end char-map start*)
- (subvector-move-left! face-map start end face-map start*))
- (let ((delta (fix:* x-size amount))
- (end (screen-char-index screen xl yu)))
- (do ((from (screen-char-index screen xl y-from)
- (fix:+ from x-size)))
- ((fix:= from end))
- (let ((from-end (fix:+ from width))
- (to (fix:- from delta)))
- (%substring-move! char-map from from-end char-map to)
- (subvector-move-left! face-map from from-end
- face-map to))))))
- (os2win-scroll (screen-wid screen)
- (cxl->xl screen xl)
- (cxh->xh screen xu)
- (cyh->yl screen yu)
- (cyl->yh screen (fix:+ yl amount))
- 0
- (fix:* amount (screen-char-height screen)))
- 'CLOBBERED-CURSOR)))
-\f
-(define-integrable (screen-face screen highlight)
- (if highlight
- (screen-highlight-face screen)
- (screen-normal-face screen)))
-
-(define (set-screen-face! screen face)
- (if (not (eq? face (screen-current-face screen)))
- (begin
- (os2ps-set-colors (screen-psid screen)
- (face-foreground-color face)
- (face-background-color face))
- (set-screen-current-face! screen face))))
-
-(define-structure face
- (foreground-color #f read-only #t)
- (background-color #f read-only #t))
-
-(define current-font #f)
-(define initial-font-list
- '("4.System VIO" "8.Courier" "10.Courier" "12.Courier"
- "10.System Monospaced"))
-(define normal-face (make-face #x000000 #xFFFFFF))
-(define highlight-face (make-face #xFFFFFF #x000000))
-
-(define-integrable (screen-normal-face screen) screen normal-face)
-(define-integrable (screen-highlight-face screen) screen highlight-face)
-
-(define (os2-screen/set-foreground-color! screen color)
- screen
- (set! normal-face
- (make-face color (face-background-color normal-face)))
- (set! highlight-face
- (make-face (face-foreground-color highlight-face) color))
- unspecific)
-
-(define (os2-screen/set-background-color! screen color)
- screen
- (set! normal-face
- (make-face (face-foreground-color normal-face) color))
- (set! highlight-face
- (make-face color (face-background-color highlight-face)))
- unspecific)
-\f
-(define (os2-screen/set-font! screen font)
- (let ((metrics (set-normal-font! (screen-wid screen) font)))
- (if (not metrics)
- (error "Unknown font name:" font))
- (set-screen-font-metrics! screen metrics))
- (set! current-font font)
- (let ((resize (screen-resize-thunk screen)))
- (if resize
- (resize))))
-
-(define (set-normal-font! wid font)
- (let ((metrics (os2ps-set-font (os2win-ps wid) 1 font)))
- (if metrics
- (let ((width (font-metrics/width metrics))
- (height (font-metrics/height metrics)))
- (os2win-set-grid wid width height)
- (os2win-shape-cursor wid width height
- (fix:or CURSOR_SOLID CURSOR_FLASH))))
- metrics))
-
-(define (os2-screen/set-size! screen x-size y-size)
- (os2win-set-size (screen-wid screen)
- (fix:* x-size (screen-char-width screen))
- (fix:* y-size (screen-char-height screen))))
-
-(define (os2-screen/get-frame-size screen)
- (let ((w.h (os2win-get-frame-size (screen-wid screen))))
- (values (car w.h)
- (cdr w.h))))
-
-(define (os2-screen/get-position screen)
- (let ((x.y (os2win-get-pos (screen-wid screen))))
- (values (car x.y)
- (cdr x.y))))
-
-(define (os2-screen/set-position! screen x y)
- (os2win-set-pos (screen-wid screen) x y))
-
-(define (os2-screen/set-title! screen title)
- (let ((title* (screen-current-title screen)))
- (if (not (and title* (string=? title title*)))
- (begin
- (set-screen-current-title! screen #f)
- (os2win-set-title (screen-wid screen) title)
- (set-screen-current-title! screen title)))))
-
-(define (os2-screen/raise! screen)
- (os2win-set-state (screen-wid screen) window-state:top))
-
-(define (os2-screen/lower! screen)
- (os2win-set-state (screen-wid screen) window-state:bottom))
-
-(define (os2-screen/show! screen)
- (os2win-set-state (screen-wid screen) window-state:show))
-
-(define (os2-screen/hide! screen)
- (os2win-set-state (screen-wid screen) window-state:hide))
-
-(define (os2-screen/activate! screen)
- (os2win-set-state (screen-wid screen) window-state:activate))
-
-(define (os2-screen/deactivate! screen)
- (os2win-set-state (screen-wid screen) window-state:deactivate))
-
-(define (os2-screen/minimize! screen)
- (os2win-set-state (screen-wid screen) window-state:minimize))
-
-(define (os2-screen/maximize! screen)
- (os2win-set-state (screen-wid screen) window-state:maximize))
-
-(define (os2-screen/restore! screen)
- (os2win-set-state (screen-wid screen) window-state:restore))
-
-(define (os2/desktop-width)
- desktop-width)
-
-(define (os2/desktop-height)
- desktop-height)
-\f
-(define-integrable (cx->x screen cx)
- ;; Returns leftmost pel of cell.
- (fix:* cx (screen-char-width screen)))
-
-(define-integrable (cy->y screen cy)
- ;; Returns bottommost pel of cell.
- (cyl->yh screen (fix:+ cy 1)))
-
-(define-integrable (cyl->yh screen cy)
- ;; Returns bottommost pel of cell above.
- (fix:* (fix:- (screen-y-size screen) cy) (screen-char-height screen)))
-
-(define-integrable cxl->xl cx->x)
-(define-integrable cxh->xh cx->x)
-(define-integrable cyh->yl cyl->yh)
-
-(define (x->cx screen x)
- (let ((cx (fix:quotient x (screen-char-width screen)))
- (xs (screen-x-size screen)))
- (if (fix:> cx xs)
- xs
- cx)))
-
-(define (y->cy screen y)
- (let ((cy
- (fix:- (fix:- (screen-y-size screen) 1)
- (fix:quotient y (screen-char-height screen)))))
- (if (fix:< cy 0)
- 0
- cy)))
-
-(define (xl->cxl screen xl)
- (let ((cx (fix:quotient xl (screen-char-width screen)))
- (xs (screen-x-size screen)))
- (if (fix:> cx xs)
- xs
- cx)))
-
-(define (xh->cxh screen xh)
- (let ((cx
- (let ((cw (screen-char-width screen)))
- (let ((cx (fix:quotient xh cw)))
- (if (fix:= 0 (fix:remainder xh cw))
- cx
- (fix:+ cx 1)))))
- (xs (screen-x-size screen)))
- (if (fix:> cx xs)
- xs
- cx)))
-
-(define (yl->cyh screen yl)
- (let ((cy
- (fix:- (screen-y-size screen)
- (fix:quotient yl (screen-char-height screen)))))
- (if (fix:< cy 0)
- 0
- cy)))
-
-(define (yh->cyl screen yh)
- (let ((cy
- (let ((ch (screen-char-height screen)))
- (let ((cy (fix:- (screen-y-size screen) (fix:quotient yh ch))))
- (if (fix:= 0 (fix:remainder yh ch))
- cy
- (fix:- cy 1))))))
- (if (fix:< cy 0)
- 0
- cy)))
-
-(define-integrable (width->x-size screen width)
- (fix:quotient width (screen-char-width screen)))
-
-(define-integrable (height->y-size screen height)
- (fix:quotient height (screen-char-height screen)))
-\f
-(define-structure (os2-screen-state
- (constructor
- make-screen-state
- (wid font-metrics pel-width pel-height char-map face-map))
- (predicate screen-state?)
- (conc-name screen-state/))
- (wid #f read-only #t)
- font-metrics
- (pel-width 0)
- (pel-height 0)
- (char-map "")
- (face-map '#())
- (current-face normal-face)
- (current-title #f))
-
-(define-integrable (screen-wid screen)
- (screen-state/wid (screen-state screen)))
-
-(define-integrable (screen-font-metrics screen)
- (screen-state/font-metrics (screen-state screen)))
-
-(define-integrable (set-screen-font-metrics! screen metrics)
- (set-screen-state/font-metrics! (screen-state screen) metrics))
-
-(define-integrable (screen-pel-width screen)
- (screen-state/pel-width (screen-state screen)))
-
-(define-integrable (set-screen-pel-width! screen width)
- (set-screen-state/pel-width! (screen-state screen) width))
-
-(define-integrable (screen-pel-height screen)
- (screen-state/pel-height (screen-state screen)))
-
-(define-integrable (set-screen-pel-height! screen height)
- (set-screen-state/pel-height! (screen-state screen) height))
-
-(define-integrable (screen-char-map screen)
- (screen-state/char-map (screen-state screen)))
-
-(define-integrable (set-screen-char-map! screen char-map)
- (set-screen-state/char-map! (screen-state screen) char-map))
-
-(define-integrable (screen-face-map screen)
- (screen-state/face-map (screen-state screen)))
-
-(define-integrable (set-screen-face-map! screen face-map)
- (set-screen-state/face-map! (screen-state screen) face-map))
-
-(define-integrable (screen-current-face screen)
- (screen-state/current-face (screen-state screen)))
-
-(define-integrable (set-screen-current-face! screen face)
- (set-screen-state/current-face! (screen-state screen) face))
-
-(define-integrable (screen-current-title screen)
- (screen-state/current-title (screen-state screen)))
-
-(define-integrable (set-screen-current-title! screen title)
- (set-screen-state/current-title! (screen-state screen) title))
-\f
-(define-integrable (screen-psid screen)
- (os2win-ps (screen-wid screen)))
-
-(define-integrable (screen-char-width screen)
- (font-metrics/width (screen-font-metrics screen)))
-
-(define-integrable (screen-char-height screen)
- (font-metrics/height (screen-font-metrics screen)))
-
-(define-integrable (screen-char-descender screen)
- (font-metrics/descender (screen-font-metrics screen)))
-
-(define-integrable (screen-char-index screen x y)
- (fix:+ (fix:* y (screen-x-size screen)) x))
-
-(define (wid->screen wid)
- (let loop ((screens screen-list))
- (and (not (null? screens))
- (if (fix:= wid (screen-wid (car screens)))
- (car screens)
- (loop (cdr screens))))))
-\f
-(define (get-os2-input-operations screen)
- screen
- (let ((pending #f)
- (repeat 0))
-
- (define (halt-update?)
- (setup-pending 'IN-UPDATE)
- pending)
-
- (define (peek-no-hang timeout)
- (keyboard-peek-busy-no-hang
- (lambda ()
- (setup-pending #f)
- pending)
- timeout))
-
- (define (peek)
- (setup-pending #t)
- pending)
-
- (define (read)
- (setup-pending #t)
- (let ((result pending))
- (if (fix:> repeat 1)
- (set! repeat (fix:- repeat 1))
- (set! pending #f))
- result))
-
- (define (setup-pending block?)
- (if (not pending)
- (let loop ()
- (let ((event (read-event block?)))
- (cond ((not event)
- (set! pending #f))
- ((input-event? event)
- (set! pending event)
- (set! repeat 1))
- ((not (vector? event))
- (let ((flag (process-change-event event)))
- (if flag
- (begin
- (set! pending
- (make-input-event
- (if (eq? flag 'FORCE-RETURN)
- 'RETURN
- 'UPDATE)
- update-screens!
- #f))
- (set! repeat 1))
- (loop))))
- ((fix:= event-type:key (event-type event))
- (set! pending (translate-key-event event))
- (set! repeat (key-event/repeat event))
- (cond ((fix:= 0 repeat)
- (set! pending #f))
- ((and (char? pending)
- (or (char=? pending #\BEL)
- (char=? pending #\C-g))
- signal-interrupts?)
- (set! pending #f)
- (signal-interrupt!)))
- (if (not pending)
- (loop)))
- (else
- (set! pending (process-special-event event))
- (if pending
- (set! repeat 1)
- (loop))))))))
-
- (values halt-update? peek-no-hang peek read)))
-\f
-(define (read-event block?)
- (let loop ()
- (set! reading-event? #t)
- (let ((event
- (if (queue-empty? event-queue)
- (if (eq? 'IN-UPDATE block?)
- (os2win-get-event event-descriptor #f)
- (read-event-1 block?))
- (dequeue!/unsafe event-queue))))
- (set! reading-event? #f)
- (if (and (vector? event) (fix:= (event-type event) event-type:paint))
- (begin
- (process-paint-event event)
- (loop))
- event))))
-
-(define (read-event-1 block?)
- (or (os2win-get-event event-descriptor #f)
- (let loop ()
- (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
- (cond (inferior-thread-changes?
- (set-interrupt-enables! interrupt-mask)
- event:inferior-thread-output)
- ((process-output-available?)
- (set-interrupt-enables! interrupt-mask)
- event:process-output)
- ((process-status-changes?)
- (set-interrupt-enables! interrupt-mask)
- event:process-status)
- (else
- (let ((flag
- ;; Note that this procedure no longer unblocks
- ;; for subprocess status changes!!!
- (test-for-io-on-descriptor event-descriptor
- block?
- 'READ)))
- (set-interrupt-enables! interrupt-mask)
- (case flag
- ((#F) #f)
- ((PROCESS-STATUS-CHANGE) event:process-status)
- ((INTERRUPT) (loop))
- (else (read-event-1 block?))))))))))
-
-(define-integrable event:process-output -2)
-(define-integrable event:process-status -3)
-(define-integrable event:inferior-thread-output -4)
-\f
-(define (preview-event-stream)
- (set! previewer-registration
- (permanently-register-io-thread-event
- event-descriptor
- 'READ
- (current-thread)
- (lambda (mode)
- mode
- (if (not reading-event?)
- (let ((event (os2win-get-event event-descriptor #f)))
- (if event
- (preview-event event)))))))
- unspecific)
-
-(define (preview-event event)
- (cond ((not (vector? event))
- (enqueue!/unsafe event-queue event))
- ((and signal-interrupts?
- (fix:= event-type:key (event-type event))
- ;; This tests for CTRL on, ALT off, and
- ;; not a virtual key:
- (fix:= #x10 (fix:and #x32 (key-event/flags event)))
- (let ((code (key-event/code event)))
- (or (fix:= code (char->integer #\G))
- (fix:= code (char->integer #\g)))))
- (clean-event-queue event-queue)
- (signal-interrupt!))
- ((fix:= (event-type event) event-type:visibility)
- (let ((result (process-special-event event)))
- (if result
- (enqueue!/unsafe event-queue result))))
- ((fix:= (event-type event) event-type:paint)
- (process-paint-event event))
- (else
- (enqueue!/unsafe event-queue event))))
-
-(define (clean-event-queue queue)
- ;; Flush keyboard and mouse events from the input queue. Other
- ;; events are harmless and must be processed regardless.
- (do ((events (let loop ()
- (if (queue-empty? queue)
- '()
- (let ((event (dequeue!/unsafe queue)))
- (if (and (vector? event)
- (let ((type (event-type event)))
- (or (fix:= type event-type:button)
- (fix:= type event-type:key))))
- (loop)
- (cons event (loop))))))
- (cdr events)))
- ((null? events))
- (enqueue!/unsafe queue (car events))))
-
-(define (signal-interrupt!)
- (editor-beep)
- (temporary-message "Quit")
- (^G-signal))
-
-(define (translate-key-event event)
- (let ((code (key-event/code event))
- (flags (key-event/flags event)))
- (let ((bits (flags->bucky-bits flags)))
- (let ((process-code
- (lambda (code)
- (if (and (fix:<= #x40 code) (fix:< code #x60)
- (fix:= (fix:and bits char-bit:control)
- char-bit:control))
- (make-char (fix:and code #x1F)
- (fix:andc bits char-bit:control))
- (make-char code bits)))))
- (if (fix:= 0 (fix:and flags KC_VIRTUALKEY))
- (and (fix:< code #x80)
- (process-code code))
- (let ((key
- (and (fix:< code (vector-length virtual-key-table))
- (vector-ref virtual-key-table code))))
- (and key
- (if (fix:fixnum? key)
- (process-code key)
- (make-special-key key bits)))))))))
-\f
-(define (process-change-event event)
- (cond ((fix:= event event:process-output) (accept-process-output))
- ((fix:= event event:process-status) (handle-process-status-changes))
- ((fix:= event event:inferior-thread-output) (accept-thread-output))
- (else (error "Illegal change event:" event))))
-
-(define (process-paint-event event)
- (let ((wid (event-wid event))
- (xl (paint-event/xl event))
- (xh (paint-event/xh event))
- (yl (paint-event/yl event))
- (yh (paint-event/yh event)))
- (os2ps-clear (os2win-ps wid) xl xh yl yh)
- (let ((screen (wid->screen wid)))
- (if screen
- (let ((cxl (xl->cxl screen xl))
- (cxh (xh->cxh screen xh))
- (cyl (yh->cyl screen yh))
- (cyh (yl->cyh screen yl))
- (char-map (screen-char-map screen))
- (face-map (screen-face-map screen))
- (x-size (screen-x-size screen))
- (char-height (screen-char-height screen)))
- (if (fix:< cxl cxh)
- (let ((size (fix:- cxh cxl)))
- (do ((cy cyl (fix:+ cy 1))
- (y (fix:+ (cy->y screen cyl)
- (screen-char-descender screen))
- (fix:- y char-height))
- (start (screen-char-index screen cxl cyl)
- (fix:+ start x-size)))
- ((fix:= cy cyh))
- (let ((end (fix:+ start size)))
- (let outer ((start start) (cxl cxl))
- (let ((face (vector-ref face-map start)))
- (let inner ((index (fix:+ start 1)))
- (if (or (fix:= index end)
- (not (eq? face
- (vector-ref face-map index))))
- (begin
- (set-screen-face! screen face)
- (os2ps-write (os2win-ps wid)
- (cx->x screen cxl) y
- char-map start end)
- (if (not (fix:= index end))
- (outer index
- (fix:+ cxl (fix:- index start)))))
- (inner (fix:+ index 1)))))))))))))))
-
-(define (process-special-event event)
- (let ((handler
- (let ((type (event-type event)))
- (and (fix:fixnum? type)
- (fix:>= type 0)
- (fix:< type (vector-length event-handlers))
- (vector-ref event-handlers type))))
- (screen (wid->screen (event-wid event))))
- (and handler
- screen
- (handler screen event))))
-
-(define event-handlers
- (make-vector number-of-event-types #f))
-\f
-(define (define-event-handler event-type handler)
- (vector-set! event-handlers event-type handler))
-
-(define-event-handler event-type:button
- (lambda (screen event)
- (and (eq? button-event-type:down (button-event/type event))
- (if (os2win-focus? (screen-wid screen))
- (make-input-event
- 'BUTTON
- execute-button-command
- screen
- (make-down-button (button-event/number event)
- (flags->bucky-bits (button-event/flags event)))
- (x->cx screen (button-event/x event))
- (y->cy screen (button-event/y event)))
- (begin
- (os2win-activate (screen-wid screen))
- #f)))))
-
-(define-event-handler event-type:close
- (lambda (screen event)
- event
- (and (not (screen-deleted? screen))
- (make-input-event 'DELETE-SCREEN delete-screen! screen))))
-
-(define-event-handler event-type:focus
- (lambda (screen event)
- (and (focus-event/gained? event)
- (not (selected-screen? screen))
- (make-input-event 'SELECT-SCREEN select-screen screen))))
-
-(define-event-handler event-type:resize
- (lambda (screen event)
- (set-screen-pel-width! screen (resize-event/width event))
- (set-screen-pel-height! screen (resize-event/height event))
- (let ((thunk (screen-resize-thunk screen)))
- (and thunk
- (make-input-event 'SET-SCREEN-SIZE
- (lambda (screen)
- (thunk)
- (update-screen! screen #t))
- screen)))))
-
-(define (screen-resize-thunk screen)
- (let ((width (screen-pel-width screen))
- (height (screen-pel-height screen)))
- (let ((x-size (width->x-size screen width))
- (y-size (height->y-size screen height)))
- (and (not (and (= x-size (screen-x-size screen))
- (= y-size (screen-y-size screen))))
- (lambda ()
- (let ((size (fix:* x-size y-size)))
- (let ((char-map (make-string size #\space))
- (face-map
- (make-vector size (screen-current-face screen))))
- (without-interrupts
- (lambda ()
- (set-screen-char-map! screen char-map)
- (set-screen-face-map! screen face-map)
- (set-screen-size! screen x-size y-size))))))))))
-
-(define-event-handler event-type:visibility
- (lambda (screen event)
- (and (not (screen-deleted? screen))
- (if (visibility-event/shown? event)
- (begin
- (set-screen-visibility! screen 'VISIBLE) ;don't really know
- (screen-force-update screen)
- (make-input-event 'UPDATE update-screen! screen #f))
- (begin
- (set-screen-visibility! screen 'UNMAPPED)
- (and (selected-screen? screen)
- (let ((screen (other-screen screen)))
- (and screen
- (make-input-event 'SELECT-SCREEN
- select-screen
- screen)))))))))
-\f
-(define (make-virtual-key-table)
- ;; Shift keys are commented out, causing them to be ignored.
- (let ((table (make-vector virtual-key-supremum #f)))
- (vector-set! table VK_BUTTON1 'BUTTON1)
- (vector-set! table VK_BUTTON2 'BUTTON2)
- (vector-set! table VK_BUTTON3 'BUTTON3)
- (vector-set! table VK_BREAK 'BREAK)
- (vector-set! table VK_BACKSPACE (char-code #\rubout))
- (vector-set! table VK_TAB (char-code #\tab))
- (vector-set! table VK_BACKTAB 'BACKTAB)
- (vector-set! table VK_NEWLINE (char-code #\return))
- ;;(vector-set! table VK_SHIFT 'SHIFT)
- ;;(vector-set! table VK_CTRL 'CTRL)
- ;;(vector-set! table VK_ALT 'ALT)
- ;;(vector-set! table VK_ALTGRAF 'ALTGRAF)
- (vector-set! table VK_PAUSE 'PAUSE)
- ;;(vector-set! table VK_CAPSLOCK 'CAPS-LOCK)
- (vector-set! table VK_ESC (char-code #\escape))
- (vector-set! table VK_SPACE (char-code #\space))
- (vector-set! table VK_PAGEUP 'PAGE-UP)
- (vector-set! table VK_PAGEDOWN 'PAGE-DOWN)
- (vector-set! table VK_END 'END)
- (vector-set! table VK_HOME 'HOME)
- (vector-set! table VK_LEFT 'LEFT)
- (vector-set! table VK_UP 'UP)
- (vector-set! table VK_RIGHT 'RIGHT)
- (vector-set! table VK_DOWN 'DOWN)
- (vector-set! table VK_PRINTSCRN 'PRINT-SCREEN)
- (vector-set! table VK_INSERT 'INSERT)
- (vector-set! table VK_DELETE 'DELETE)
- ;;(vector-set! table VK_SCRLLOCK 'SCRL-LOCK)
- ;;(vector-set! table VK_NUMLOCK 'NUM-LOCK)
- (vector-set! table VK_ENTER (char-code #\return))
- (vector-set! table VK_SYSRQ 'SYSRQ)
- (vector-set! table VK_F1 'F1)
- (vector-set! table VK_F2 'F2)
- (vector-set! table VK_F3 'F3)
- (vector-set! table VK_F4 'F4)
- (vector-set! table VK_F5 'F5)
- (vector-set! table VK_F6 'F6)
- (vector-set! table VK_F7 'F7)
- (vector-set! table VK_F8 'F8)
- (vector-set! table VK_F9 'F9)
- (vector-set! table VK_F10 'F10)
- (vector-set! table VK_F11 'F11)
- (vector-set! table VK_F12 'F12)
- (vector-set! table VK_F13 'F13)
- (vector-set! table VK_F14 'F14)
- (vector-set! table VK_F15 'F15)
- (vector-set! table VK_F16 'F16)
- (vector-set! table VK_F17 'F17)
- (vector-set! table VK_F18 'F18)
- (vector-set! table VK_F19 'F19)
- (vector-set! table VK_F20 'F20)
- (vector-set! table VK_F21 'F21)
- (vector-set! table VK_F22 'F22)
- (vector-set! table VK_F23 'F23)
- (vector-set! table VK_F24 'F24)
- (vector-set! table VK_ENDDRAG 'END-DRAG)
- (vector-set! table VK_CLEAR 'CLEAR)
- (vector-set! table VK_EREOF 'EREOF)
- (vector-set! table VK_PA1 'PA1)
- table))
-
-(define (flags->bucky-bits flags)
- (fix:or (if (fix:= 0 (fix:and flags KC_CTRL)) #x2 #x0)
- (if (fix:= 0 (fix:and flags KC_ALT)) #x1 #x0)))
\ No newline at end of file
rm-pkg)
maybe_rm *-unx.crf *-unx.fre *-unx.pkd
maybe_rm *-w32.crf *-w32.fre *-w32.pkd
- maybe_rm *-os2.crf *-os2.fre *-os2.pkd
;;
rm-c)
maybe_rm *.c
(lambda (os)
(cbf-conditionally (string-append root "-" os ".pkd")))))
(compile-pkg "unx")
- (compile-pkg "w32")
- (compile-pkg "os2"))))))
+ (compile-pkg "w32"))))))
(define (cbf-conditionally pathname)
(let ((input (pathname-default-type pathname "bin")))
(map (lambda (os-suffix)
(string-append pkg-name "-" os-suffix))
;; XXX Need them all to process other package descriptions.
- '("os2" "unx" "w32"))
+ '("unx" "w32"))
(sort (let ((names
(map ->namestring
(cref/package-files
# define HOOK_ENTER_INTERPRETER win32_enter_interpreter
#endif
-#ifdef __OS2__
- extern void OS2_initialize_early (void);
- extern void OS2_enter_interpreter (void (*) (void));
-# define HOOK_ENTER_INTERPRETER OS2_enter_interpreter
-#endif
-
#ifndef HOOK_ENTER_INTERPRETER
# define HOOK_ENTER_INTERPRETER(func) func ()
#endif
#endif
#ifdef PREALLOCATE_HEAP_MEMORY
PREALLOCATE_HEAP_MEMORY ();
-#endif
-#ifdef __OS2__
- OS2_initialize_early ();
#endif
obstack_init (&scratch_obstack);
obstack_init (&ffi_obstack);
ia32_cache_synchronize (); \
} while (false)
\f
-#if defined(__OS2__) && (defined(__IBMC__) || defined(__WATCOMC__))
+#if defined(__IBMC__) || defined(__WATCOMC__)
# define ASM_ENTRY_POINT(name) (_System name)
#elif defined(__WIN32__) && defined(__WATCOMC__)
# define ASM_ENTRY_POINT(name) (__cdecl name)
#endif /* __alpha */
\f
-#ifdef __OS2__
-
-#define PREALLOCATE_HEAP_MEMORY() \
-{ \
- extern void OS2_alloc_heap (void); \
- OS2_alloc_heap (); \
-}
-
-extern void * OS2_commit_heap (unsigned long);
-#define HEAP_MALLOC OS2_commit_heap
-#define HEAP_FREE(address)
-
-#define EXIT_SCHEME_DECLARATIONS extern void OS2_exit_scheme (int)
-#define EXIT_SCHEME OS2_exit_scheme
-
-extern void OS2_stack_reset (void);
-#define STACK_RESET OS2_stack_reset
-
-extern int OS2_stack_overflowed_p (void);
-#define STACK_OVERFLOWED_P OS2_stack_overflowed_p
-
-#define CC_ARCH_INITIALIZE i386_interface_initialize
-
-#endif /* __OS2__ */
-
#ifdef __WIN32__
extern void win32_stack_reset (void);
RELEASE_INTERRUPT_REGISTERS (); \
} while (0)
-#if defined(__OS2__) || defined(__WIN32__)
+#if defined(__WIN32__)
extern void OS_grab_interrupt_registers (void);
extern void OS_release_interrupt_registers (void);
# define GRAB_INTERRUPT_REGISTERS() OS_grab_interrupt_registers ()
'()))))
specs)))
-(define os-pkd-suffixes '("unx" "w32" "os2"))
+(define os-pkd-suffixes '("unx" "w32"))
(define (package-description-files descriptor)
(receive (filename suffixes)
# include "ntio.h"
#endif
-#if defined(__WIN32__) || defined(__OS2__)
+#if defined(__WIN32__)
# define DOS_LIKE_FILENAMES
#endif
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#include "os2.h"
-\f
-/* Define OS2_USE_SUBHEAP_MALLOC to use this custom malloc
- implementation for most of Scheme's memory. This implementation,
- by virtue of being separate from the system's malloc, and also by
- having specific redundancy checks, offers some features that can be
- valuable during debugging of memory problems. */
-
-/* #define OS2_USE_SUBHEAP_MALLOC */
-#ifdef OS2_USE_SUBHEAP_MALLOC
-
-static PVOID malloc_object;
-static ULONG malloc_object_size = 0x200000; /* two megabytes */
-
-typedef struct
-{
- char * check;
- unsigned int size;
-} malloc_header_t;
-
-void
-OS2_initialize_malloc (void)
-{
- if (((DosAllocMem ((&malloc_object),
- malloc_object_size,
- (PAG_EXECUTE | PAG_READ | PAG_WRITE)))
- != NO_ERROR)
- || ((DosSubSetMem (malloc_object,
- (DOSSUB_INIT | DOSSUB_SPARSE_OBJ | DOSSUB_SERIALIZE),
- malloc_object_size))
- != NO_ERROR))
- termination_init_error ();
-}
-
-static malloc_header_t *
-guarantee_valid_malloc_pointer (void * ptr)
-{
- malloc_header_t * header = (((malloc_header_t *) ptr) - 1);
- if ((((char *) header) < ((char *) malloc_object))
- || (((char *) header) > (((char *) malloc_object) + malloc_object_size))
- || ((((ULONG) header) & 7) != 0)
- || ((header -> check) != (((char *) header) - 47)))
- OS2_logic_error ("Bad pointer passed to OS_free.");
- return (header);
-}
-
-void *
-OS2_malloc_noerror (unsigned long size)
-{
- PVOID result;
- APIRET rc
- = (DosSubAllocMem (malloc_object,
- (&result),
- (size + (sizeof (malloc_header_t)))));
- if (rc == ERROR_DOSSUB_NOMEM)
- return (0);
- if (rc != NO_ERROR)
- {
- char buffer [1024];
- sprintf (buffer, "DosSubAllocMem error: %d.", rc);
- OS2_logic_error (buffer);
- }
- (((malloc_header_t *) result) -> check) = (((char *) result) - 47);
- (((malloc_header_t *) result) -> size) = size;
- return (((malloc_header_t *) result) + 1);
-}
-
-void
-OS_free (void * ptr)
-{
- malloc_header_t * header = (guarantee_valid_malloc_pointer (ptr));
- APIRET rc;
- (header -> check) = 0;
- rc = (DosSubFreeMem (malloc_object, header, (header -> size)));
- if (rc != NO_ERROR)
- {
- char buffer [1024];
- sprintf (buffer, "DosSubFreeMem error: %d.", rc);
- OS2_logic_error (buffer);
- }
-}
-
-void *
-OS2_realloc_noerror (void * ptr, unsigned long size)
-{
- unsigned long osize = ((guarantee_valid_malloc_pointer (ptr)) -> size);
- if (osize == size)
- return (ptr);
- {
- void * result = (OS2_malloc_noerror (size));
- if (result != 0)
- {
- char * scan1 = ptr;
- char * end1 = (scan1 + ((osize < size) ? osize : size));
- char * scan2 = result;
- while (scan1 < end1)
- (*scan2++) = (*scan1++);
- OS_free (ptr);
- }
- return (result);
- }
-}
-
-#else /* not OS2_USE_SUBHEAP_MALLOC */
-
-/* Use malloc. */
-
-void
-OS2_initialize_malloc (void)
-{
-}
-
-void *
-OS2_malloc_noerror (unsigned long size)
-{
- return (malloc (size));
-}
-
-void *
-OS2_realloc_noerror (void * ptr, unsigned long size)
-{
- return (realloc (ptr, size));
-}
-
-void
-OS_free (void * ptr)
-{
- free (ptr);
-}
-
-#endif /* not OS2_USE_SUBHEAP_MALLOC */
-
-void *
-OS_malloc_init (size_t size)
-{
- return (OS2_malloc_noerror (size));
-}
-
-void *
-OS_malloc (size_t size)
-{
- void * result = (OS2_malloc_noerror (size));
- if (result == 0)
- OS2_error_system_call (ERROR_NOT_ENOUGH_MEMORY, syscall_malloc);
- return (result);
-}
-
-void *
-OS_realloc (void * ptr, size_t size)
-{
- void * result = (OS2_realloc_noerror (ptr, size));
- if (result == 0)
- OS2_error_system_call (ERROR_NOT_ENOUGH_MEMORY, syscall_realloc);
- return (result);
-}
-\f
-HMTX
-OS2_create_mutex_semaphore (PSZ name, int sharedp)
-{
- HMTX result;
- STD_API_CALL
- (dos_create_mutex_sem,
- (name, (&result), (sharedp ? DC_SEM_SHARED : 0), 0));
- return (result);
-}
-
-void
-OS2_close_mutex_semaphore (HMTX s)
-{
- STD_API_CALL (dos_close_mutex_sem, (s));
-}
-
-void
-OS2_request_mutex_semaphore (HMTX s)
-{
- while (1)
- {
- APIRET rc = (dos_request_mutex_sem (s, SEM_INDEFINITE_WAIT));
- if (rc == NO_ERROR)
- break;
- /* This return code has been regularly occurring on my machine.
- On one occurrence, I proceeded past the error in the
- debugger, and the program continued working without errors.
- However, more recently proceeding past this error has caused
- a subsequent error when unlocking the semaphore because the
- lock didn't succeed. IBM tech support is mystified because
- this code appears nowhere in their sources. */
- if (rc == 3000)
- {
- PID pid;
- TID tid;
- ULONG count;
- DosQueryMutexSem (s, (&pid), (&tid), (&count));
- if ((count > 0) && (tid == (OS2_current_tid ())))
- break;
- }
- else if (rc != ERROR_INTERRUPT)
- OS2_error_system_call (rc, syscall_dos_request_mutex_sem);
- }
-}
-
-void
-OS2_release_mutex_semaphore (HMTX s)
-{
- STD_API_CALL (dos_release_mutex_sem, (s));
-}
-
-HEV
-OS2_create_event_semaphore (PSZ name, int sharedp)
-{
- HEV result;
- STD_API_CALL
- (dos_create_event_sem,
- (name, (&result), (sharedp ? DC_SEM_SHARED : 0), 0));
- return (result);
-}
-
-void
-OS2_close_event_semaphore (HEV s)
-{
- STD_API_CALL (dos_close_event_sem, (s));
-}
-
-int
-OS2_post_event_semaphore (HEV s)
-{
- XTD_API_CALL
- (dos_post_event_sem, (s),
- {
- if (rc == ERROR_ALREADY_POSTED)
- return (1);
- });
- return (0);
-}
-
-ULONG
-OS2_reset_event_semaphore (HEV s)
-{
- ULONG post_count;
- XTD_API_CALL
- (dos_reset_event_sem, (s, (&post_count)),
- {
- if (rc == ERROR_ALREADY_RESET)
- return (0);
- });
- return (post_count);
-}
-
-int
-OS2_wait_event_semaphore (HEV s, int blockp)
-{
- XTD_API_CALL
- (dos_wait_event_sem,
- (s, (blockp ? SEM_INDEFINITE_WAIT : SEM_IMMEDIATE_RETURN)),
- {
- if ((rc == ERROR_TIMEOUT) && (!blockp))
- return (0);
- });
- return (1);
-}
-\f
-HMTX OS2_create_queue_lock;
-
-HQUEUE
-OS2_create_queue (ULONG priority)
-{
- static unsigned int n = 0;
- unsigned int this_n;
- char buffer [64];
- HQUEUE result;
- OS2_request_mutex_semaphore (OS2_create_queue_lock);
- this_n = (n++);
- OS2_release_mutex_semaphore (OS2_create_queue_lock);
- sprintf (buffer, "\\queues\\scm%d\\%d.que", OS2_scheme_pid, this_n);
- STD_API_CALL (dos_create_queue, ((&result), priority, buffer));
- return (result);
-}
-
-void
-OS2_close_queue (HQUEUE q)
-{
- STD_API_CALL (dos_close_queue, (q));
-}
-
-void
-OS2_write_queue (HQUEUE q, ULONG type, ULONG length, PVOID data, ULONG priority)
-{
- STD_API_CALL (dos_write_queue, (q, type, length, data, priority));
-}
-
-int
-OS2_read_queue (HQUEUE q, ULONG * type, ULONG * length, PVOID * data, HEV s)
-{
- REQUESTDATA request;
- BYTE priority;
- (request.pid) = OS2_scheme_pid;
- if (s != NULLHANDLE)
- (void) OS2_reset_event_semaphore (s);
- XTD_API_CALL
- (dos_read_queue,
- (q, (&request), length, data, 0,
- ((s == NULLHANDLE) ? DCWW_WAIT : DCWW_NOWAIT), (&priority), s),
- {
- if ((rc == ERROR_QUE_EMPTY) && (s != NULLHANDLE))
- return (0);
- });
- (*type) = (request.ulData);
- return (1);
-}
-
-ULONG
-OS2_system_variable (ULONG index)
-{
- ULONG result;
- STD_API_CALL
- (dos_query_sys_info, (index, index, (&result), (sizeof (result))));
- return (result);
-}
-\f
-int
-OS2_essential_thread_p (TID tid)
-{
- extern TID OS2_pm_tid;
- extern TID OS2_timer_tid;
- extern TID OS2_console_tid;
- return ((tid == OS2_scheme_tid)
- || (tid == OS2_pm_tid)
- || (tid == OS2_timer_tid)
- || (tid == OS2_console_tid));
-}
-
-void
-OS2_logic_error_1 (const char * description,
- const char * file,
- unsigned int line)
-{
- extern TID OS2_child_wait_tid;
- char * format = "%s error in thread %d, file \"%s\", line %d: %s%s\
- This indicates a bug in the Scheme implementation.\
- Please report this information to a Scheme wizard.";
- TID tid = (OS2_current_tid ());
- if (OS2_essential_thread_p (tid))
- {
- outf_fatal (format, "Fatal", tid, file, line, description, "");
- outf_fatal ("\n\n");
- termination_init_error ();
- }
- else
- {
- extern void OS2_message_box (const char *, const char *, int);
- char buffer [1024];
- sprintf (buffer, format, "Non-fatal", tid, file, line, description,
- ((tid == OS2_child_wait_tid)
- ? " The thread will be killed.\
- Afterwards, Scheme will not be able to manage subprocesses properly."
- : " The thread will be killed."));
- OS2_message_box ("Scheme Error", buffer, 0);
- OS2_endthread ();
- }
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* OS/2 system include file */
-
-#ifndef SCM_OS2_H
-#define SCM_OS2_H
-
-#include "config.h"
-#include "dstack.h"
-#include "osscheme.h"
-#include "syscall.h"
-
-#define INCL_BASE
-#define INCL_PM
-#include <os2.h>
-#include <setjmp.h>
-
-#include "os2api.h"
-#include "os2msg.h"
-#include "os2io.h"
-#include "os2thrd.h"
-#include "os2ctty.h"
-#include "os2cthrd.h"
-#include "os2pm.h"
-
-#define FILE_ANY \
- (FILE_NORMAL | FILE_HIDDEN | FILE_SYSTEM | FILE_DIRECTORY | FILE_ARCHIVED)
-
-extern HMTX OS2_create_mutex_semaphore (PSZ, int);
-extern void OS2_close_mutex_semaphore (HMTX);
-extern void OS2_request_mutex_semaphore (HMTX);
-extern void OS2_release_mutex_semaphore (HMTX);
-
-extern HEV OS2_create_event_semaphore (PSZ, int);
-extern void OS2_close_event_semaphore (HEV);
-extern int OS2_post_event_semaphore (HEV);
-extern ULONG OS2_reset_event_semaphore (HEV);
-extern int OS2_wait_event_semaphore (HEV, int);
-
-extern HQUEUE OS2_create_queue (ULONG);
-extern void OS2_close_queue (HQUEUE);
-extern void OS2_write_queue (HQUEUE, ULONG, ULONG, PVOID, ULONG);
-extern int OS2_read_queue (HQUEUE, ULONG *, ULONG *, PVOID *, HEV);
-
-extern ULONG OS2_system_variable (ULONG);
-
-/* Logic errors are fatal and can't be caught. These are errors that
- should never happen, and if one does occur the program cannot
- proceed. */
-#define OS2_logic_error(d) OS2_logic_error_1 ((d), __FILE__, __LINE__)
-extern void OS2_logic_error_1 (const char *, const char *, unsigned int);
-
-#endif /* SCM_OS2_H */
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* This flag, defined by "syscall.h", means to define the syscall
- enums normally defined by that file. */
-#ifdef DEFINE_OS2_SYSCALLS
-
-enum syscall_names
-{
- syscall_dos_alloc_mem,
- syscall_dos_alloc_shared_mem,
- syscall_dos_async_timer,
- syscall_dos_close,
- syscall_dos_close_event_sem,
- syscall_dos_close_mutex_sem,
- syscall_dos_close_queue,
- syscall_dos_copy,
- syscall_dos_create_dir,
- syscall_dos_create_event_sem,
- syscall_dos_create_mutex_sem,
- syscall_dos_create_pipe,
- syscall_dos_create_queue,
- syscall_dos_create_thread,
- syscall_dos_delete,
- syscall_dos_delete_dir,
- syscall_dos_dup_handle,
- syscall_dos_exec_pgm,
- syscall_dos_exit,
- syscall_dos_find_close,
- syscall_dos_find_first,
- syscall_dos_find_next,
- syscall_dos_free_mem,
- syscall_dos_get_info_blocks,
- syscall_dos_get_message,
- syscall_dos_get_named_shared_mem,
- syscall_dos_get_shared_mem,
- syscall_dos_give_shared_mem,
- syscall_dos_kill_process,
- syscall_dos_kill_thread,
- syscall_dos_move,
- syscall_dos_open,
- syscall_dos_post_event_sem,
- syscall_dos_query_current_dir,
- syscall_dos_query_current_disk,
- syscall_dos_query_fh_state,
- syscall_dos_query_file_info,
- syscall_dos_query_fs_attach,
- syscall_dos_query_fs_info,
- syscall_dos_query_h_type,
- syscall_dos_query_mem,
- syscall_dos_query_n_p_h_state,
- syscall_dos_query_path_info,
- syscall_dos_query_sys_info,
- syscall_dos_read,
- syscall_dos_read_queue,
- syscall_dos_release_mutex_sem,
- syscall_dos_request_mutex_sem,
- syscall_dos_reset_event_sem,
- syscall_dos_scan_env,
- syscall_dos_send_signal_exception,
- syscall_dos_set_current_dir,
- syscall_dos_set_default_disk,
- syscall_dos_set_fh_state,
- syscall_dos_set_file_ptr,
- syscall_dos_set_file_size,
- syscall_dos_set_max_fh,
- syscall_dos_set_mem,
- syscall_dos_set_path_info,
- syscall_dos_set_rel_max_fh,
- syscall_dos_start_timer,
- syscall_dos_stop_timer,
- syscall_dos_wait_child,
- syscall_dos_wait_event_sem,
- syscall_dos_write,
- syscall_dos_write_queue,
- syscall_beginthread,
- syscall_gmtime,
- syscall_kbd_char_in,
- syscall_localtime,
- syscall_malloc,
- syscall_mktime,
- syscall_realloc,
- syscall_time,
- syscall_vio_wrt_tty,
-
- /* Socket calls: */
- syscall_accept,
- syscall_bind,
- syscall_connect,
- syscall_gethostbyname,
- syscall_gethostname,
- syscall_listen,
- syscall_recv,
- syscall_send,
- syscall_socket,
- syscall_soclose
-};
-
-/* Machine-generated table, do not edit: */
-enum syserr_names
-{
- syserr_invalid_function,
- syserr_file_not_found,
- syserr_path_not_found,
- syserr_too_many_open_files,
- syserr_access_denied,
- syserr_invalid_handle,
- syserr_arena_trashed,
- syserr_not_enough_memory,
- syserr_invalid_block,
- syserr_bad_environment,
- syserr_bad_format,
- syserr_invalid_access,
- syserr_invalid_data,
- syserr_invalid_drive,
- syserr_current_directory,
- syserr_not_same_device,
- syserr_no_more_files,
- syserr_write_protect,
- syserr_bad_unit,
- syserr_not_ready,
- syserr_bad_command,
- syserr_crc,
- syserr_bad_length,
- syserr_seek,
- syserr_not_dos_disk,
- syserr_sector_not_found,
- syserr_out_of_paper,
- syserr_write_fault,
- syserr_read_fault,
- syserr_gen_failure,
- syserr_sharing_violation,
- syserr_lock_violation,
- syserr_wrong_disk,
- syserr_fcb_unavailable,
- syserr_sharing_buffer_exceeded,
- syserr_code_page_mismatched,
- syserr_handle_eof,
- syserr_handle_disk_full,
- syserr_not_supported,
- syserr_rem_not_list,
- syserr_dup_name,
- syserr_bad_netpath,
- syserr_network_busy,
- syserr_dev_not_exist,
- syserr_too_many_cmds,
- syserr_adap_hdw_err,
- syserr_bad_net_resp,
- syserr_unexp_net_err,
- syserr_bad_rem_adap,
- syserr_printq_full,
- syserr_no_spool_space,
- syserr_print_cancelled,
- syserr_netname_deleted,
- syserr_network_access_denied,
- syserr_bad_dev_type,
- syserr_bad_net_name,
- syserr_too_many_names,
- syserr_too_many_sess,
- syserr_sharing_paused,
- syserr_req_not_accep,
- syserr_redir_paused,
- syserr_sbcs_att_write_prot,
- syserr_sbcs_general_failure,
- syserr_xga_out_memory,
- syserr_file_exists,
- syserr_dup_fcb,
- syserr_cannot_make,
- syserr_fail_i24,
- syserr_out_of_structures,
- syserr_already_assigned,
- syserr_invalid_password,
- syserr_invalid_parameter,
- syserr_net_write_fault,
- syserr_no_proc_slots,
- syserr_not_frozen,
- syserr_tstovfl,
- syserr_tstdup,
- syserr_no_items,
- syserr_interrupt,
- syserr_device_in_use,
- syserr_too_many_semaphores,
- syserr_excl_sem_already_owned,
- syserr_sem_is_set,
- syserr_too_many_sem_requests,
- syserr_invalid_at_interrupt_time,
- syserr_sem_owner_died,
- syserr_sem_user_limit,
- syserr_disk_change,
- syserr_drive_locked,
- syserr_broken_pipe,
- syserr_open_failed,
- syserr_buffer_overflow,
- syserr_disk_full,
- syserr_no_more_search_handles,
- syserr_invalid_target_handle,
- syserr_protection_violation,
- syserr_viokbd_request,
- syserr_invalid_category,
- syserr_invalid_verify_switch,
- syserr_bad_driver_level,
- syserr_call_not_implemented,
- syserr_sem_timeout,
- syserr_insufficient_buffer,
- syserr_invalid_name,
- syserr_invalid_level,
- syserr_no_volume_label,
- syserr_mod_not_found,
- syserr_proc_not_found,
- syserr_wait_no_children,
- syserr_child_not_complete,
- syserr_direct_access_handle,
- syserr_negative_seek,
- syserr_seek_on_device,
- syserr_is_join_target,
- syserr_is_joined,
- syserr_is_substed,
- syserr_not_joined,
- syserr_not_substed,
- syserr_join_to_join,
- syserr_subst_to_subst,
- syserr_join_to_subst,
- syserr_subst_to_join,
- syserr_busy_drive,
- syserr_same_drive,
- syserr_dir_not_root,
- syserr_dir_not_empty,
- syserr_is_subst_path,
- syserr_is_join_path,
- syserr_path_busy,
- syserr_is_subst_target,
- syserr_system_trace,
- syserr_invalid_event_count,
- syserr_too_many_muxwaiters,
- syserr_invalid_list_format,
- syserr_label_too_long,
- syserr_too_many_tcbs,
- syserr_signal_refused,
- syserr_discarded,
- syserr_not_locked,
- syserr_bad_threadid_addr,
- syserr_bad_arguments,
- syserr_bad_pathname,
- syserr_signal_pending,
- syserr_uncertain_media,
- syserr_max_thrds_reached,
- syserr_monitors_not_supported,
- syserr_unc_driver_not_installed,
- syserr_lock_failed,
- syserr_swapio_failed,
- syserr_swapin_failed,
- syserr_busy,
- syserr_cancel_violation,
- syserr_atomic_lock_not_supported,
- syserr_read_locks_not_supported,
- syserr_invalid_segment_number,
- syserr_invalid_callgate,
- syserr_invalid_ordinal,
- syserr_already_exists,
- syserr_no_child_process,
- syserr_child_alive_nowait,
- syserr_invalid_flag_number,
- syserr_sem_not_found,
- syserr_invalid_starting_codeseg,
- syserr_invalid_stackseg,
- syserr_invalid_moduletype,
- syserr_invalid_exe_signature,
- syserr_exe_marked_invalid,
- syserr_bad_exe_format,
- syserr_iterated_data_exceeds_64k,
- syserr_invalid_minallocsize,
- syserr_dynlink_from_invalid_ring,
- syserr_iopl_not_enabled,
- syserr_invalid_segdpl,
- syserr_autodataseg_exceeds_64k,
- syserr_ring2seg_must_be_movable,
- syserr_reloc_chain_xeeds_seglim,
- syserr_infloop_in_reloc_chain,
- syserr_envvar_not_found,
- syserr_not_current_ctry,
- syserr_no_signal_sent,
- syserr_filename_exced_range,
- syserr_ring2_stack_in_use,
- syserr_meta_expansion_too_long,
- syserr_invalid_signal_number,
- syserr_thread_1_inactive,
- syserr_info_not_avail,
- syserr_locked,
- syserr_bad_dynalink,
- syserr_too_many_modules,
- syserr_nesting_not_allowed,
- syserr_cannot_shrink,
- syserr_zombie_process,
- syserr_stack_in_high_memory,
- syserr_invalid_exitroutine_ring,
- syserr_getbuf_failed,
- syserr_flushbuf_failed,
- syserr_transfer_too_long,
- syserr_forcenoswap_failed,
- syserr_smg_no_target_window,
- syserr_no_children,
- syserr_invalid_screen_group,
- syserr_bad_pipe,
- syserr_pipe_busy,
- syserr_no_data,
- syserr_pipe_not_connected,
- syserr_more_data,
- syserr_vc_disconnected,
- syserr_circularity_requested,
- syserr_directory_in_cds,
- syserr_invalid_fsd_name,
- syserr_invalid_path,
- syserr_invalid_ea_name,
- syserr_ea_list_inconsistent,
- syserr_ea_list_too_long,
- syserr_no_meta_match,
- syserr_findnotify_timeout,
- syserr_no_more_items,
- syserr_search_struc_reused,
- syserr_char_not_found,
- syserr_too_much_stack,
- syserr_invalid_attr,
- syserr_invalid_starting_ring,
- syserr_invalid_dll_init_ring,
- syserr_cannot_copy,
- syserr_directory,
- syserr_oplocked_file,
- syserr_oplock_thread_exists,
- syserr_volume_changed,
- syserr_findnotify_handle_in_use,
- syserr_findnotify_handle_closed,
- syserr_notify_object_removed,
- syserr_already_shutdown,
- syserr_eas_didnt_fit,
- syserr_ea_file_corrupt,
- syserr_ea_table_full,
- syserr_invalid_ea_handle,
- syserr_no_cluster,
- syserr_create_ea_file,
- syserr_cannot_open_ea_file,
- syserr_eas_not_supported,
- syserr_need_eas_found,
- syserr_duplicate_handle,
- syserr_duplicate_name,
- syserr_empty_muxwait,
- syserr_mutex_owned,
- syserr_not_owner,
- syserr_param_too_small,
- syserr_too_many_handles,
- syserr_too_many_opens,
- syserr_wrong_type,
- syserr_unused_code,
- syserr_thread_not_terminated,
- syserr_init_routine_failed,
- syserr_module_in_use,
- syserr_not_enough_watchpoints,
- syserr_too_many_posts,
- syserr_already_posted,
- syserr_already_reset,
- syserr_sem_busy,
- syserr_invalid_procid,
- syserr_invalid_pdelta,
- syserr_not_descendant,
- syserr_not_session_manager,
- syserr_invalid_pclass,
- syserr_invalid_scope,
- syserr_invalid_threadid,
- syserr_dossub_shrink,
- syserr_dossub_nomem,
- syserr_dossub_overlap,
- syserr_dossub_badsize,
- syserr_dossub_badflag,
- syserr_dossub_badselector,
- syserr_mr_msg_too_long,
- syserr_mr_mid_not_found,
- syserr_mr_un_acc_msgf,
- syserr_mr_inv_msgf_format,
- syserr_mr_inv_ivcount,
- syserr_mr_un_perform,
- syserr_ts_wakeup,
- syserr_ts_semhandle,
- syserr_ts_notimer,
- syserr_ts_handle,
- syserr_ts_datetime,
- syserr_sys_internal,
- syserr_que_current_name,
- syserr_que_proc_not_owned,
- syserr_que_proc_owned,
- syserr_que_duplicate,
- syserr_que_element_not_exist,
- syserr_que_no_memory,
- syserr_que_invalid_name,
- syserr_que_invalid_priority,
- syserr_que_invalid_handle,
- syserr_que_link_not_found,
- syserr_que_memory_error,
- syserr_que_prev_at_end,
- syserr_que_proc_no_access,
- syserr_que_empty,
- syserr_que_name_not_exist,
- syserr_que_not_initialized,
- syserr_que_unable_to_access,
- syserr_que_unable_to_add,
- syserr_que_unable_to_init,
- syserr_vio_invalid_mask,
- syserr_vio_ptr,
- syserr_vio_aptr,
- syserr_vio_rptr,
- syserr_vio_cptr,
- syserr_vio_lptr,
- syserr_vio_mode,
- syserr_vio_width,
- syserr_vio_attr,
- syserr_vio_row,
- syserr_vio_col,
- syserr_vio_toprow,
- syserr_vio_botrow,
- syserr_vio_rightcol,
- syserr_vio_leftcol,
- syserr_scs_call,
- syserr_scs_value,
- syserr_vio_wait_flag,
- syserr_vio_unlock,
- syserr_sgs_not_session_mgr,
- syserr_smg_invalid_session_id,
- syserr_smg_no_sessions,
- syserr_smg_session_not_found,
- syserr_smg_set_title,
- syserr_kbd_parameter,
- syserr_kbd_no_device,
- syserr_kbd_invalid_iowait,
- syserr_kbd_invalid_length,
- syserr_kbd_invalid_echo_mask,
- syserr_kbd_invalid_input_mask,
- syserr_mon_invalid_parms,
- syserr_mon_invalid_devname,
- syserr_mon_invalid_handle,
- syserr_mon_buffer_too_small,
- syserr_mon_buffer_empty,
- syserr_mon_data_too_large,
- syserr_mouse_no_device,
- syserr_mouse_inv_handle,
- syserr_mouse_inv_parms,
- syserr_mouse_cant_reset,
- syserr_mouse_display_parms,
- syserr_mouse_inv_module,
- syserr_mouse_inv_entry_pt,
- syserr_mouse_inv_mask,
- syserr_mouse_no_data,
- syserr_mouse_ptr_drawn,
- syserr_invalid_frequency,
- syserr_nls_no_country_file,
- syserr_nls_open_failed,
- syserr_no_country_or_codepage,
- syserr_nls_table_truncated,
- syserr_nls_bad_type,
- syserr_nls_type_not_found,
- syserr_vio_smg_only,
- syserr_vio_invalid_asciiz,
- syserr_vio_deregister,
- syserr_vio_no_popup,
- syserr_vio_existing_popup,
- syserr_kbd_smg_only,
- syserr_kbd_invalid_asciiz,
- syserr_kbd_invalid_mask,
- syserr_kbd_register,
- syserr_kbd_deregister,
- syserr_mouse_smg_only,
- syserr_mouse_invalid_asciiz,
- syserr_mouse_invalid_mask,
- syserr_mouse_register,
- syserr_mouse_deregister,
- syserr_smg_bad_action,
- syserr_smg_invalid_call,
- syserr_scs_sg_notfound,
- syserr_scs_not_shell,
- syserr_vio_invalid_parms,
- syserr_vio_function_owned,
- syserr_vio_return,
- syserr_scs_invalid_function,
- syserr_scs_not_session_mgr,
- syserr_vio_register,
- syserr_vio_no_mode_thread,
- syserr_vio_no_save_restore_thd,
- syserr_vio_in_bg,
- syserr_vio_illegal_during_popup,
- syserr_smg_not_baseshell,
- syserr_smg_bad_statusreq,
- syserr_que_invalid_wait,
- syserr_vio_lock,
- syserr_mouse_invalid_iowait,
- syserr_vio_invalid_handle,
- syserr_vio_illegal_during_lock,
- syserr_vio_invalid_length,
- syserr_kbd_invalid_handle,
- syserr_kbd_no_more_handle,
- syserr_kbd_cannot_create_kcb,
- syserr_kbd_codepage_load_incompl,
- syserr_kbd_invalid_codepage_id,
- syserr_kbd_no_codepage_support,
- syserr_kbd_focus_required,
- syserr_kbd_focus_already_active,
- syserr_kbd_keyboard_busy,
- syserr_kbd_invalid_codepage,
- syserr_kbd_unable_to_focus,
- syserr_smg_session_non_select,
- syserr_smg_session_not_foregrnd,
- syserr_smg_session_not_parent,
- syserr_smg_invalid_start_mode,
- syserr_smg_invalid_related_opt,
- syserr_smg_invalid_bond_option,
- syserr_smg_invalid_select_opt,
- syserr_smg_start_in_background,
- syserr_smg_invalid_stop_option,
- syserr_smg_bad_reserve,
- syserr_smg_process_not_parent,
- syserr_smg_invalid_data_length,
- syserr_smg_not_bound,
- syserr_smg_retry_sub_alloc,
- syserr_kbd_detached,
- syserr_vio_detached,
- syserr_mou_detached,
- syserr_vio_font,
- syserr_vio_user_font,
- syserr_vio_bad_cp,
- syserr_vio_no_cp,
- syserr_vio_na_cp,
- syserr_invalid_code_page,
- syserr_cplist_too_small,
- syserr_cp_not_moved,
- syserr_mode_switch_init,
- syserr_code_page_not_found,
- syserr_unexpected_slot_returned,
- syserr_smg_invalid_trace_option,
- syserr_vio_internal_resource,
- syserr_vio_shell_init,
- syserr_smg_no_hard_errors,
- syserr_cp_switch_incomplete,
- syserr_vio_transparent_popup,
- syserr_critsec_overflow,
- syserr_critsec_underflow,
- syserr_vio_bad_reserve,
- syserr_invalid_address,
- syserr_zero_selectors_requested,
- syserr_not_enough_selectors_ava,
- syserr_invalid_selector,
- syserr_smg_invalid_program_type,
- syserr_smg_invalid_pgm_control,
- syserr_smg_invalid_inherit_opt,
- syserr_vio_extended_sg,
- syserr_vio_not_pres_mgr_sg,
- syserr_vio_shield_owned,
- syserr_vio_no_more_handles,
- syserr_vio_see_error_log,
- syserr_vio_associated_dc,
- syserr_kbd_no_console,
- syserr_mouse_no_console,
- syserr_mouse_invalid_handle,
- syserr_smg_invalid_debug_parms,
- syserr_kbd_extended_sg,
- syserr_mou_extended_sg,
- syserr_smg_invalid_icon_file,
- syserr_trc_pid_non_existent,
- syserr_trc_count_active,
- syserr_trc_suspended_by_count,
- syserr_trc_count_inactive,
- syserr_trc_count_reached,
- syserr_no_mc_trace,
- syserr_mc_trace,
- syserr_trc_count_zero,
- syserr_smg_too_many_dds,
- syserr_smg_invalid_notification,
- syserr_lf_invalid_function,
- syserr_lf_not_avail,
- syserr_lf_suspended,
- syserr_lf_buf_too_small,
- syserr_lf_buffer_full,
- syserr_lf_invalid_record,
- syserr_lf_invalid_service,
- syserr_lf_general_failure,
- syserr_lf_invalid_id,
- syserr_lf_invalid_handle,
- syserr_lf_no_id_avail,
- syserr_lf_template_area_full,
- syserr_lf_id_in_use,
- syserr_mou_not_initialized,
- syserr_mouinitreal_done,
- syserr_dossub_corrupted,
- syserr_mouse_caller_not_subsys,
- syserr_arithmetic_overflow,
- syserr_tmr_no_device,
- syserr_tmr_invalid_time,
- syserr_pvw_invalid_entity,
- syserr_pvw_invalid_entity_type,
- syserr_pvw_invalid_spec,
- syserr_pvw_invalid_range_type,
- syserr_pvw_invalid_counter_blk,
- syserr_pvw_invalid_text_blk,
- syserr_prf_not_initialized,
- syserr_prf_already_initialized,
- syserr_prf_not_started,
- syserr_prf_already_started,
- syserr_prf_timer_out_of_range,
- syserr_prf_timer_reset,
- syserr_vdd_lock_useage_denied,
- syserr_timeout,
- syserr_vdm_down,
- syserr_vdm_limit,
- syserr_vdd_not_found,
- syserr_invalid_caller,
- syserr_pid_mismatch,
- syserr_invalid_vdd_handle,
- syserr_vlpt_no_spooler,
- syserr_vcom_device_busy,
- syserr_vlpt_device_busy,
- syserr_nesting_too_deep,
- syserr_vdd_missing,
- syserr_bidi_invalid_length,
- syserr_bidi_invalid_increment,
- syserr_bidi_invalid_combination,
- syserr_bidi_invalid_reserved,
- syserr_bidi_invalid_effect,
- syserr_bidi_invalid_csdrec,
- syserr_bidi_invalid_csdstate,
- syserr_bidi_invalid_level,
- syserr_bidi_invalid_type_support,
- syserr_bidi_invalid_orientation,
- syserr_bidi_invalid_num_shape,
- syserr_bidi_invalid_csd,
- syserr_bidi_no_support,
- syserr_bidi_rw_incomplete,
- syserr_imp_invalid_parm,
- syserr_imp_invalid_length,
- syserr_hpfs_disk_error_warn,
- syserr_mon_bad_buffer,
- syserr_module_corrupted,
- syserr_sm_outof_swapfile,
- syserr_lf_timeout,
- syserr_lf_suspend_success,
- syserr_lf_resume_success,
- syserr_lf_redirect_success,
- syserr_lf_redirect_failure,
- syserr_swapper_not_active,
- syserr_invalid_swapid,
- syserr_ioerr_swap_file,
- syserr_swap_table_full,
- syserr_swap_file_full,
- syserr_cant_init_swapper,
- syserr_swapper_already_init,
- syserr_pmm_insufficient_memory,
- syserr_pmm_invalid_flags,
- syserr_pmm_invalid_address,
- syserr_pmm_lock_failed,
- syserr_pmm_unlock_failed,
- syserr_pmm_move_incomplete,
- syserr_ucom_drive_renamed,
- syserr_ucom_filename_truncated,
- syserr_ucom_buffer_length,
- syserr_mon_chain_handle,
- syserr_mon_not_registered,
- syserr_smg_already_top,
- syserr_pmm_arena_modified,
- syserr_smg_printer_open,
- syserr_pmm_set_flags_failed,
- syserr_invalid_dos_dd,
- syserr_blocked,
- syserr_noblock,
- syserr_instance_shared,
- syserr_no_object,
- syserr_partial_attach,
- syserr_incache,
- syserr_swap_io_problems,
- syserr_crosses_object_boundary,
- syserr_longlock,
- syserr_shortlock,
- syserr_uvirtlock,
- syserr_aliaslock,
- syserr_alias,
- syserr_no_more_handles,
- syserr_scan_terminated,
- syserr_terminator_not_found,
- syserr_not_direct_child,
- syserr_delay_free,
- syserr_guardpage,
- syserr_swaperror,
- syserr_ldrerror,
- syserr_nomemory,
- syserr_noaccess,
- syserr_no_dll_term,
- syserr_cpsio_code_page_invalid,
- syserr_cpsio_no_spooler,
- syserr_cpsio_font_id_invalid,
- syserr_cpsio_internal_error,
- syserr_cpsio_invalid_ptr_name,
- syserr_cpsio_not_active,
- syserr_cpsio_pid_full,
- syserr_cpsio_pid_not_found,
- syserr_cpsio_read_ctl_seq,
- syserr_cpsio_read_fnt_def,
- syserr_cpsio_write_error,
- syserr_cpsio_write_full_error,
- syserr_cpsio_write_handle_bad,
- syserr_cpsio_swit_load,
- syserr_cpsio_inv_command,
- syserr_cpsio_no_font_swit,
- syserr_entry_is_callgate,
-
- /* Socket errors: */
- syserr_socket_perm,
- syserr_socket_srch,
- syserr_socket_intr,
- syserr_socket_nxio,
- syserr_socket_badf,
- syserr_socket_acces,
- syserr_socket_fault,
- syserr_socket_inval,
- syserr_socket_mfile,
- syserr_socket_pipe,
- syserr_socket_os2err,
- syserr_socket_wouldblock,
- syserr_socket_inprogress,
- syserr_socket_already,
- syserr_socket_notsock,
- syserr_socket_destaddrreq,
- syserr_socket_msgsize,
- syserr_socket_prototype,
- syserr_socket_noprotoopt,
- syserr_socket_protonosupport,
- syserr_socket_socktnosupport,
- syserr_socket_opnotsupp,
- syserr_socket_pfnosupport,
- syserr_socket_afnosupport,
- syserr_socket_addrinuse,
- syserr_socket_addrnotavail,
- syserr_socket_netdown,
- syserr_socket_netunreach,
- syserr_socket_netreset,
- syserr_socket_connaborted,
- syserr_socket_connreset,
- syserr_socket_nobufs,
- syserr_socket_isconn,
- syserr_socket_notconn,
- syserr_socket_shutdown,
- syserr_socket_toomanyrefs,
- syserr_socket_timedout,
- syserr_socket_connrefused,
- syserr_socket_loop,
- syserr_socket_nametoolong,
- syserr_socket_hostdown,
- syserr_socket_hostunreach,
- syserr_socket_notempty,
-
- syserr_unknown
-};
-
-#define syserr_not_enough_space syserr_not_enough_memory
-
-#else /* not DEFINE_OS2_SYSCALLS */
-\f
-#ifndef SCM_OS2API_H
-#define SCM_OS2API_H
-
-/* STD_API_CALL cannot be written as a specialization of XTD_API_CALL,
- because that causes the `proc' argument to be expanded, which
- screws up the generation of `syscall_ ## proc'. */
-
-#define STD_API_CALL(proc, args) \
-{ \
- while (1) \
- { \
- APIRET rc = (proc args); \
- if (rc == NO_ERROR) \
- break; \
- if (rc != ERROR_INTERRUPT) \
- OS2_error_system_call (rc, syscall_ ## proc); \
- } \
-}
-
-#define XTD_API_CALL(proc, args, if_error) \
-{ \
- while (1) \
- { \
- APIRET rc = (proc args); \
- if (rc == NO_ERROR) \
- break; \
- if (rc != ERROR_INTERRUPT) \
- { \
- if_error; \
- OS2_error_system_call (rc, syscall_ ## proc); \
- } \
- } \
-}
-
-#define dos_alloc_mem DosAllocMem
-#define dos_alloc_shared_mem DosAllocSharedMem
-#define dos_async_timer DosAsyncTimer
-#define dos_close DosClose
-#define dos_close_event_sem DosCloseEventSem
-#define dos_close_mutex_sem DosCloseMutexSem
-#define dos_close_queue DosCloseQueue
-#define dos_copy DosCopy
-#define dos_create_dir DosCreateDir
-#define dos_create_event_sem DosCreateEventSem
-#define dos_create_mutex_sem DosCreateMutexSem
-#define dos_create_pipe DosCreatePipe
-#define dos_create_queue DosCreateQueue
-#define dos_create_thread DosCreateThread
-#define dos_delete DosDelete
-#define dos_delete_dir DosDeleteDir
-#define dos_dup_handle DosDupHandle
-#define dos_exec_pgm DosExecPgm
-#define dos_exit DosExit
-#define dos_find_close DosFindClose
-#define dos_find_first DosFindFirst
-#define dos_find_next DosFindNext
-#define dos_free_mem DosFreeMem
-#define dos_get_info_blocks DosGetInfoBlocks
-#define dos_get_message DosGetMessage
-#define dos_get_named_shared_mem DosGetNamedSharedMem
-#define dos_get_shared_mem DosGetSharedMem
-#define dos_give_shared_mem DosGiveSharedMem
-#define dos_kill_process DosKillProcess
-#define dos_kill_thread DosKillThread
-#define dos_move DosMove
-#define dos_open DosOpen
-#define dos_post_event_sem DosPostEventSem
-#define dos_query_current_dir DosQueryCurrentDir
-#define dos_query_current_disk DosQueryCurrentDisk
-#define dos_query_fh_state DosQueryFHState
-#define dos_query_file_info DosQueryFileInfo
-#define dos_query_fs_attach DosQueryFSAttach
-#define dos_query_fs_info DosQueryFSInfo
-#define dos_query_h_type DosQueryHType
-#define dos_query_mem DosQueryMem
-#define dos_query_n_p_h_state DosQueryNPHState
-#define dos_query_path_info DosQueryPathInfo
-#define dos_query_sys_info DosQuerySysInfo
-#define dos_read DosRead
-#define dos_read_queue DosReadQueue
-#define dos_release_mutex_sem DosReleaseMutexSem
-#define dos_request_mutex_sem DosRequestMutexSem
-#define dos_reset_event_sem DosResetEventSem
-#define dos_scan_env DosScanEnv
-#define dos_send_signal_exception DosSendSignalException
-#define dos_set_current_dir DosSetCurrentDir
-#define dos_set_default_disk DosSetDefaultDisk
-#define dos_set_fh_state DosSetFHState
-#define dos_set_file_ptr DosSetFilePtr
-#define dos_set_file_size DosSetFileSize
-#define dos_set_max_fh DosSetMaxFH
-#define dos_set_mem DosSetMem
-#define dos_set_path_info DosSetPathInfo
-#define dos_set_rel_max_fh DosSetRelMaxFH
-#define dos_start_timer DosStartTimer
-#define dos_stop_timer DosStopTimer
-#define dos_wait_child DosWaitChild
-#define dos_wait_event_sem DosWaitEventSem
-#define dos_write DosWrite
-#define dos_write_queue DosWriteQueue
-#define kbd_char_in KbdCharIn
-#define vio_wrt_tty VioWrtTTY
-
-#ifdef SCM_OS2TOP_C
-
-static char * syscall_names_table [] =
-{
- "dos-alloc-mem",
- "dos-alloc-shared-mem",
- "dos-async-timer",
- "dos-close",
- "dos-close-event-sem",
- "dos-close-mutex-sem",
- "dos-close-queue",
- "dos-copy",
- "dos-create-dir",
- "dos-create-event-sem",
- "dos-create-mutex-sem",
- "dos-create-pipe",
- "dos-create-queue",
- "dos-create-thread",
- "dos-delete",
- "dos-delete-dir",
- "dos-dup-handle",
- "dos-exec-pgm",
- "dos-exit",
- "dos-find-close",
- "dos-find-first",
- "dos-find-next",
- "dos-free-mem",
- "dos-get-info-blocks",
- "dos-get-message",
- "dos-get-named-shared-mem",
- "dos-get-shared-mem",
- "dos-give-shared-mem",
- "dos-kill-process",
- "dos-kill-thread",
- "dos-move",
- "dos-open",
- "dos-post-event-sem",
- "dos-query-current-dir",
- "dos-query-current-disk",
- "dos-query-fh-state",
- "dos-query-file-info",
- "dos-query-fs-attach",
- "dos-query-fs-info",
- "dos-query-h-type",
- "dos-query-mem",
- "dos-query-n-p-h-state",
- "dos-query-path-info",
- "dos-query-sys-info",
- "dos-read",
- "dos-read-queue",
- "dos-release-mutex-sem",
- "dos-request-mutex-sem",
- "dos-reset-event-sem",
- "dos-scan-env",
- "dos-send-signal-exception",
- "dos-set-current-dir",
- "dos-set-default-disk",
- "dos-set-fh-state",
- "dos-set-file-ptr",
- "dos-set-file-size",
- "dos-set-max-fh",
- "dos-set-mem",
- "dos-set-path-info",
- "dos-set-rel-max-fh",
- "dos-start-timer",
- "dos-stop-timer",
- "dos-wait-child",
- "dos-wait-event-sem",
- "dos-write",
- "dos-write-queue",
- "beginthread",
- "gmtime",
- "kbd-char-in",
- "localtime",
- "malloc",
- "mktime",
- "realloc",
- "time",
- "vio-wrt-tty",
-
- /* Socket calls: */
- "accept",
- "bind",
- "connect",
- "get-host-by-name",
- "get-host-name",
- "listen",
- "recv",
- "send",
- "socket",
- "soclose"
-};
-
-#endif /* SCM_OS2TOP_C */
-
-#endif /* SCM_OS2API_H */
-#endif /* not DEFINE_OS2_SYSCALLS */
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#define USE_PMCON
-/* #define USE_VIO */
-/* #define USE_PMIO */
-
-#include "os2.h"
-
-#ifdef USE_PMCON
-
-extern void OS2_initialize_pm_console (void);
-extern int OS2_pm_console_getch (void);
-extern void OS2_pm_console_write (const char *, size_t);
-
-#else
-#ifdef USE_PMIO
-
-#include <pmio.h>
-
-#endif
-#endif
-\f
-#ifdef USE_PMCON
-#define getch OS2_pm_console_getch
-#else
-#ifndef USE_PMIO
-static int getch (void);
-#endif
-#endif
-
-static void console_thread (void *);
-static void grab_console_lock (void);
-static void release_console_lock (void);
-
-static void process_input_char (char);
-static void do_rubout (void);
-static void add_to_line (char);
-static void do_newline (void);
-static void do_self_insert (char);
-static void add_char_to_line_buffer (char);
-static void finish_line (void);
-static void send_char (char);
-static void send_readahead (msg_t *);
-static void handle_console_interrupt (msg_t *);
-
-static void console_operator
- (Tchannel, chop_t, choparg_t, choparg_t, choparg_t);;
-static void flush_input (void);
-static void console_input_buffered (Tchannel, int, int *);
-static void console_output_cooked (Tchannel, int, int *);
-
-static void write_char (char, int);
-static void write_output (const char *, size_t, int);
-static void write_output_1 (const char *, const char *);
-static unsigned int char_output_length (char);
-
-static HMTX console_lock;
-static int input_buffered_p;
-static int output_cooked_p;
-static qid_t console_writer_qid;
-static channel_context_t * console_context;
-static void * line_buffer;
-
-TID OS2_console_tid;
-
-void
-OS2_initialize_console (void)
-{
-#ifdef USE_PMCON
- OS2_initialize_pm_console ();
-#else
-#ifdef USE_PMIO
- pmio_fontspec = "6.System VIO";
- set_width (80);
- set_height (40);
- start_pmio ();
-#endif
-#endif
- console_lock = (OS2_create_mutex_semaphore (0, 0));
- input_buffered_p = 1;
- output_cooked_p = 1;
- console_context = (OS2_make_channel_context ());
- OS2_open_qid ((CHANNEL_CONTEXT_READER_QID (console_context)),
- OS2_scheme_tqueue);
- console_writer_qid = (CHANNEL_CONTEXT_WRITER_QID (console_context));
- OS2_open_qid (console_writer_qid, (OS2_make_std_tqueue ()));
- (CHANNEL_CONTEXT_FIRST_READ_P (console_context)) = 0;
- OS2_console_tid = (OS2_beginthread (console_thread, 0, 0x4000));
- (CHANNEL_CONTEXT_TID (console_context)) = OS2_console_tid;
-}
-\f
-static void
-console_thread (void * arg)
-{
- EXCEPTIONREGISTRATIONRECORD registration;
- grab_console_lock ();
- line_buffer = (OS2_make_readahead_buffer ());
- release_console_lock ();
- (void) OS2_thread_initialize ((®istration), console_writer_qid);
- while (1)
- {
- int c = (getch ());
- if (c == EOF)
- {
- msg_t * message = (OS2_make_readahead ());
- (SM_READAHEAD_SIZE (message)) = 0;
- send_readahead (message);
- break;
- }
- {
- int code = (OS2_keyboard_interrupt_handler (c));
- if (code == '\0')
- process_input_char (c);
- else
- {
- msg_t * message = (OS2_create_message (mt_console_interrupt));
- (SM_CONSOLE_INTERRUPT_CODE (message)) = code;
- OS2_send_message (OS2_interrupt_qid, message);
- /* Flush buffers only for certain chars? */
- flush_input ();
- if (c == '\a')
- write_char ('\a', 0);
- }
- }
- }
- {
- tqueue_t * tqueue = (OS2_qid_tqueue (console_writer_qid));
- OS2_close_qid (console_writer_qid);
- OS2_close_std_tqueue (tqueue);
- }
- OS2_endthread ();
-}
-
-#if ((!defined(USE_PMCON)) && (!defined(USE_PMIO)))
-static int
-getch (void)
-{
- while (1)
- {
-#ifdef USE_VIO
- KBDKEYINFO info;
- XTD_API_CALL
- (kbd_char_in, ((&info), IO_WAIT, 0),
- {
- if (rc == ERROR_KBD_INVALID_HANDLE)
- return (EOF);
- });
- if ((info . fbStatus) == 0x40)
- return (info . chChar);
-#else
- int c = (_getch ());
- if (c == EOF)
- return (EOF);
- else if ((c == 0) || (c == 0xe0))
- {
- /* Discard extended keycodes. */
- if ((_getch ()) == EOF)
- return (EOF);
- }
- else
- return (c);
-#endif
- }
-}
-#endif /* not USE_PMIO */
-
-static void
-grab_console_lock (void)
-{
- OS2_request_mutex_semaphore (console_lock);
-}
-
-static void
-release_console_lock (void)
-{
- OS2_release_mutex_semaphore (console_lock);
-}
-\f
-static void
-process_input_char (char c)
-{
- if (!input_buffered_p)
- send_char (c);
- else switch (c)
- {
- case '\b':
- case '\177':
- do_rubout ();
- break;
- case '\r':
- do_self_insert ('\r');
- do_self_insert ('\n');
- finish_line ();
- break;
- default:
- do_self_insert (c);
- break;
- }
-}
-
-static void
-do_self_insert (char c)
-{
- add_char_to_line_buffer (c);
- write_char (c, 1);
-}
-
-static void
-add_char_to_line_buffer (char c)
-{
- grab_console_lock ();
- OS2_readahead_buffer_insert (line_buffer, c);
- release_console_lock ();
-}
-
-static void
-do_rubout (void)
-{
- grab_console_lock ();
- if (OS2_readahead_buffer_emptyp (line_buffer))
- {
- release_console_lock ();
- write_char ('\a', 0);
- return;
- }
- {
- unsigned int n
- = (char_output_length (OS2_readahead_buffer_rubout (line_buffer)));
- unsigned int i;
- release_console_lock ();
- for (i = 0; (i < n); i += 1)
- write_char ('\b', 0);
- for (i = 0; (i < n); i += 1)
- write_char (' ', 0);
- for (i = 0; (i < n); i += 1)
- write_char ('\b', 0);
- }
-}
-\f
-static void
-finish_line (void)
-{
- msg_t ** messages;
- msg_t ** scan;
- grab_console_lock ();
- messages = (OS2_readahead_buffer_read_all (line_buffer));
- release_console_lock ();
- scan = messages;
- while (1)
- {
- msg_t * msg = (*scan++);
- if (msg == 0)
- break;
- send_readahead (msg);
- }
- OS_free (messages);
-}
-
-static void
-send_char (char c)
-{
- msg_t * message = (OS2_make_readahead ());
- (SM_READAHEAD_SIZE (message)) = 1;
- ((SM_READAHEAD_DATA (message)) [0]) = c;
- send_readahead (message);
-}
-
-static void
-send_readahead (msg_t * message)
-{
- OS2_send_message (console_writer_qid, message);
- (void) OS2_wait_for_readahead_ack (console_writer_qid);
-}
-\f
-void
-OS2_initialize_console_channel (Tchannel channel)
-{
- (CHANNEL_OPERATOR_CONTEXT (channel)) = console_context;
- (CHANNEL_OPERATOR (channel)) = console_operator;
-}
-
-static void
-console_operator (Tchannel channel, chop_t operation,
- choparg_t arg1, choparg_t arg2, choparg_t arg3)
-{
- switch (operation)
- {
- case chop_read:
- (* ((long *) arg3))
- = (OS2_channel_thread_read
- (channel, ((char *) arg1), ((size_t) arg2)));
- break;
- case chop_write:
- write_output (((const char *) arg1), ((size_t) arg2), output_cooked_p);
- (* ((long *) arg3)) = ((size_t) arg2);
- break;
- case chop_close:
- case chop_output_flush:
- case chop_output_drain:
- break;
- case chop_input_flush:
- flush_input ();
- break;
- case chop_input_buffered:
- console_input_buffered (channel, ((int) arg1), ((int *) arg2));
- break;
- case chop_output_cooked:
- console_output_cooked (channel, ((int) arg1), ((int *) arg2));
- break;
- default:
- OS2_logic_error ("Unknown operation for console.");
- break;
- }
-}
-
-static void
-flush_input (void)
-{
- msg_t ** messages;
- msg_t ** scan;
- grab_console_lock ();
- messages = (OS2_readahead_buffer_read_all (line_buffer));
- release_console_lock ();
- scan = messages;
- while (1)
- {
- msg_t * msg = (*scan++);
- if (msg == 0)
- break;
- OS2_destroy_message (msg);
- }
- OS_free (messages);
-}
-
-static void
-console_input_buffered (Tchannel channel, int new, int * pold)
-{
- if (new < 0)
- (* pold) = input_buffered_p;
- else
- {
- int old = input_buffered_p;
- input_buffered_p = new;
- if (old && (!new))
- flush_input ();
- }
-}
-
-static void
-console_output_cooked (Tchannel channel, int new, int * pold)
-{
- if (new < 0)
- (* pold) = output_cooked_p;
- else
- output_cooked_p = (new ? 1 : 0);
-}
-\f
-static void
-write_char (char c, int cooked_p)
-{
- write_output ((&c), 1, cooked_p);
-}
-
-void
-OS2_console_write (const char * data, size_t size)
-{
- write_output (data, size, 2);
-}
-
-static void
-write_output (const char * data, size_t size, int cooked_p)
-{
- const char * scan = data;
- const char * end = (scan + size);
- char output_translation [256];
- char * out = output_translation;
- char * out_limit = (out + ((sizeof (output_translation)) - 4));
- char c;
- if (cooked_p == 0)
- write_output_1 (scan, end);
- else
- while (1)
- {
- if ((scan == end) || (out >= out_limit))
- {
- write_output_1 (output_translation, out);
- if (scan == end)
- break;
- out = output_translation;
- }
- c = (*scan++);
- if ((cooked_p == 2) && (c == '\n'))
- {
- (*out++) = '\r';
- (*out++) = '\n';
- }
- else if ((isprint (c))
- || (c == '\f')
- || (c == '\a')
- || (c == '\r')
- || (c == '\n'))
- (*out++) = c;
- else if (c < 0x20)
- {
- (*out++) = '^';
- (*out++) = ('@' + c);
- }
- else
- {
- (*out++) = '\\';
- (*out++) = ('0' + ((c >> 6) & 3));
- (*out++) = ('0' + ((c >> 3) & 7));
- (*out++) = ('0' + (c & 7));
- }
- }
-}
-\f
-static void
-write_output_1 (const char * scan, const char * end)
-{
-#ifdef USE_PMCON
-
- OS2_pm_console_write (scan, (end - scan));
-
-#else /* not USE_PMCON */
-#ifdef USE_PMIO
-
- put_raw ((end - scan), scan);
-
-#else /* not USE_PMIO */
-#ifdef USE_VIO
-
- STD_API_CALL (vio_wrt_tty, (((PCH) scan), (end - scan), 0));
-
-#else /* not USE_VIO */
-
- while (1)
- {
- ULONG n;
- APIRET rc = (dos_write (1, ((void *) scan), (end - scan), (& n)));
- if (rc != NO_ERROR)
- break;
- scan += n;
- if (scan == end)
- break;
- }
-
-#endif /* not USE_VIO */
-#endif /* not USE_PMIO */
-#endif /* not USE_PMCON */
-}
-
-static unsigned int
-char_output_length (char c)
-{
- return ((isprint (c)) ? 1 : (c < 0x20) ? 2 : 4);
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* Scheme side of channel thread interface */
-
-#include "os2.h"
-
-static void run_channel_thread (void *);
-static void start_readahead_thread (channel_context_t *);
-static void send_readahead_ack (qid_t, enum readahead_ack_action);
-static msg_t * new_message (void);
-\f
-typedef struct
-{
- LHANDLE handle;
- qid_t qid;
- channel_reader_t reader;
-} thread_arg_t;
-
-void
-OS2_start_channel_thread (Tchannel channel,
- channel_reader_t reader,
- channel_op_t operator)
-{
- channel_context_t * context = (OS2_make_channel_context ());
- thread_arg_t * arg = (OS_malloc (sizeof (thread_arg_t)));
- (CHANNEL_OPERATOR_CONTEXT (channel)) = context;
- OS2_open_qid ((CHANNEL_CONTEXT_READER_QID (context)), OS2_scheme_tqueue);
- OS2_open_qid
- ((CHANNEL_CONTEXT_WRITER_QID (context)), (OS2_make_std_tqueue ()));
- (arg -> handle) = (CHANNEL_HANDLE (channel));
- (arg -> qid) = (CHANNEL_CONTEXT_WRITER_QID (context));
- (arg -> reader) = reader;
- (CHANNEL_CONTEXT_TID (context))
- = (OS2_beginthread (run_channel_thread, arg, 0));
- (CHANNEL_OPERATOR (channel)) = operator;
-}
-
-static void
-run_channel_thread (void * arg)
-{
- LHANDLE handle = (((thread_arg_t *) arg) -> handle);
- qid_t qid = (((thread_arg_t *) arg) -> qid);
- channel_reader_t reader = (((thread_arg_t *) arg) -> reader);
- EXCEPTIONREGISTRATIONRECORD registration;
- OS_free (arg);
- (void) OS2_thread_initialize ((®istration), qid);
- /* Wait for first read request before doing anything. */
- while ((OS2_wait_for_readahead_ack (qid)) == raa_read)
- {
- int eofp;
- msg_t * message
- = ((*reader) (handle, qid, (OS2_make_readahead ()), (&eofp)));
- if (message == 0)
- break;
- OS2_send_message (qid, message);
- if (eofp)
- break;
- }
- {
- tqueue_t * tqueue = (OS2_qid_tqueue (qid));
- OS2_close_qid (qid);
- OS2_close_std_tqueue (tqueue);
- }
- OS2_endthread ();
-}
-
-void
-OS2_channel_thread_read_op (Tchannel channel,
- choparg_t arg1, choparg_t arg2, choparg_t arg3)
-{
- (* ((long *) arg3))
- = (OS2_channel_thread_read
- (channel, ((char *) arg1), ((size_t) arg2)));
-}
-\f
-void
-OS2_initialize_channel_thread_messages (void)
-{
- SET_MSG_TYPE_LENGTH (mt_readahead, sm_readahead_t);
- SET_MSG_TYPE_LENGTH (mt_readahead_ack, sm_readahead_ack_t);
-}
-
-channel_context_t *
-OS2_make_channel_context (void)
-{
- channel_context_t * context = (OS_malloc (sizeof (channel_context_t)));
- OS2_make_qid_pair ((& (CHANNEL_CONTEXT_READER_QID (context))),
- (& (CHANNEL_CONTEXT_WRITER_QID (context))));
- (CHANNEL_CONTEXT_EOFP (context)) = 0;
- (CHANNEL_CONTEXT_FIRST_READ_P (context)) = 1;
- return (context);
-}
-
-void
-OS2_channel_thread_close (Tchannel channel)
-{
- channel_context_t * context = (CHANNEL_OPERATOR_CONTEXT (channel));
- /* Send a readahead ACK informing the channel thread to kill itself.
- Then, close our end of the connection -- it's no longer needed. */
- send_readahead_ack ((CHANNEL_CONTEXT_READER_QID (context)), raa_close);
- OS2_close_qid (CHANNEL_CONTEXT_READER_QID (context));
- OS_free (context);
- /* Finally, the caller must close the channel handle. If the
- channel thread is blocked in dos_read, this will break it out and
- get it to kill itself. There's no race, because the channel
- thread won't try to close the handle, and if it breaks out of
- dos_read before we do the close, it will see the readahead ACK we
- just sent and that will kill it. */
-}
-
-qid_t
-OS2_channel_thread_descriptor (Tchannel channel)
-{
- channel_context_t * context = (CHANNEL_OPERATOR_CONTEXT (channel));
- /* Make sure that the readahead thread is started, so that when
- input arrives it will be registered properly so that the "select"
- emulation will notice it. */
- start_readahead_thread (context);
- return (CHANNEL_CONTEXT_READER_QID (context));
-}
-
-static void
-start_readahead_thread (channel_context_t * context)
-{
- /* Wake up the reader thread if this is the first time we are
- operating on it. This is necessary because we sometimes don't
- want to read from the channel at all -- for example, when the
- channel is the read side of a pipe that is being passed to a
- child process. */
- if (CHANNEL_CONTEXT_FIRST_READ_P (context))
- {
- send_readahead_ack ((CHANNEL_CONTEXT_READER_QID (context)), raa_read);
- (CHANNEL_CONTEXT_FIRST_READ_P (context)) = 0;
- }
-}
-\f
-msg_t *
-OS2_make_readahead (void)
-{
- msg_t * message = (OS2_create_message (mt_readahead));
- (SM_READAHEAD_INDEX (message)) = 0;
- return (message);
-}
-
-long
-OS2_channel_thread_read (Tchannel channel, char * buffer, size_t size)
-{
- channel_context_t * context = (CHANNEL_OPERATOR_CONTEXT (channel));
- qid_t qid = (CHANNEL_CONTEXT_READER_QID (context));
- msg_t * message;
- unsigned short index;
- unsigned short navail;
- if ((CHANNEL_CONTEXT_EOFP (context)) || (size == 0))
- return (0);
- start_readahead_thread (context);
- message = (OS2_receive_message (qid, (!CHANNEL_NONBLOCKING (channel)), 1));
- if (message == 0)
- return (-1);
- if (OS2_error_message_p (message))
- {
- send_readahead_ack (qid, raa_read);
- OS2_handle_error_message (message);
- }
- if ((MSG_TYPE (message)) != mt_readahead)
- OS2_logic_error ("Illegal message from channel thread.");
- index = (SM_READAHEAD_INDEX (message));
- if (index == 0)
- send_readahead_ack (qid, raa_read);
- navail = ((SM_READAHEAD_SIZE (message)) - index);
- if (navail == 0)
- {
- OS2_destroy_message (message);
- (CHANNEL_CONTEXT_EOFP (context)) = 1;
- return (0);
- }
- else if (navail <= size)
- {
- FASTCOPY (((SM_READAHEAD_DATA (message)) + index), buffer, navail);
- OS2_destroy_message (message);
- return (navail);
- }
- else
- {
- FASTCOPY (((SM_READAHEAD_DATA (message)) + index), buffer, size);
- (SM_READAHEAD_INDEX (message)) += size;
- OS2_unread_message (qid, message);
- return (size);
- }
-}
-
-static void
-send_readahead_ack (qid_t qid, enum readahead_ack_action action)
-{
- msg_t * message = (OS2_create_message (mt_readahead_ack));
- (SM_READAHEAD_ACK_ACTION (message)) = action;
- OS2_send_message (qid, message);
-}
-
-enum readahead_ack_action
-OS2_wait_for_readahead_ack (qid_t qid)
-{
- /* Wait for an acknowledgement before starting another read.
- This regulates the amount of data in the queue. */
- msg_t * message = (OS2_wait_for_message (qid, mt_readahead_ack));
- enum readahead_ack_action action = (SM_READAHEAD_ACK_ACTION (message));
- OS2_destroy_message (message);
- return (action);
-}
-\f
-void
-OS2_readahead_buffer_insert (void * buffer, char c)
-{
- msg_t * last = (OS2_msg_fifo_last (buffer));
- if ((last != 0) && ((SM_READAHEAD_SIZE (last)) < SM_READAHEAD_MAX))
- ((SM_READAHEAD_DATA (last)) [(SM_READAHEAD_SIZE (last))++]) = c;
- else
- {
- msg_t * message = (new_message ());
- ((SM_READAHEAD_DATA (message)) [(SM_READAHEAD_SIZE (message))++]) = c;
- OS2_msg_fifo_insert (buffer, message);
- }
-}
-
-static msg_t *
-new_message (void)
-{
- msg_t * message = (OS2_make_readahead ());
- (SM_READAHEAD_SIZE (message)) = 0;
- return (message);
-}
-
-char
-OS2_readahead_buffer_rubout (void * buffer)
-{
- msg_t * message = (OS2_msg_fifo_last (buffer));
- if (message == 0)
- OS2_logic_error ("Rubout from empty readahead buffer.");
- {
- char c = ((SM_READAHEAD_DATA (message)) [--(SM_READAHEAD_SIZE (message))]);
- if ((SM_READAHEAD_SIZE (message)) == 0)
- {
- OS2_msg_fifo_remove_last (buffer);
- OS2_destroy_message (message);
- }
- return (c);
- }
-}
-
-msg_t *
-OS2_readahead_buffer_read (void * buffer)
-{
- msg_t * message = (OS2_msg_fifo_remove (buffer));
- return ((message == 0) ? (new_message ()) : message);
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#ifndef SCM_OS2CTHRD_H
-#define SCM_OS2CTHRD_H
-\f
-#ifndef SM_READAHEAD_MAX
-#define SM_READAHEAD_MAX 4096
-#endif
-
-typedef struct
-{
- TID tid;
- qid_t reader_qid;
- qid_t writer_qid;
- unsigned int eofp : 1;
- unsigned int first_read_p : 1;
-} channel_context_t;
-#define CHANNEL_CONTEXT_TID(c) ((c) -> tid)
-#define CHANNEL_CONTEXT_READER_QID(c) ((c) -> reader_qid)
-#define CHANNEL_CONTEXT_WRITER_QID(c) ((c) -> writer_qid)
-#define CHANNEL_CONTEXT_EOFP(c) ((c) -> eofp)
-#define CHANNEL_CONTEXT_FIRST_READ_P(c) ((c) -> first_read_p)
-
-typedef struct
-{
- DECLARE_MSG_HEADER_FIELDS;
- unsigned short size;
- unsigned short index;
- char data [SM_READAHEAD_MAX];
-} sm_readahead_t;
-#define SM_READAHEAD_SIZE(m) (((sm_readahead_t *) (m)) -> size)
-#define SM_READAHEAD_INDEX(m) (((sm_readahead_t *) (m)) -> index)
-#define SM_READAHEAD_DATA(m) (((sm_readahead_t *) (m)) -> data)
-
-enum readahead_ack_action { raa_read, raa_close };
-
-typedef struct
-{
- DECLARE_MSG_HEADER_FIELDS;
- enum readahead_ack_action action;
-} sm_readahead_ack_t;
-#define SM_READAHEAD_ACK_ACTION(m) (((sm_readahead_ack_t *) (m)) -> action)
-
-typedef msg_t * (* channel_reader_t) (LHANDLE, qid_t, msg_t *, int *);
-
-extern void OS2_start_channel_thread
- (Tchannel, channel_reader_t, channel_op_t);
-extern void OS2_channel_thread_read_op
- (Tchannel, choparg_t, choparg_t, choparg_t);
-
-extern channel_context_t * OS2_make_channel_context (void);
-extern long OS2_channel_thread_read (Tchannel, char *, size_t);
-extern enum readahead_ack_action OS2_wait_for_readahead_ack (qid_t);
-extern void OS2_channel_thread_close (Tchannel);
-
-#define OS2_make_readahead_buffer OS2_create_msg_fifo
-#define OS2_readahead_buffer_emptyp OS2_msg_fifo_emptyp
-
-extern void OS2_readahead_buffer_insert (void *, char);
-extern char OS2_readahead_buffer_rubout (void *);
-extern msg_t * OS2_make_readahead (void);
-extern msg_t * OS2_readahead_buffer_read (void *);
-
-#define OS2_readahead_buffer_read_all(b) \
- ((msg_t **) (OS2_msg_fifo_remove_all (b)))
-
-#endif /* SCM_OS2CTHRD_H */
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#include "os2.h"
-#include "osctty.h"
-#include "ossig.h"
-\f
-#define CONTROL_B_ENABLE (0x1)
-#define CONTROL_G_ENABLE (0x2)
-#define CONTROL_U_ENABLE (0x4)
-#define CONTROL_X_ENABLE (0x8)
-#define INTERACTIVE_INTERRUPT_ENABLE (0x10)
-#define TERMINATE_INTERRUPT_ENABLE (0x20)
-
-#define ALL_ENABLES \
- (CONTROL_B_ENABLE | CONTROL_G_ENABLE | CONTROL_U_ENABLE | CONTROL_X_ENABLE)
-
-#define CONTROL_B '\002'
-#define CONTROL_G '\007'
-#define CONTROL_U '\025'
-#define CONTROL_X '\030'
-#define CONTROL_C '\003'
-
-#define KB_INT_CHARS_SIZE 5
-#define KB_INT_TABLE_SIZE 256
-
-static char keyboard_interrupt_characters [KB_INT_CHARS_SIZE];
-static enum interrupt_handler keyboard_interrupt_handlers [KB_INT_CHARS_SIZE];
-static enum interrupt_handler keyboard_interrupt_table [KB_INT_TABLE_SIZE];
-static enum interrupt_handler keyboard_break_interrupt;
-static Tinterrupt_enables keyboard_interrupt_enables;
-
-static void
-update_keyboard_interrupt_characters (void)
-{
- unsigned int i;
- for (i = 0; (i < KB_INT_TABLE_SIZE); i += 1)
- (keyboard_interrupt_table[i]) = interrupt_handler_ignore;
- for (i = 0; (i < KB_INT_CHARS_SIZE); i += 1)
- (keyboard_interrupt_table [keyboard_interrupt_characters [i]]) =
- (keyboard_interrupt_handlers[i]);
-}
-
-void
-OS2_initialize_keyboard_interrupts (void)
-{
- (keyboard_interrupt_characters[0]) = CONTROL_B;
- (keyboard_interrupt_handlers[0]) = interrupt_handler_control_b;
- (keyboard_interrupt_characters[1]) = CONTROL_G;
- (keyboard_interrupt_handlers[1]) = interrupt_handler_control_g;
- (keyboard_interrupt_characters[2]) = CONTROL_U;
- (keyboard_interrupt_handlers[2]) = interrupt_handler_control_u;
- (keyboard_interrupt_characters[3]) = CONTROL_X;
- (keyboard_interrupt_handlers[3]) = interrupt_handler_control_x;
- (keyboard_interrupt_characters[4]) = CONTROL_C;
- (keyboard_interrupt_handlers[4]) = interrupt_handler_interactive;
- keyboard_break_interrupt = interrupt_handler_terminate;
- update_keyboard_interrupt_characters ();
- keyboard_interrupt_enables = ALL_ENABLES;
-}
-\f
-void
-OS_ctty_get_interrupt_enables (Tinterrupt_enables * mask)
-{
- (*mask) = keyboard_interrupt_enables;
-}
-
-void
-OS_ctty_set_interrupt_enables (Tinterrupt_enables * mask)
-{
- keyboard_interrupt_enables = ((*mask) & ALL_ENABLES);
-}
-
-unsigned int
-OS_ctty_num_int_chars (void)
-{
- return (KB_INT_CHARS_SIZE + 1);
-}
-
-cc_t
-OS_tty_map_interrupt_char (cc_t int_char)
-{
- return (int_char);
-}
-
-cc_t *
-OS_ctty_get_int_chars (void)
-{
- static cc_t characters [KB_INT_CHARS_SIZE + 1];
- unsigned int i;
- for (i = 0; (i < KB_INT_CHARS_SIZE); i += 1)
- (characters[i]) = (keyboard_interrupt_characters[i]);
- (characters[i]) = '\0'; /* dummy for control-break */
- return (characters);
-}
-
-void
-OS_ctty_set_int_chars (cc_t * characters)
-{
- unsigned int i;
- for (i = 0; (i < KB_INT_CHARS_SIZE); i += 1)
- (keyboard_interrupt_characters[i]) = (characters[i]);
- update_keyboard_interrupt_characters ();
-}
-
-cc_t *
-OS_ctty_get_int_char_handlers (void)
-{
- static cc_t handlers [KB_INT_CHARS_SIZE + 1];
- unsigned int i;
- for (i = 0; (i < KB_INT_CHARS_SIZE); i += 1)
- (handlers[i]) = ((cc_t) (keyboard_interrupt_handlers[i]));
- (handlers[i]) = ((cc_t) keyboard_break_interrupt);
- return (handlers);
-}
-
-void
-OS_ctty_set_int_char_handlers (cc_t * handlers)
-{
- unsigned int i;
- for (i = 0; (i < KB_INT_CHARS_SIZE); i += 1)
- (keyboard_interrupt_handlers[i]) =
- ((enum interrupt_handler) (handlers[i]));
- keyboard_break_interrupt = ((enum interrupt_handler) (handlers[i]));
- update_keyboard_interrupt_characters ();
-}
-\f
-static char
-check_if_enabled (enum interrupt_handler handler)
-{
- unsigned int bitmask;
- char result;
- switch (handler)
- {
- case interrupt_handler_control_b:
- bitmask = CONTROL_B_ENABLE;
- result = 'B';
- break;
- case interrupt_handler_control_g:
- bitmask = CONTROL_G_ENABLE;
- result = 'G';
- break;
- case interrupt_handler_control_u:
- bitmask = CONTROL_U_ENABLE;
- result = 'U';
- break;
- case interrupt_handler_control_x:
- bitmask = CONTROL_X_ENABLE;
- result = 'X';
- break;
- case interrupt_handler_interactive:
- bitmask = INTERACTIVE_INTERRUPT_ENABLE;
- result = '!';
- break;
- case interrupt_handler_terminate:
- bitmask = TERMINATE_INTERRUPT_ENABLE;
- result = '@';
- break;
- default:
- bitmask = 0;
- result = '\0';
- break;
- }
- return (((keyboard_interrupt_enables & bitmask) == 0) ? '\0' : result);
-}
-
-char
-OS2_keyboard_interrupt_handler (char c)
-{
- return (check_if_enabled (keyboard_interrupt_table[c]));
-}
-
-char
-OS2_keyboard_break_interrupt_handler (void)
-{
- return (check_if_enabled (keyboard_break_interrupt));
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#ifndef SCM_OS2CTTY_H
-#define SCM_OS2CTTY_H
-
-extern char OS2_keyboard_interrupt_handler (char);
-extern char OS2_keyboard_break_interrupt_handler (void);
-
-#endif /* SCM_OS2CTTY_H */
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#include "scheme.h"
-#include "os2.h"
-#include "osenv.h"
-#include <time.h>
-#include <sys\types.h>
-
-#ifdef __IBMC__
-# include <sys\timeb.h>
-# define NC_TIMEZONE _timezone
-# define NC_DAYLIGHT _daylight
-# if (__IBMC__ >= 360)
-# define NC_FTIME ftime
-# else
-# define NC_FTIME _ftime
-# endif
-#endif
-
-#if defined(__WATCOMC__) || defined(__EMX__)
-# include <sys\timeb.h>
-# define NC_TIMEZONE timezone
-# define NC_DAYLIGHT daylight
-# define NC_FTIME ftime
-#endif
-
-#ifdef __GCC2__
-# include <errno.h>
-# include <sys/times.h>
-#endif
-
-static void initialize_real_time_clock (void);
-static double get_real_time_clock (void);
-
-static void initialize_timer (void);
-static void timer_thread (void *);
-static void handle_timer_event (msg_t *);
-
-void
-OS2_initialize_environment (void)
-{
- initialize_real_time_clock ();
- initialize_timer ();
-}
-\f
-time_t
-OS_encoded_time (void)
-{
- time_t t = (time (0));
- if (t < 0)
- OS2_error_system_call (errno, syscall_time);
- return (t);
-}
-
-void
-OS_decode_time (time_t t, struct time_structure * buffer)
-{
- struct tm * ts = (localtime (&t));
- if (ts == 0)
- OS2_error_system_call (errno, syscall_localtime);
- (buffer -> year) = ((ts -> tm_year) + 1900);
- (buffer -> month) = ((ts -> tm_mon) + 1);
- (buffer -> day) = (ts -> tm_mday);
- (buffer -> hour) = (ts -> tm_hour);
- (buffer -> minute) = (ts -> tm_min);
- (buffer -> second) = (ts -> tm_sec);
- (buffer -> daylight_savings_time) = (ts -> tm_isdst);
-#ifdef NC_TIMEZONE
- (buffer -> time_zone) = NC_TIMEZONE;
-#else
- (buffer -> time_zone) = INT_MAX;
-#endif
- {
- /* In localtime() encoding, 0 is Sunday; in ours, it's Monday. */
- int wday = (ts -> tm_wday);
- (buffer -> day_of_week) = ((wday == 0) ? 6 : (wday - 1));
- }
-}
-
-void
-OS_decode_utc (time_t t, struct time_structure * buffer)
-{
- struct tm * ts = (gmtime (&t));
- if (ts == 0)
- OS2_error_system_call (errno, syscall_gmtime);
- (buffer -> year) = ((ts -> tm_year) + 1900);
- (buffer -> month) = ((ts -> tm_mon) + 1);
- (buffer -> day) = (ts -> tm_mday);
- (buffer -> hour) = (ts -> tm_hour);
- (buffer -> minute) = (ts -> tm_min);
- (buffer -> second) = (ts -> tm_sec);
- (buffer -> daylight_savings_time) = (ts -> tm_isdst);
- (buffer -> time_zone) = 0;
- {
- /* In gmtime() encoding, 0 is Sunday; in ours, it's Monday. */
- int wday = (ts -> tm_wday);
- (buffer -> day_of_week) = ((wday == 0) ? 6 : (wday - 1));
- }
-}
-
-time_t
-OS_encode_time (struct time_structure * buffer)
-{
- struct tm ts;
- (ts . tm_year) = ((buffer -> year) - 1900);
- (ts . tm_mon) = ((buffer -> month) - 1);
- (ts . tm_mday) = (buffer -> day);
- (ts . tm_hour) = (buffer -> hour);
- (ts . tm_min) = (buffer -> minute);
- (ts . tm_sec) = (buffer -> second);
- (ts . tm_isdst) = (buffer -> daylight_savings_time);
- {
- time_t t = (mktime (&ts));
- if (t < 0)
- OS2_error_system_call (errno, syscall_mktime);
-#ifdef NC_TIMEZONE
- /* mktime assumes its argument is local time, and converts it to
- UTC; if the specified time zone is different, adjust the result. */
- if (((buffer -> time_zone) != INT_MAX)
- && ((buffer -> time_zone) != NC_TIMEZONE))
- t = ((t - NC_TIMEZONE) + (buffer -> time_zone));
-#endif
- return (t);
- }
-}
-
-long
-OS2_timezone (void)
-{
-#ifdef NC_TIMEZONE
- return (NC_TIMEZONE);
-#else
- return (0);
-#endif
-}
-
-int
-OS2_daylight_savings_p (void)
-{
-#ifdef NC_DAYLIGHT
- return (NC_DAYLIGHT);
-#else
- return (-1);
-#endif
-}
-
-static double initial_rtc;
-
-static void
-initialize_real_time_clock (void)
-{
- initial_rtc = (get_real_time_clock ());
-}
-
-double
-OS_real_time_clock (void)
-{
- return ((get_real_time_clock ()) - initial_rtc);
-}
-
-static double
-get_real_time_clock (void)
-{
-#ifdef NC_FTIME
- struct timeb rtc;
- NC_FTIME (&rtc);
- return ((((double) (rtc . time)) * 1000.0) + ((double) (rtc . millitm)));
-#endif
-#ifdef __GCC2__
- struct tms rtc;
- times (&rtc);
- return (((double) (rtc . tms_utime)) * (1000.0 / ((double) CLK_TCK)));
-#endif
-}
-
-double
-OS_process_clock (void)
-{
- /* This must not signal an error in normal use. */
- return (OS_real_time_clock ());
-}
-\f
-static HEV timer_event;
-static int timer_handle_valid;
-static HTIMER timer_handle;
-TID OS2_timer_tid;
-
-static void
-initialize_timer (void)
-{
- timer_event = (OS2_create_event_semaphore (0, 1));
- timer_handle_valid = 0;
- OS2_timer_tid = (OS2_beginthread (timer_thread, 0, 0));
-}
-
-static void
-timer_thread (void * arg)
-{
- EXCEPTIONREGISTRATIONRECORD registration;
- (void) OS2_thread_initialize ((®istration), QID_NONE);
- while (1)
- {
- ULONG count = (OS2_reset_event_semaphore (timer_event));
- while (count > 0)
- {
- OS2_send_message (OS2_interrupt_qid,
- (OS2_create_message (mt_timer_event)));
- count -= 1;
- }
- (void) OS2_wait_event_semaphore (timer_event, 1);
- }
-}
-
-void
-OS_real_timer_set (clock_t first, clock_t interval)
-{
- /* **** No support for (first != interval), but runtime system never
- does that anyway. */
- OS_real_timer_clear ();
- if (interval != 0)
- {
- STD_API_CALL (dos_start_timer, (interval,
- ((HSEM) timer_event),
- (&timer_handle)));
- timer_handle_valid = 1;
- }
- else if (first != 0)
- {
- STD_API_CALL (dos_async_timer, (first,
- ((HSEM) timer_event),
- (&timer_handle)));
- timer_handle_valid = 1;
- }
-}
-
-void
-OS_real_timer_clear (void)
-{
- if (timer_handle_valid)
- {
- STD_API_CALL (dos_stop_timer, (timer_handle));
- timer_handle_valid = 0;
- }
- (void) OS2_reset_event_semaphore (timer_event);
-}
-\f
-void
-OS_process_timer_set (clock_t first, clock_t interval)
-{
- OS2_error_unimplemented_primitive ();
-}
-
-void
-OS_process_timer_clear (void)
-{
-}
-
-void
-OS_profile_timer_set (clock_t first, clock_t interval)
-{
- OS2_error_unimplemented_primitive ();
-}
-
-void
-OS_profile_timer_clear (void)
-{
-}
-\f
-static size_t current_dir_path_size = 0;
-static char * current_dir_path = 0;
-
-const char *
-OS_working_dir_pathname (void)
-{
- ULONG drive_number;
- {
- ULONG drive_map;
- STD_API_CALL (dos_query_current_disk, ((&drive_number), (&drive_map)));
- }
- if ((current_dir_path_size == 0) || (current_dir_path == 0))
- {
- current_dir_path_size = 1024;
- current_dir_path = (OS_malloc (current_dir_path_size));
- }
- while (1)
- {
- ULONG size = (current_dir_path_size - 3);
- {
- APIRET rc =
- (dos_query_current_dir
- (drive_number, (current_dir_path + 3), (&size)));
- if (rc == NO_ERROR)
- break;
- if (rc != ERROR_BUFFER_OVERFLOW)
- OS2_error_system_call (rc, syscall_dos_query_current_dir);
- }
- do
- current_dir_path_size *= 2;
- while ((current_dir_path_size - 3) < size);
- OS_free (current_dir_path);
- current_dir_path = (OS_malloc (current_dir_path_size));
- }
- (current_dir_path[0]) = ('a' + drive_number - 1);
- (current_dir_path[1]) = ':';
- (current_dir_path[2]) = '\\';
- return (current_dir_path);
-}
-
-void
-OS_set_working_dir_pathname (const char * name)
-{
- extern char * OS2_remove_trailing_backslash (const char *);
- unsigned int length;
- name = (OS2_remove_trailing_backslash (name));
- length = (strlen (name));
- if ((length >= 2) && ((name[1]) == ':'))
- {
- STD_API_CALL
- (dos_set_default_disk,
- ((name[0]) - ((islower (name[0])) ? 'a' : 'A') + 1));
- name += 2;
- length -= 2;
- }
- STD_API_CALL (dos_set_current_dir, ((length == 0) ? "\\" : ((char *) name)));
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#include "os2.h"
-#include "osfile.h"
-
-static ULONG set_file_pointer (Tchannel, ULONG, LONG);
-
-#define OS2_OPEN_MODE(m) \
- (((((m) & CHANNEL_READ) == 0) \
- ? (OPEN_ACCESS_WRITEONLY | OPEN_SHARE_DENYWRITE) \
- : (((m) & CHANNEL_WRITE) == 0) \
- ? (OPEN_ACCESS_READONLY | OPEN_SHARE_DENYNONE) \
- : (OPEN_ACCESS_READWRITE | OPEN_SHARE_DENYWRITE)) \
- | OPEN_FLAGS_NOINHERIT)
-\f
-static Tchannel
-open_file (const char * filename, ULONG attr, ULONG flags, unsigned int mode)
-{
- HFILE handle;
- ULONG action;
- STD_API_CALL
- (dos_open, (((char *) filename), (&handle), (&action), 0, attr, flags,
- (OS2_OPEN_MODE (mode)), 0));
- return (OS2_make_channel (handle, mode));
-}
-
-Tchannel
-OS_open_input_file (const char * filename)
-{
- return
- (open_file (filename,
- FILE_NORMAL,
- (OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_FAIL_IF_NEW),
- CHANNEL_READ));
-}
-
-Tchannel
-OS_open_output_file (const char * filename)
-{
- return
- (open_file (filename,
- FILE_NORMAL,
- (OPEN_ACTION_REPLACE_IF_EXISTS | OPEN_ACTION_CREATE_IF_NEW),
- CHANNEL_WRITE));
-}
-
-Tchannel
-OS_open_io_file (const char * filename)
-{
- return
- (open_file (filename,
- FILE_NORMAL,
- (OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_CREATE_IF_NEW),
- (CHANNEL_READ | CHANNEL_WRITE)));
-}
-
-Tchannel
-OS_open_append_file (const char * filename)
-{
- Tchannel channel =
- (open_file (filename,
- FILE_NORMAL,
- (OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_CREATE_IF_NEW),
- CHANNEL_WRITE));
- transaction_begin ();
- OS_channel_close_on_abort (channel);
- (void) set_file_pointer (channel, FILE_END, 0);
- transaction_commit ();
- return (channel);
-}
-
-Tchannel
-OS_open_exclusive_output_file (const char * filename)
-{
- error_unimplemented_primitive ();
- return (0);
-}
-\f
-static Tchannel
-open_file_noerror (const char * filename, ULONG attr, ULONG flags,
- unsigned int mode)
-{
- HFILE handle;
- ULONG action;
- if ((dos_open (((char *) filename), (&handle), (&action), 0, attr, flags,
- (OS2_OPEN_MODE (mode)), 0))
- != NO_ERROR)
- return (NO_CHANNEL);
- {
- Tchannel channel = (OS2_make_channel (handle, mode));
- if ((CHANNEL_TYPE (channel)) == channel_type_file)
- return (channel);
- OS_channel_close_noerror (channel);
- return (NO_CHANNEL);
- }
-}
-
-Tchannel
-OS_open_load_file (const char * filename)
-{
- return
- (open_file_noerror
- (filename,
- FILE_NORMAL,
- (OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_FAIL_IF_NEW),
- CHANNEL_READ));
-}
-
-Tchannel
-OS_open_dump_file (const char * filename)
-{
- return
- (open_file_noerror
- (filename,
- FILE_NORMAL,
- (OPEN_ACTION_REPLACE_IF_EXISTS | OPEN_ACTION_CREATE_IF_NEW),
- CHANNEL_WRITE));
-}
-
-off_t
-OS_file_length (Tchannel channel)
-{
- FILESTATUS3 buffer;
- if ((CHANNEL_TYPE (channel)) != channel_type_file)
- OS2_error_system_call (ERROR_INVALID_HANDLE, syscall_dos_query_file_info);
- STD_API_CALL
- (dos_query_file_info,
- ((CHANNEL_HANDLE (channel)), FIL_STANDARD,
- (&buffer), (sizeof (buffer))));
- return (buffer.cbFile);
-}
-
-off_t
-OS_file_position (Tchannel channel)
-{
- return (set_file_pointer (channel, FILE_CURRENT, 0));
-}
-
-void
-OS_file_set_position (Tchannel channel, off_t position)
-{
- if ((set_file_pointer (channel, FILE_BEGIN, position)) != position)
- OS2_error_anonymous ();
-}
-
-static ULONG
-set_file_pointer (Tchannel channel, ULONG type, LONG distance)
-{
- ULONG fp;
- if ((CHANNEL_TYPE (channel)) != channel_type_file)
- OS2_error_system_call (ERROR_INVALID_HANDLE, syscall_dos_set_file_ptr);
- STD_API_CALL
- (dos_set_file_ptr, ((CHANNEL_HANDLE (channel)), distance, type, (&fp)));
- return (fp);
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#include "os2.h"
-#include "osfs.h"
-
-#ifdef __GCC2__
-# define stricmp strcasecmp
-# define strnicmp strncasecmp
-#endif
-
-#ifndef FILE_TOUCH_OPEN_TRIES
-# define FILE_TOUCH_OPEN_TRIES 5
-#endif
-
-static const char * make_pathname (const char *, const char *);
-static const char * filename_extension (const char *);
-extern char * OS2_drive_type (char);
-extern char * OS2_remove_trailing_backslash (const char *);
-\f
-FILESTATUS3 *
-OS2_read_file_status (const char * filename)
-{
- char name [CCHMAXPATH];
- static FILESTATUS3 info;
- unsigned int flen = (strlen (filename));
- FASTCOPY (filename, name, flen);
- /* Strip trailing backslash. */
- if ((flen > 0) && ((name [flen - 1]) == '\\'))
- flen -= 1;
- (name [flen]) = '\0';
- /* Canonicalize various forms of reference to root directory. */
- if ((flen == 5)
- && (isalpha (name [0]))
- && ((name [1]) == ':')
- && ((name [2]) == '\\')
- && ((name [3]) == '.')
- && ((name [4]) == '.'))
- (name [4]) = '\0';
- else if ((flen == 2)
- && (isalpha (name [0]))
- && ((name [1]) == ':'))
- {
- (name [2]) = '\\';
- (name [3]) = '.';
- (name [4]) = '\0';
- }
- else if (flen == 0)
- {
- (name [0]) = '\\';
- (name [1]) = '.';
- (name [2]) = '\0';
- }
- {
- APIRET rc
- = (dos_query_path_info (name, FIL_STANDARD, (&info), (sizeof (info))));
- /* So many different things can go wrong here that it is a bad
- idea to attempt to enumerate them. Several times I have
- thought I had all the possible conditions and later discovered
- that I was wrong. */
- if (rc != NO_ERROR)
- return (0);
- }
- return (&info);
-}
-
-void
-OS2_write_file_status (const char * filename, FILESTATUS3 * info)
-{
- STD_API_CALL
- (dos_set_path_info,
- ((OS2_remove_trailing_backslash (filename)),
- FIL_STANDARD, info, (sizeof (FILESTATUS3)), 0));
-}
-
-enum file_existence
-OS_file_existence_test (const char * filename)
-{
- return
- ((OS2_read_file_status (filename))
- ? file_does_exist
- : file_doesnt_exist);
-}
-
-enum file_existence
-OS_file_existence_test_direct (const char * filename)
-{
- return (OS_file_existence_test (filename));
-}
-
-enum file_type
-OS_file_type_direct (const char * filename)
-{
- FILESTATUS3 * info = (OS2_read_file_status (filename));
- return
- ((info == 0)
- ? file_type_nonexistent
- : (((info -> attrFile) & FILE_DIRECTORY) == 0)
- ? file_type_regular
- : file_type_directory);
-}
-
-enum file_type
-OS_file_type_indirect (const char * filename)
-{
- return (OS_file_type_direct (filename));
-}
-
-#define R_OK 4
-#define W_OK 2
-#define X_OK 1
-
-int
-OS_file_access (const char * filename, unsigned int mode)
-{
- FILESTATUS3 * info = (OS2_read_file_status (filename));
- if (!info)
- return (0);
- if (((mode & W_OK) != 0) && (((info -> attrFile) & FILE_READONLY) != 0))
- return (0);
- if (((mode & X_OK) != 0) && (((info -> attrFile) & FILE_DIRECTORY) == 0))
- {
- const char * extension = (filename_extension (filename));
- if (! (((stricmp (extension, ".exe")) == 0)
- || ((stricmp (extension, ".com")) == 0)
- || ((stricmp (extension, ".cmd")) == 0)
- || ((stricmp (extension, ".bat")) == 0)))
- return (0);
- }
- return (1);
-}
-
-int
-OS_file_directory_p (const char * filename)
-{
- if (((strlen (filename)) == 3)
- && (isalpha (filename [0]))
- && ((filename [1]) == ':')
- && ((filename [2]) == '\\'))
- return ((OS2_drive_type (filename [0])) != 0);
- else
- {
- FILESTATUS3 * info = (OS2_read_file_status (filename));
- return ((info == 0) ? 0 : (((info -> attrFile) & FILE_DIRECTORY) != 0));
- }
-}
-
-char *
-OS2_drive_type (char drive_letter)
-{
- char name [3];
- static char cbuf [(sizeof (FSQBUFFER2)) + (3 * CCHMAXPATH)];
- FSQBUFFER2 * buffer = ((FSQBUFFER2 *) cbuf);
- ULONG size = (sizeof (cbuf));
- (name [0]) = drive_letter;
- (name [1]) = ':';
- (name [2]) = '\0';
- STD_API_CALL
- (dos_query_fs_attach, (name, 0, FSAIL_QUERYNAME, buffer, (& size)));
- if (((buffer -> iType) == FSAT_LOCALDRV)
- || ((buffer -> iType) == FSAT_REMOTEDRV))
- {
- char * fsdname = ((buffer -> szName) + (buffer -> cbName) + 1);
- if ((buffer -> iType) == FSAT_REMOTEDRV)
- /* This bit of magic causes the "attach data" to be appended
- to the driver name, with a colon separator. In the case of
- an NFS drive, the "attach data" is the mount information,
- e.g. "martigny:/zu". This information is valuable, because
- it can be used to make crude inferences about the file
- system on the remote machine. */
- (fsdname [buffer -> cbFSDName]) = ':';
- return (fsdname);
- }
- else
- return (0);
-}
-
-const char *
-OS_file_soft_link_p (const char * filename)
-{
- return (0);
-}
-\f
-void
-OS_file_remove (const char * filename)
-{
- {
- FILESTATUS3 * info = (OS2_read_file_status (filename));
- if (info == 0)
- return;
- if (((info -> attrFile) & FILE_READONLY) != 0)
- {
- (info -> attrFile) &=~ FILE_READONLY;
- STD_API_CALL
- (dos_set_path_info,
- (((char *) filename), FIL_STANDARD, info, (sizeof (*info)), 0));
- }
- }
- STD_API_CALL (dos_delete, ((char *) filename));
-}
-
-void
-OS_file_remove_link (const char * filename)
-{
- OS_file_remove (filename);
-}
-
-void
-OS_file_rename (const char * from_name, const char * to_name)
-{
- STD_API_CALL (dos_move, (((char *) from_name), ((char *) to_name)));
-}
-
-void
-OS_file_link_hard (const char * from_name, const char * to_name)
-{
- OS2_error_unimplemented_primitive ();
-}
-
-void
-OS_file_link_soft (const char * from_name, const char * to_name)
-{
- OS2_error_unimplemented_primitive ();
-}
-
-void
-OS_file_copy (const char * from, const char * to)
-{
- FILESTATUS3 * info = (OS2_read_file_status (to));
- if ((info != 0) && (((info -> attrFile) & FILE_READONLY) != 0))
- {
- (info -> attrFile) &=~ FILE_READONLY;
- OS2_write_file_status (to, info);
- }
- STD_API_CALL (dos_copy, (((PSZ) from), ((PSZ) to), DCPY_EXISTING));
-}
-
-void
-OS_directory_make (const char * directory_name)
-{
- STD_API_CALL
- (dos_create_dir, ((OS2_remove_trailing_backslash (directory_name)), 0));
-}
-
-void
-OS_directory_delete (const char * directory_name)
-{
- STD_API_CALL
- (dos_delete_dir, (OS2_remove_trailing_backslash (directory_name)));
-}
-\f
-static void protect_handle (LHANDLE);
-
-int
-OS_file_touch (const char * filename)
-{
- HFILE handle;
- ULONG action;
- APIRET rc;
- unsigned int count = 0;
-
- transaction_begin ();
- while (1)
- {
- APIRET rc
- = (dos_open (((char *) filename),
- (&handle),
- (&action),
- 0,
- FILE_NORMAL,
- (OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_CREATE_IF_NEW),
- (OPEN_ACCESS_READWRITE | OPEN_SHARE_DENYREADWRITE),
- 0));
- if (rc == NO_ERROR)
- break;
- if ((rc != NO_ERROR)
- && (rc != ERROR_FILE_NOT_FOUND)
- && (rc != ERROR_PATH_NOT_FOUND)
- && ((++ count) >= FILE_TOUCH_OPEN_TRIES))
- OS2_error_system_call (rc, syscall_dos_open);
- }
- protect_handle (handle);
- if (action == FILE_CREATED)
- {
- transaction_commit ();
- return (1);
- }
- /* Existing file -- we'll write something to it to make sure that it
- has its times updated properly upon close. This was needed for
- unix implementation, but it is not known whether it is needed in
- OS/2. In any case, it does no harm to do this. */
- {
- FILESTATUS3 info;
- char buffer [1];
- ULONG n;
- STD_API_CALL (dos_query_file_info,
- (handle, FIL_STANDARD, (& info), (sizeof (info))));
- if ((info . cbFile) == 0)
- {
- /* Zero-length file: write a byte, then reset the length. */
- (buffer[0]) = '\0';
- STD_API_CALL (dos_write, (handle, buffer, 1, (& n)));
- STD_API_CALL (dos_set_file_size, (handle, 0));
- }
- else
- {
- /* Read the first byte, then write it back in place. */
- STD_API_CALL (dos_read, (handle, buffer, 1, (&n)));
- STD_API_CALL (dos_set_file_ptr, (handle, 0, FILE_BEGIN, (& n)));
- STD_API_CALL (dos_write, (handle, buffer, 1, (& n)));
- }
- }
- transaction_commit ();
- return (0);
-}
-
-static void
-protect_handle_1 (void * hp)
-{
- (void) dos_close (* ((LHANDLE *) hp));
-}
-
-static void
-protect_handle (LHANDLE h)
-{
- LHANDLE * hp = (dstack_alloc (sizeof (LHANDLE)));
- (*hp) = h;
- transaction_record_action (tat_always, protect_handle_1, hp);
-}
-\f
-typedef struct
-{
- char allocatedp;
- HDIR handle;
- FILEFINDBUF3 info;
- ULONG count;
-} dir_search_state;
-
-static dir_search_state * dir_search_states;
-static unsigned int n_dir_search_states;
-
-void
-OS2_initialize_directory_reader (void)
-{
- dir_search_states = 0;
- n_dir_search_states = 0;
-}
-
-static unsigned int
-allocate_dir_search_state (void)
-{
- if (n_dir_search_states == 0)
- {
- dir_search_state * states =
- ((dir_search_state *) (OS_malloc ((sizeof (dir_search_state)) * 4)));
- dir_search_states = states;
- n_dir_search_states = 4;
- {
- dir_search_state * scan = dir_search_states;
- dir_search_state * end = (scan + n_dir_search_states);
- ((scan++) -> allocatedp) = 1;
- while (scan < end)
- ((scan++) -> allocatedp) = 0;
- }
- return (0);
- }
- {
- dir_search_state * scan = dir_search_states;
- dir_search_state * end = (scan + n_dir_search_states);
- while (scan < end)
- if (! ((scan++) -> allocatedp))
- {
- ((--scan) -> allocatedp) = 1;
- return (scan - dir_search_states);
- }
- }
- {
- unsigned int result = n_dir_search_states;
- unsigned int n_states = (2 * n_dir_search_states);
- dir_search_state * states =
- ((dir_search_state *)
- (OS_realloc (((void *) dir_search_states),
- ((sizeof (dir_search_state)) * n_states))));
- {
- dir_search_state * scan = (states + result);
- dir_search_state * end = (states + n_states);
- ((scan++) -> allocatedp) = 1;
- while (scan < end)
- ((scan++) -> allocatedp) = 0;
- }
- dir_search_states = states;
- n_dir_search_states = n_states;
- return (result);
- }
-}
-
-#define REFERENCE_DIR_SEARCH_STATE(index) (& (dir_search_states[(index)]))
-#define DEALLOCATE_DIR_SEARCH_STATE(state) ((state) -> allocatedp) = 0
-\f
-int
-OS_directory_valid_p (unsigned int index)
-{
- return
- ((index < n_dir_search_states)
- && ((REFERENCE_DIR_SEARCH_STATE (index)) -> allocatedp));
-}
-
-static void
-dir_open_deallocate (void * arg)
-{
- DEALLOCATE_DIR_SEARCH_STATE ((dir_search_state *) arg);
-}
-
-unsigned int
-OS_directory_open (const char * search_pattern)
-{
- static char pattern [CCHMAXPATH];
- unsigned int index = (allocate_dir_search_state ());
- dir_search_state * s = (REFERENCE_DIR_SEARCH_STATE (index));
- transaction_begin ();
- transaction_record_action (tat_abort, dir_open_deallocate, s);
- strcpy (pattern, search_pattern);
- {
- unsigned int len = (strlen (pattern));
- if ((len > 0) && ((pattern [len - 1]) == '\\'))
- strcat (pattern, "*");
- }
- (s -> handle) = HDIR_CREATE;
- (s -> count) = 1;
- while (1)
- {
- APIRET rc
- = (dos_find_first
- (pattern, (& (s -> handle)), FILE_ANY, (& (s -> info)),
- (sizeof (s -> info)), (& (s -> count)), FIL_STANDARD));
- if (rc == NO_ERROR)
- break;
- if (rc == ERROR_NO_MORE_FILES)
- {
- (s -> handle) = HDIR_CREATE;
- (s -> count) = 0;
- break;
- }
- if (rc != ERROR_INTERRUPT)
- OS2_error_system_call (rc, syscall_dos_find_first);
- }
- transaction_commit ();
- return (index);
-}
-
-static void
-dir_find_next (dir_search_state * s)
-{
- (s -> count) = 1;
- XTD_API_CALL
- (dos_find_next,
- ((s -> handle), (& (s -> info)), (sizeof (s -> info)), (& (s -> count))),
- {
- if (rc == ERROR_NO_MORE_FILES)
- {
- (s -> count) = 0;
- return;
- }
- });
-}
-
-static const char *
-dir_current_name (dir_search_state * s)
-{
- static char result [CCHMAXPATH];
- strcpy (result, ((s -> info) . achName));
- dir_find_next (s);
- return (result);
-}
-
-const char *
-OS_directory_read (unsigned int index)
-{
- dir_search_state * s = (REFERENCE_DIR_SEARCH_STATE (index));
- return (((s -> count) == 0) ? 0 : (dir_current_name (s)));
-}
-
-const char *
-OS_directory_read_matching (unsigned int index, const char * prefix)
-{
- dir_search_state * s = (REFERENCE_DIR_SEARCH_STATE (index));
- unsigned int n = (strlen (prefix));
- while (1)
- {
- if ((s -> count) == 0)
- return (0);
- if ((strnicmp (((s -> info) . achName), prefix, n)) == 0)
- return (dir_current_name (s));
- dir_find_next (s);
- }
-}
-
-void
-OS_directory_close (unsigned int index)
-{
- dir_search_state * s = (REFERENCE_DIR_SEARCH_STATE (index));
- if ((s -> handle) != HDIR_CREATE)
- STD_API_CALL (dos_find_close, (s -> handle));
- DEALLOCATE_DIR_SEARCH_STATE (s);
-}
-\f
-static const char *
-filename_extension (const char * filename)
-{
- const char * start;
- const char * period;
- start = (strrchr (filename, '\\'));
- start = ((start == 0) ? filename : (start + 1));
- period = (strrchr (start, '.'));
- return ((period == 0) ? (filename + (strlen (filename))) : period);
-}
-
-static const char *
-make_pathname (const char * directory, const char * name)
-{
- unsigned int dirlen = (strlen (directory));
- unsigned int namlen = (strlen (name));
- char * result = (OS_malloc (dirlen + namlen + 2));
- strcpy (result, directory);
- if ((dirlen > 0) && ((result [dirlen - 1]) != '\\'))
- strcat (result, "\\");
- strcat (result, name);
- return (result);
-}
-
-char *
-OS2_remove_trailing_backslash (const char * filename)
-{
- static char result [CCHMAXPATH];
- unsigned int len = (strlen (filename));
- if ((len == 0) || ((filename [len - 1]) != '\\'))
- return ((char *) filename);
- FASTCOPY (filename, result, (len - 1));
- (result [len - 1]) = '\0';
- return (result);
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#include "os2.h"
-#include "os2proc.h"
-
-extern void add_reload_cleanup (void (*) (void));
-extern void OS2_initialize_console_channel (Tchannel);
-extern void OS2_initialize_pipe_channel (Tchannel);
-\f
-static enum channel_type handle_channel_type (LHANDLE);
-static void handle_noinherit (LHANDLE);
-
-Tchannel OS_channel_table_size;
-struct channel * OS2_channel_table;
-Tchannel * OS2_channel_pointer_table;
-const int OS_have_select_p = 1;
-
-#ifndef OS2_DEFAULT_MAX_FH
-# define OS2_DEFAULT_MAX_FH 256
-#endif
-
-/* Set this to a larger size than OS2_DEFAULT_MAX_FH, because the
- maximum number of file handles can be increased dynamically by
- calling a primitive. */
-#ifndef OS2_DEFAULT_CHANNEL_TABLE_SIZE
-# define OS2_DEFAULT_CHANNEL_TABLE_SIZE 1024
-#endif
-
-void
-OS2_initialize_channels (void)
-{
- {
- LONG req_max_fh = 0;
- ULONG current_max_fh;
- STD_API_CALL (dos_set_rel_max_fh, ((&req_max_fh), (¤t_max_fh)));
- req_max_fh = (OS2_DEFAULT_MAX_FH - current_max_fh);
- if (req_max_fh > 0)
- STD_API_CALL (dos_set_rel_max_fh, ((&req_max_fh), (¤t_max_fh)));
- }
- OS_channel_table_size = OS2_DEFAULT_CHANNEL_TABLE_SIZE;
- OS2_channel_table =
- (OS_malloc (OS_channel_table_size * (sizeof (struct channel))));
- OS2_channel_pointer_table =
- (OS_malloc (OS_channel_table_size * (sizeof (Tchannel))));
- {
- Tchannel channel;
- for (channel = 0; (channel < OS_channel_table_size); channel += 1)
- {
- (CHANNEL_OPEN (channel)) = 0;
- (OS2_channel_pointer_table [channel]) = channel;
- }
- }
- add_reload_cleanup (OS2_channel_close_all_noerror);
-}
-
-void
-OS2_reset_channels (void)
-{
- OS_free (OS2_channel_table);
- OS2_channel_table = 0;
- OS_channel_table_size = 0;
-}
-
-void
-OS2_channel_operation (Tchannel channel, chop_t operation,
- choparg_t arg1, choparg_t arg2, choparg_t arg3)
-{
- ((* (CHANNEL_OPERATOR (channel))) (channel, operation, arg1, arg2, arg3));
-}
-\f
-Tchannel
-OS2_make_channel (LHANDLE handle, unsigned int mode)
-{
- Tchannel channel;
- enum channel_type type;
- transaction_begin ();
- OS2_handle_close_on_abort (handle);
- type = (handle_channel_type (handle));
- handle_noinherit (handle);
- channel = (OS2_allocate_channel ());
- OS2_initialize_channel (channel, handle, mode, type);
- switch (type)
- {
- case channel_type_console:
- OS2_initialize_console_channel (channel);
- break;
- case channel_type_unnamed_pipe:
- OS2_initialize_pipe_channel (channel);
- break;
- }
- transaction_commit ();
- return (channel);
-}
-
-Tchannel
-OS2_allocate_channel (void)
-{
- Tchannel channel = 0;
- while (1)
- {
- if (channel == OS_channel_table_size)
- OS2_error_out_of_channels ();
- if (! (CHANNEL_OPEN (channel)))
- return (channel);
- channel += 1;
- }
-}
-
-static enum channel_type
-handle_channel_type (LHANDLE handle)
-{
- /* **** For now, limit channel types to those that we know how to
- handle in a reasonable way. Later we can add other types if
- needed. However, we probably won't need other types since pipes
- and files are sufficient to do nearly anything, and the console
- will be flushed when the PM support is installed. */
- ULONG type;
- ULONG flags;
- if ((dos_query_h_type (handle, (&type), (&flags))) == NO_ERROR)
- switch (type & 0xff)
- {
- case FHT_DISKFILE:
- return (channel_type_file);
- case FHT_CHRDEV:
- if ((flags & 0x3) != 0)
- return (channel_type_console);
- else if ((flags & 0x4) != 0)
- /* return (channel_type_null); */
- break;
- else if ((flags & 0x8) != 0)
- /* return (channel_type_clock); */
- break;
- else
- /* return (channel_type_character_device); */
- break;
- case FHT_PIPE:
- {
- APIRET rc = (dos_query_n_p_h_state (handle, (&flags)));
- if ((rc == NO_ERROR) || (rc == ERROR_PIPE_NOT_CONNECTED))
- /* return (channel_type_named_pipe); */
- break;
- else
- return (channel_type_unnamed_pipe);
- }
- }
- /* Anything that can't be recognized should be treated as a pipe.
- This is safe since pipes aren't assumed to have any special
- properties. */
- return (channel_type_unnamed_pipe);
-}
-
-static void
-handle_noinherit (LHANDLE handle)
-{
- ULONG state;
- STD_API_CALL (dos_query_fh_state, (handle, (& state)));
- /* Magic mask 0xFF88 zeroes out high bits and two fields
- required to be zero by the spec. When testing, the high
- bits were not zero, and this caused the system call to
- complain. */
- state &= 0xFF88;
- STD_API_CALL
- (dos_set_fh_state, (handle, (state | OPEN_FLAGS_NOINHERIT)));
-}
-
-static void
-channel_discard_on_abort_1 (void * cp)
-{
- (CHANNEL_OPEN (* ((Tchannel *) cp))) = 0;
-}
-
-static void
-channel_discard_on_abort (Tchannel c)
-{
- Tchannel * cp = (dstack_alloc (sizeof (Tchannel)));
- (*cp) = c;
- transaction_record_action (tat_abort, channel_discard_on_abort_1, cp);
-}
-
-void
-OS2_initialize_channel (Tchannel channel, LHANDLE handle, unsigned int mode,
- enum channel_type type)
-{
- (CHANNEL_HANDLE (channel)) = handle;
- (CHANNEL_TYPE (channel)) = type;
- (CHANNEL_OPEN (channel)) = 1;
- (CHANNEL_INTERNAL (channel)) = 0;
- (CHANNEL_NONBLOCKING (channel)) = 0;
- (CHANNEL_INPUTP (channel)) = ((mode & CHANNEL_READ) != 0);
- (CHANNEL_OUTPUTP (channel)) = ((mode & CHANNEL_WRITE) != 0);
- (CHANNEL_OPERATOR (channel)) = 0;
- channel_discard_on_abort (channel);
-}
-\f
-void
-OS_channel_close (Tchannel channel)
-{
- if (! (CHANNEL_INTERNAL (channel)))
- {
- if (CHANNEL_ABSTRACT_P (channel))
- OS2_channel_operation (channel, chop_close, 0, 0, 0);
- else
- STD_API_CALL (dos_close, (CHANNEL_HANDLE (channel)));
- (CHANNEL_OPEN (channel)) = 0;
- }
-}
-
-void
-OS2_channel_close_all_noerror (void)
-{
- Tchannel channel;
- for (channel = 0; (channel < OS_channel_table_size); channel += 1)
- if (CHANNEL_OPEN (channel))
- OS_channel_close_noerror (channel);
-}
-
-void
-OS_channel_close_noerror (Tchannel channel)
-{
- transaction_begin ();
- OS2_ignore_errors ();
- OS_channel_close (channel);
- transaction_commit ();
-}
-
-static void
-OS_channel_close_on_abort_1 (void * cp)
-{
- OS_channel_close_noerror (* ((Tchannel *) cp));
-}
-
-void
-OS_channel_close_on_abort (Tchannel channel)
-{
- Tchannel * cp = (dstack_alloc (sizeof (Tchannel)));
- (*cp) = (channel);
- transaction_record_action (tat_abort, OS_channel_close_on_abort_1, cp);
-}
-
-static void
-OS2_handle_close_on_abort_1 (void * hp)
-{
- (void) dos_close (* ((LHANDLE *) hp));
-}
-
-void
-OS2_handle_close_on_abort (LHANDLE h)
-{
- LHANDLE * hp = (dstack_alloc (sizeof (LHANDLE)));
- (*hp) = h;
- transaction_record_action (tat_abort, OS2_handle_close_on_abort_1, hp);
-}
-
-int
-OS_channel_open_p (Tchannel channel)
-{
- return (CHANNEL_OPEN (channel));
-}
-
-enum channel_type
-OS_channel_type (Tchannel channel)
-{
- return (CHANNEL_TYPE (channel));
-}
-\f
-long
-OS_channel_read (Tchannel channel, void * buffer, size_t nbytes)
-{
- long n;
- if (nbytes == 0)
- return (0);
- if (CHANNEL_ABSTRACT_P (channel))
- OS2_channel_operation (channel, chop_read,
- ((choparg_t) buffer),
- ((choparg_t) nbytes),
- ((choparg_t) (& n)));
- else
- STD_API_CALL
- (dos_read, ((CHANNEL_HANDLE (channel)), buffer, nbytes,
- ((ULONG *) (& n))));
- return (n);
-}
-
-long
-OS_channel_write (Tchannel channel, const void * buffer, size_t nbytes)
-{
- long n;
- if (nbytes == 0)
- return (0);
- if (CHANNEL_ABSTRACT_P (channel))
- OS2_channel_operation (channel,
- chop_write,
- ((choparg_t) buffer),
- ((choparg_t) nbytes),
- ((choparg_t) (& n)));
- else
- STD_API_CALL
- (dos_write, ((CHANNEL_HANDLE (channel)), ((void *) buffer), nbytes,
- ((ULONG *) (& n))));
- return (n);
-}
-
-int
-OS_channel_nonblocking_p (Tchannel channel)
-{
- return (CHANNEL_NONBLOCKING (channel));
-}
-
-void
-OS_channel_nonblocking (Tchannel channel)
-{
- (CHANNEL_NONBLOCKING (channel)) = 1;
-}
-
-void
-OS_channel_blocking (Tchannel channel)
-{
- (CHANNEL_NONBLOCKING (channel)) = 0;
-}
-
-void
-OS_channel_synchronize (Tchannel channel)
-{
-}
-\f
-size_t
-OS_channel_read_load_file (Tchannel channel, void * buffer, size_t nbytes)
-{
- ULONG nread;
- if ((dos_read ((CHANNEL_HANDLE (channel)), buffer, nbytes, (&nread))) != 0)
- return (0);
- return (nread);
-}
-
-size_t
-OS_channel_write_dump_file (Tchannel channel,
- const void * buffer,
- size_t nbytes)
-{
- ULONG nwrite;
- if ((dos_write
- ((CHANNEL_HANDLE (channel)), ((void *) buffer), nbytes, (&nwrite)))
- != 0)
- return (0);
- return (nwrite);
-}
-
-void
-OS_channel_write_string (Tchannel channel, const char * string)
-{
- unsigned long length = (strlen (string));
- if ((OS_channel_write (channel, string, length)) != length)
- OS2_error_anonymous ();
-}
-\f
-struct select_registry_s
-{
- unsigned int n_qids;
- unsigned int length;
- qid_t * qids;
- unsigned char * qmodes;
- unsigned char * rmodes;
-};
-
-select_registry_t
-OS_allocate_select_registry (void)
-{
- struct select_registry_s * r
- = (OS_malloc (sizeof (struct select_registry_s)));
- (r -> n_qids) = 0;
- (r -> length) = 16;
- (r -> qids) = (OS_malloc ((sizeof (qid_t)) * (r -> length)));
- (r -> qmodes) = (OS_malloc ((sizeof (unsigned char)) * (r -> length)));
- (r -> rmodes) = (OS_malloc ((sizeof (unsigned char)) * (r -> length)));
- return (r);
-}
-
-void
-OS_deallocate_select_registry (select_registry_t registry)
-{
- struct select_registry_s * r = registry;
- OS_free (r -> rmodes);
- OS_free (r -> qmodes);
- OS_free (r -> qids);
- OS_free (r);
-}
-
-static void
-resize_select_registry (struct select_registry_s * r, int growp)
-{
- if (growp)
- (r -> length) *= 2;
- else
- (r -> length) /= 2;
- (r -> qids)
- = (OS_realloc ((r -> qids),
- ((sizeof (qid_t)) * (r -> length))));
- (r -> qmodes)
- = (OS_realloc ((r -> qmodes),
- ((sizeof (unsigned char)) * (r -> length))));
- (r -> rmodes)
- = (OS_realloc ((r -> rmodes),
- ((sizeof (unsigned char)) * (r -> length))));
-}
-
-void
-OS_add_to_select_registry (select_registry_t registry, int fd,
- unsigned int mode)
-{
- struct select_registry_s * r = registry;
- qid_t qid = fd;
- unsigned int i = 0;
-
- while (i < (r -> n_qids))
- {
- if (((r -> qids) [i]) == qid)
- {
- ((r -> qmodes) [i]) |= mode;
- return;
- }
- i += 1;
- }
- if (i == (r -> length))
- resize_select_registry (r, 1);
- ((r -> qids) [i]) = qid;
- ((r -> qmodes) [i]) = mode;
- (r -> n_qids) += 1;
-}
-\f
-void
-OS_remove_from_select_registry (select_registry_t registry, int fd,
- unsigned int mode)
-{
- struct select_registry_s * r = registry;
- qid_t qid = fd;
- unsigned int i = 0;
-
- while (1)
- {
- if (i == (r -> n_qids))
- return;
- if (((r -> qids) [i]) == qid)
- {
- ((r -> qmodes) [i]) &=~ mode;
- if (((r -> qmodes) [i]) == 0)
- break;
- else
- return;
- }
- i += 1;
- }
- while (i < (r -> n_qids))
- {
- ((r -> qids) [i]) = ((r -> qids) [(i + 1)]);
- ((r -> qmodes) [i]) = ((r -> qmodes) [(i + 1)]);
- i += 1;
- }
- (r -> n_qids) -= 1;
-
- if (((r -> length) > 16) && ((r -> n_qids) < ((r -> length) / 2)))
- resize_select_registry (r, 0);
-}
-
-unsigned int
-OS_select_registry_length (select_registry_t registry)
-{
- struct select_registry_s * r = registry;
- return (r -> n_qids);
-}
-
-void
-OS_select_registry_result (select_registry_t registry, unsigned int index,
- int * fd_r, unsigned int * mode_r)
-{
- struct select_registry_s * r = registry;
- (*fd_r) = ((r -> qids) [index]);
- (*mode_r) = ((r -> rmodes) [index]);
-}
-\f
-int
-OS_test_select_descriptor (int fd, int blockp, unsigned int qmode)
-{
- qid_t qid = fd;
- unsigned int rmode = (qmode & SELECT_MODE_WRITE);
- if ((qmode & SELECT_MODE_READ) == 0)
- return (rmode);
- switch (OS2_message_availablep (qid, blockp))
- {
- case mat_available:
- return (rmode | SELECT_MODE_READ);
- case mat_not_available:
- return (rmode);
- case mat_interrupt:
- return
- ((OS_process_any_status_change ())
- ? SELECT_PROCESS_STATUS_CHANGE
- : SELECT_INTERRUPT);
- default:
- error_external_return ();
- return (rmode | SELECT_MODE_ERROR);
- }
-}
-
-int
-OS_test_select_registry (select_registry_t registry, int blockp)
-{
- struct select_registry_s * r = registry;
- unsigned int n_values = 0;
- int interruptp = 0;
- unsigned int i;
-
- while (1)
- {
- for (i = 0; (i < (r -> n_qids)); i += 1)
- {
- ((r -> rmodes) [i]) = (((r -> qmodes) [i]) & SELECT_MODE_WRITE);
- if ((((r -> qmodes) [i]) & SELECT_MODE_READ) != 0)
- switch (OS2_message_availablep (((r -> qids) [i]), 0))
- {
- case mat_available:
- ((r -> rmodes) [i]) |= SELECT_MODE_READ;
- break;
- case mat_interrupt:
- interruptp = 1;
- break;
- }
- if (((r -> rmodes) [i]) != 0)
- n_values += 1;
- }
- if (n_values > 0)
- return (n_values);
- if (interruptp)
- return
- ((OS_process_any_status_change ())
- ? SELECT_PROCESS_STATUS_CHANGE
- : SELECT_INTERRUPT);
- if (!blockp)
- return (0);
- if ((OS2_scheme_tqueue_block ()) == mat_interrupt)
- interruptp = 1;
- }
-}
-
-int
-OS_pause (bool ignore_status_change)
-{
- /* Wait-for-io must spin. */
- return
- ((OS_process_any_status_change ())
- ? SELECT_PROCESS_STATUS_CHANGE
- : SELECT_INTERRUPT);
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#ifndef SCM_OS2IO_H
-#define SCM_OS2IO_H
-
-#include "osio.h"
-\f
-typedef enum
-{
- chop_close,
- chop_read,
- chop_write,
- chop_input_buffered,
- chop_input_flush,
- chop_output_cooked,
- chop_output_flush,
- chop_output_drain
-} chop_t;
-
-typedef void * choparg_t;
-typedef void (* channel_op_t)
- (Tchannel, chop_t, choparg_t, choparg_t, choparg_t);
-
-struct channel
-{
- LHANDLE handle;
- channel_op_t operator;
- void * operator_context;
- enum channel_type type;
- unsigned int open : 1;
- unsigned int internal : 1;
- unsigned int nonblocking : 1;
- unsigned int inputp : 1;
- unsigned int outputp : 1;
-};
-
-#define _CHANNEL(c) (OS2_channel_table [(c)])
-#define CHANNEL_HANDLE(c) ((_CHANNEL (c)) . handle)
-#define CHANNEL_OPERATOR(c) ((_CHANNEL (c)) . operator)
-#define CHANNEL_OPERATOR_CONTEXT(c) ((_CHANNEL (c)) . operator_context)
-#define CHANNEL_TYPE(c) ((_CHANNEL (c)) . type)
-#define CHANNEL_OPEN(c) ((_CHANNEL (c)) . open)
-#define CHANNEL_INTERNAL(c) ((_CHANNEL (c)) . internal)
-#define CHANNEL_NONBLOCKING(c) ((_CHANNEL (c)) . nonblocking)
-#define CHANNEL_INPUTP(c) ((_CHANNEL (c)) . inputp)
-#define CHANNEL_OUTPUTP(c) ((_CHANNEL (c)) . outputp)
-
-#define CHANNEL_ABSTRACT_P(c) ((CHANNEL_OPERATOR (c)) != 0)
-
-#define channel_type_console channel_type_os2_console
-#define channel_type_unnamed_pipe channel_type_os2_unnamed_pipe
-#define channel_type_named_pipe channel_type_os2_named_pipe
-
-/* Channel modes: */
-#define CHANNEL_READ 1
-#define CHANNEL_WRITE 2
-
-extern struct channel * OS2_channel_table;
-extern Tchannel * OS2_channel_pointer_table;
-extern Tchannel OS2_make_channel (LHANDLE, unsigned int);
-extern void OS2_initialize_channel
- (Tchannel, LHANDLE, unsigned int, enum channel_type);
-extern Tchannel OS2_allocate_channel (void);
-extern void OS2_channel_close_all_noerror (void);
-extern void OS_channel_close_on_abort (Tchannel);
-extern void OS2_handle_close_on_abort (LHANDLE);
-extern void OS2_channel_operation
- (Tchannel, chop_t, choparg_t, choparg_t, choparg_t);
-
-#endif /* SCM_OS2IO_H */
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* Master Message Queue */
-
-#include "os2.h"
-
-extern void tty_set_next_interrupt_char (cc_t c);
-extern void * OS2_malloc_noerror (unsigned long);
-
-static qid_t allocate_qid (void);
-static void OS2_initialize_message_lengths (void);
-static void write_subqueue (msg_t *);
-static msg_t * read_subqueue (qid_t);
-static int subqueue_emptyp (qid_t);
-static msg_t * read_tqueue (tqueue_t *, int);
-static void write_tqueue (tqueue_t *, msg_t *);
-static msg_t * read_std_tqueue (tqueue_t *, int);
-static void write_std_tqueue (tqueue_t *, msg_t *);
-static tqueue_t * make_scm_tqueue (void);
-static msg_t * read_scm_tqueue (tqueue_t *, int);
-static void write_scm_tqueue (tqueue_t *, msg_t *);
-static void process_interrupt_messages (void);
-\f
-/*
-
-How this works
-==============
-
-This file describes the inter-thread communications mechanism. The
-naming used here is atrocious. Mea culpa; the code was written in
-1994, while these notes are being written in 2003. I've learned a bit
-in the meantime and can now see how bad the code is.
-
-Every thread has an associated input queue, called its "tqueue".
-(Originally meant to be an abbreviation of "Thread QUEUE".) All
-messages sent to that thread, from any source, are queued there in
-order of transmission.
-
-Two threads that wish to communicate must set up a "channel", which
-consists of a pair of "qid" objects. ("qid" was originally meant to
-be an abbreviation of "Queue IDentifier".) These objects are always
-created in pairs, one for each thread, and after creation each qid is
-associated with one of the two threads. The other half of a qid pair
-is called its "twin". If you are familiar with sockets, a qid is the
-analog of a socket. A qid pair is the analog of a connection.
-
-Also associated with each qid is something called a "subqueue", which
-is simply a secondary queue for messages received from that qid's
-twin.
-
-* Suppose that thread A and thread B share two halves of a qid pair,
- which we will call QA and QB. Also suppose that the tqueues
- associated with these threads are called TA and TB.
-
-* If thread A calls OS2_send_message() on QA and a message M, M's
- "sender" is set to be QB, and M is then queued at the end of TB.
- Additionally, if any thread is blocked on TB (only B is allowed to
- block on TB), the event semaphore EB is posted, which wakes up the
- threads waiting on TB.
-
-* If thread B calls OS2_receive_message() on QB, B first dequeues each
- the queued messages from TB. Each dequeued message M is queued at
- the end of the subqueue of the sender of M. For example, if M's
- sender is QB, then the message is put into QB's subqueue. This
- process is repeated until all of the messages have been removed from
- TB and dispatched to the appropriate subqueues.
-
- The subqueue for QB is then checked; if there are any messages, the
- first one is dequeued and then returned. Otherwise, B blocks on TB
- waiting for another message to arrive, by waiting on EB. Eventually
- the message sent by A arrives in TB, EB is posted, and B wakes up.
-
- This process continues until a message is received.
-
-Some things to note here: the event semaphores are the primary
-synchronization mechanism for communications. These guarantee that
-messages aren't lost due to timing errors. Additionally, each tqueue
-has an associated mutex semaphore that is used to lock the tqueue in
-critical sections.
-
-*/
-\f
-typedef struct
-{
- unsigned int allocatedp : 1; /* queue allocated? */
- qid_t twin; /* other end of connection */
- qid_receive_filter_t filter; /* filter for received messages */
- tqueue_t * tqueue; /* thread queue for reception */
- void * subqueue; /* receiving subqueue */
- HMTX lock;
-} iqid_t;
-
-static iqid_t queue_array [QID_MAX + 1];
-static HMTX qid_lock;
-
-tqueue_t * OS2_scheme_tqueue;
-static qid_t OS2_interrupt_qid_local;
-qid_t OS2_interrupt_qid;
-
-#define _QID(q) (queue_array [(q)])
-#define QID_ALLOCATEDP(q) ((_QID (q)) . allocatedp)
-#define QID_TWIN(q) ((_QID (q)) . twin)
-#define QID_FILTER(q) ((_QID (q)) . filter)
-#define QID_TQUEUE(q) ((_QID (q)) . tqueue)
-#define QID_SUBQUEUE(q) ((_QID (q)) . subqueue)
-#define QID_LOCK(q) ((_QID (q)) . lock)
-
-void
-OS2_initialize_message_queues (void)
-{
- {
- qid_t qid = 0;
- while (1)
- {
- (QID_ALLOCATEDP (qid)) = 0;
- (QID_TWIN (qid)) = QID_NONE;
- (QID_FILTER (qid)) = 0;
- (QID_TQUEUE (qid)) = 0;
- (QID_SUBQUEUE (qid)) = 0;
- (QID_LOCK (qid)) = NULLHANDLE;
- if (qid == QID_MAX)
- break;
- qid += 1;
- }
- }
- OS2_initialize_message_lengths ();
- SET_MSG_TYPE_LENGTH (mt_init, sm_init_t);
- SET_MSG_TYPE_LENGTH (mt_console_interrupt, sm_console_interrupt_t);
- SET_MSG_TYPE_LENGTH (mt_timer_event, sm_timer_event_t);
- SET_MSG_TYPE_LENGTH (mt_generic_reply, sm_generic_reply_t);
- qid_lock = (OS2_create_mutex_semaphore (0, 0));
- OS2_scheme_tqueue = (make_scm_tqueue ());
- OS2_make_qid_pair ((&OS2_interrupt_qid_local), (&OS2_interrupt_qid));
- OS2_open_qid (OS2_interrupt_qid_local, OS2_scheme_tqueue);
-}
-\f
-void
-OS2_make_qid_pair (qid_t * pq1, qid_t * pq2)
-{
- qid_t q1 = (allocate_qid ());
- qid_t q2 = (allocate_qid ());
- (QID_TWIN (q1)) = q2;
- (QID_TWIN (q2)) = q1;
- (*pq1) = q1;
- (*pq2) = q2;
-}
-
-static qid_t
-allocate_qid (void)
-{
- unsigned int qid = 0;
- OS2_request_mutex_semaphore (qid_lock);
- while (1)
- {
- if ((QID_ALLOCATEDP (qid)) == 0)
- break;
- if (qid == QID_MAX)
- OS2_logic_error ("No more QIDs available.");
- qid += 1;
- }
- (QID_ALLOCATEDP (qid)) = 1;
- (QID_TWIN (qid)) = QID_NONE;
- OS2_release_mutex_semaphore (qid_lock);
- (QID_FILTER (qid)) = 0;
- (QID_TQUEUE (qid)) = 0;
- (QID_SUBQUEUE (qid)) = (OS2_create_msg_fifo ());
- if ((QID_LOCK (qid)) == NULLHANDLE)
- (QID_LOCK (qid)) = (OS2_create_mutex_semaphore (0, 0));
- return (qid);
-}
-
-void
-OS2_open_qid (qid_t qid, tqueue_t * tqueue)
-{
- if ((QID_TQUEUE (qid)) != 0)
- OS2_logic_error ("Reopening already open QID.");
- if (tqueue == 0)
- OS2_logic_error ("Null tqueue passed to OS2_open_qid.");
- (QID_TQUEUE (qid)) = tqueue;
-}
-
-int
-OS2_qid_openp (qid_t qid)
-{
- return ((QID_TQUEUE (qid)) != 0);
-}
-
-void
-OS2_close_qid (qid_t qid)
-{
- OS2_request_mutex_semaphore (QID_LOCK (qid));
- while (1)
- {
- msg_t * msg = (OS2_msg_fifo_remove (QID_SUBQUEUE (qid)));
- if (msg == 0)
- break;
- OS2_destroy_message (msg);
- }
- OS2_destroy_msg_fifo (QID_SUBQUEUE (qid));
- (QID_FILTER (qid)) = 0;
- (QID_TQUEUE (qid)) = 0;
- (QID_SUBQUEUE (qid)) = 0;
- OS2_release_mutex_semaphore (QID_LOCK (qid));
- OS2_request_mutex_semaphore (qid_lock);
- {
- qid_t twin = (QID_TWIN (qid));
- if (twin != QID_NONE)
- {
- (QID_TWIN (twin)) = QID_NONE;
- (QID_TWIN (qid)) = QID_NONE;
- }
- }
- (QID_ALLOCATEDP (qid)) = 0;
- OS2_release_mutex_semaphore (qid_lock);
-}
-\f
-tqueue_t *
-OS2_qid_tqueue (qid_t qid)
-{
- return (QID_TQUEUE (qid));
-}
-
-qid_t
-OS2_qid_twin (qid_t qid)
-{
- qid_t twin;
- OS2_request_mutex_semaphore (qid_lock);
- twin
- = (((QID_ALLOCATEDP (qid))
- && ((QID_TWIN (qid)) != QID_NONE)
- && (QID_ALLOCATEDP (QID_TWIN (qid))))
- ? (QID_TWIN (qid))
- : QID_NONE);
- OS2_release_mutex_semaphore (qid_lock);
- return (twin);
-}
-
-void
-OS2_close_qid_pair (qid_t qid)
-{
- /* This is safe because it is used only in a particular way. The
- twin of this qid is never received from, and qid is never sent
- to, and the twin will never be closed by the other thread. Thus,
- even though the unlocked sections of OS2_close_qid are
- manipulating structures that belong to the other thread, the
- other thread won't be manipulating them so no conflict will
- arise. It's important not to use this procedure in any other
- situation! */
- if (QID_ALLOCATEDP (qid))
- {
- qid_t twin = (OS2_qid_twin (qid));
- if (twin != QID_NONE)
- OS2_close_qid (twin);
- OS2_close_qid (qid);
- }
-}
-
-void
-OS2_set_qid_receive_filter (qid_t qid, qid_receive_filter_t filter)
-{
- (QID_FILTER (qid)) = filter;
-}
-\f
-/* Message Lengths */
-
-#define MESSAGE_LENGTH(t) (message_lengths [(unsigned int) (t)])
-static msg_length_t message_lengths [MSG_TYPE_SUP];
-
-static void
-OS2_initialize_message_lengths (void)
-{
- unsigned int type = 0;
- while (1)
- {
- (MESSAGE_LENGTH (type)) = 0;
- if (type == MSG_TYPE_MAX)
- break;
- type += 1;
- }
-}
-
-void
-OS2_check_message_length_initializations (void)
-{
- unsigned int type = 0;
- while (1)
- {
- if ((MESSAGE_LENGTH (type)) == 0)
- {
- char buffer [64];
- sprintf (buffer, "Message type %d not initialized.", type);
- OS2_logic_error (buffer);
- }
- if (type == MSG_TYPE_MAX)
- break;
- type += 1;
- }
-}
-
-msg_length_t
-OS2_message_type_length (msg_type_t type)
-{
- msg_length_t length;
- if (type > MSG_TYPE_MAX)
- {
- char buffer [64];
- sprintf (buffer, "Message type %d out of range.", type);
- OS2_logic_error (buffer);
- }
- length = (MESSAGE_LENGTH (type));
- if (length == 0)
- {
- char buffer [64];
- sprintf (buffer, "Message type %d has unknown length.", type);
- OS2_logic_error (buffer);
- }
- return (length);
-}
-
-void
-OS2_set_message_type_length (msg_type_t type, msg_length_t length)
-{
- (MESSAGE_LENGTH (type)) = length;
-}
-
-msg_t *
-OS2_create_message_1 (msg_type_t type, msg_length_t extra)
-{
- /* Do allocation carefully to prevent infinite loop when signalling
- "out of memory" condition. */
- msg_t * message =
- (OS2_malloc_noerror (((unsigned long) (OS2_message_type_length (type)))
- + extra));
- if (message == 0)
- if ((type == mt_syscall_error)
- && ((SM_SYSCALL_ERROR_CODE (message)) == ERROR_NOT_ENOUGH_MEMORY)
- && ((SM_SYSCALL_ERROR_NAME (message)) == syscall_malloc))
- OS2_logic_error ("Unable to allocate memory for error message.");
- else
- OS2_error_system_call (ERROR_NOT_ENOUGH_MEMORY, syscall_malloc);
- (MSG_TYPE (message)) = type;
- return (message);
-}
-
-void
-OS2_destroy_message (msg_t * message)
-{
- OS_free (message);
-}
-\f
-/* Message Transmission and Reception */
-
-void
-OS2_send_message (qid_t qid, msg_t * message)
-{
- qid_t twin = (QID_TWIN (qid));
- tqueue_t * tqueue;
- if ((twin == QID_NONE) || ((tqueue = (QID_TQUEUE (twin))) == 0))
- /* Other end of connection has been closed, so discard the
- message. We used to signal an error here, but this can happen
- pretty easily when closing windows or exiting Scheme. The only
- way to avoid this is to force synchronization of communicating
- threads, which can be tricky. For example, when closing a PM
- window, it's not obvious when the last message will be
- generated by the PM thread. So it's just simpler to ignore
- messages after the receiver decides it's no longer interested
- in them. */
- OS2_destroy_message (message);
- else
- {
- (MSG_SENDER (message)) = twin;
- write_tqueue (tqueue, message);
- }
-}
-
-msg_t *
-OS2_receive_message (qid_t qid, int blockp, int interruptp)
-{
- tqueue_t * tqueue = (QID_TQUEUE (qid));
- msg_t * message;
- if (tqueue == 0)
- {
- if ((OS2_current_tid ()) != OS2_scheme_tid)
- /* This behavior is a little random, but it's based on the
- idea that if an inferior thread is reading from a closed
- channel, this is due to a race condition, and the fact that
- the channel is closed means that the thread is no longer
- needed. So far this has only happened under one
- circumstance, and in that case, this is the correct action. */
- OS2_endthread ();
- else
- OS2_error_anonymous ();
- }
- while (1)
- {
- while ((read_tqueue (tqueue, 0)) != 0)
- ;
- if ((TQUEUE_TYPE (tqueue)) == tqt_scm)
- {
- process_interrupt_messages ();
- if (interruptp)
- deliver_pending_interrupts ();
- }
- message = (read_subqueue (qid));
- if ((!blockp) || (message != 0))
- break;
- (void) read_tqueue (tqueue, 1);
- }
- return (message);
-}
-
-msg_avail_t
-OS2_message_availablep (qid_t qid, int blockp)
-{
- tqueue_t * tqueue = (QID_TQUEUE (qid));
- if (tqueue == 0)
- return (mat_not_available);
- while (1)
- {
- while ((read_tqueue (tqueue, 0)) != 0)
- ;
- if ((TQUEUE_TYPE (tqueue)) == tqt_scm)
- {
- process_interrupt_messages ();
- if (pending_interrupts_p ())
- return (mat_interrupt);
- }
- if (!subqueue_emptyp (qid))
- return (mat_available);
- if (!blockp)
- return (mat_not_available);
- (void) read_tqueue (tqueue, 1);
- }
-}
-
-msg_t *
-OS2_wait_for_message (qid_t qid, msg_type_t reply_type)
-{
- msg_t * reply = (OS2_receive_message (qid, 1, 0));
- if (OS2_error_message_p (reply))
- OS2_handle_error_message (reply);
- if ((MSG_TYPE (reply)) != reply_type)
- OS2_logic_error ("Incorrect reply message type.");
- return (reply);
-}
-
-msg_t *
-OS2_message_transaction (qid_t qid, msg_t * request, msg_type_t reply_type)
-{
- OS2_send_message (qid, request);
- return (OS2_wait_for_message (qid, reply_type));
-}
-\f
-static void
-write_subqueue (msg_t * message)
-{
- qid_t qid = (MSG_SENDER (message));
- qid_receive_filter_t filter = (QID_FILTER (qid));
- if (filter != 0)
- {
- message = ((* filter) (message));
- if (message == 0)
- return;
- }
- OS2_request_mutex_semaphore (QID_LOCK (qid));
- if (QID_SUBQUEUE (qid))
- OS2_msg_fifo_insert ((QID_SUBQUEUE (qid)), message);
- else
- /* If subqueue is gone, qid has been closed. */
- OS2_destroy_message (message);
- OS2_release_mutex_semaphore (QID_LOCK (qid));
-}
-
-static msg_t *
-read_subqueue (qid_t qid)
-{
- msg_t * result;
- OS2_request_mutex_semaphore (QID_LOCK (qid));
- result = (OS2_msg_fifo_remove (QID_SUBQUEUE (qid)));
- OS2_release_mutex_semaphore (QID_LOCK (qid));
- return (result);
-}
-
-void
-OS2_unread_message (qid_t qid, msg_t * message)
-{
- OS2_request_mutex_semaphore (QID_LOCK (qid));
- OS2_msg_fifo_insert_front ((QID_SUBQUEUE (qid)), message);
- OS2_release_mutex_semaphore (QID_LOCK (qid));
-}
-
-static int
-subqueue_emptyp (qid_t qid)
-{
- int result;
- OS2_request_mutex_semaphore (QID_LOCK (qid));
- result = (OS2_msg_fifo_emptyp (QID_SUBQUEUE (qid)));
- OS2_release_mutex_semaphore (QID_LOCK (qid));
- return (result);
-}
-
-static msg_t *
-read_tqueue (tqueue_t * tqueue, int blockp)
-{
- switch (TQUEUE_TYPE (tqueue))
- {
- case tqt_std:
- return (read_std_tqueue (tqueue, blockp));
- case tqt_scm:
- return (read_scm_tqueue (tqueue, blockp));
- case tqt_pm:
- return (OS2_read_pm_tqueue (tqueue, blockp));
- }
-}
-
-static void
-write_tqueue (tqueue_t * tqueue, msg_t * message)
-{
- switch (TQUEUE_TYPE (tqueue))
- {
- case tqt_std:
- write_std_tqueue (tqueue, message);
- break;
- case tqt_scm:
- write_scm_tqueue (tqueue, message);
- break;
- case tqt_pm:
- OS2_write_pm_tqueue (tqueue, message);
- break;
- }
-}
-\f
-/* Uncomment the following definition in order to use OS/2 queues.
-
- There seems to be some kind of bug when using them, which manifests
- itself as an access violation while reading from a socket. I don't
- understand this and have been unable to debug it successfully.
-
- Since my intention was to find a way to speed up the
- message-handling mechanism, and there is no noticeable improvement,
- it probably isn't worth much more effort to find the bug. */
-
-/* #define USE_OS2_QUEUES */
-#ifdef USE_OS2_QUEUES
-
-typedef struct
-{
- tqueue_type_t type;
- HQUEUE fifo;
- HEV event; /* event semaphore */
-} std_tqueue_t;
-#define STD_TQUEUE_FIFO(q) (((std_tqueue_t *) (q)) -> fifo)
-#define STD_TQUEUE_EVENT(q) (((std_tqueue_t *) (q)) -> event)
-
-tqueue_t *
-OS2_make_std_tqueue (void)
-{
- tqueue_t * tqueue = (OS_malloc (sizeof (std_tqueue_t)));
- (TQUEUE_TYPE (tqueue)) = tqt_std;
- (STD_TQUEUE_FIFO (tqueue)) = (OS2_create_queue (QUE_FIFO));
- (STD_TQUEUE_EVENT (tqueue)) = (OS2_create_event_semaphore (0, 0));
- return (tqueue);
-}
-
-static msg_t *
-read_std_tqueue_1 (tqueue_t * tqueue, int blockp)
-{
- ULONG type;
- ULONG length;
- PVOID data;
- return
- ((OS2_read_queue ((STD_TQUEUE_FIFO (tqueue)),
- (&type),
- (&length),
- (&data),
- (blockp ? 0 : (STD_TQUEUE_EVENT (tqueue)))))
- ? data
- : 0);
-}
-
-void
-OS2_close_std_tqueue (tqueue_t * tqueue)
-{
- while (1)
- {
- msg_t * msg = (read_std_tqueue_1 (tqueue, 0));
- if (msg == 0)
- break;
- OS2_destroy_message (msg);
- }
- OS2_close_queue (STD_TQUEUE_FIFO (tqueue));
- OS2_close_event_semaphore (STD_TQUEUE_EVENT (tqueue));
- OS_free (tqueue);
-}
-
-static msg_t *
-read_std_tqueue (tqueue_t * tqueue, int blockp)
-{
- msg_t * message = (read_std_tqueue_1 (tqueue, blockp));
- if (message)
- write_subqueue (message);
- return (message);
-}
-
-static void
-write_std_tqueue (tqueue_t * tqueue, msg_t * message)
-{
- OS2_write_queue ((STD_TQUEUE_FIFO (tqueue)), 0, 0, message, 0);
-}
-
-#else /* not USE_OS2_QUEUES */
-
-typedef struct
-{
- tqueue_type_t type;
- void * fifo;
- unsigned int n_blocked; /* # of blocked threads */
- HMTX mutex; /* mutex semaphore */
- HEV event; /* event semaphore */
-} std_tqueue_t;
-#define STD_TQUEUE_FIFO(q) (((std_tqueue_t *) (q)) -> fifo)
-#define STD_TQUEUE_MUTEX(q) (((std_tqueue_t *) (q)) -> mutex)
-#define STD_TQUEUE_EVENT(q) (((std_tqueue_t *) (q)) -> event)
-#define STD_TQUEUE_N_BLOCKED(q) (((std_tqueue_t *) (q)) -> n_blocked)
-
-tqueue_t *
-OS2_make_std_tqueue (void)
-{
- tqueue_t * tqueue = (OS_malloc (sizeof (std_tqueue_t)));
- (TQUEUE_TYPE (tqueue)) = tqt_std;
- (STD_TQUEUE_FIFO (tqueue)) = (OS2_create_msg_fifo ());
- (STD_TQUEUE_N_BLOCKED (tqueue)) = 0;
- (STD_TQUEUE_MUTEX (tqueue)) = (OS2_create_mutex_semaphore (0, 0));
- (STD_TQUEUE_EVENT (tqueue)) = (OS2_create_event_semaphore (0, 0));
- return (tqueue);
-}
-
-void
-OS2_close_std_tqueue (tqueue_t * tqueue)
-{
- OS2_close_event_semaphore (STD_TQUEUE_EVENT (tqueue));
- OS2_close_mutex_semaphore (STD_TQUEUE_MUTEX (tqueue));
- while (1)
- {
- msg_t * msg = (OS2_msg_fifo_remove (STD_TQUEUE_FIFO (tqueue)));
- if (msg == 0)
- break;
- OS2_destroy_message (msg);
- }
- OS_free (tqueue);
-}
-
-static msg_t *
-read_std_tqueue (tqueue_t * tqueue, int blockp)
-{
- OS2_request_mutex_semaphore (STD_TQUEUE_MUTEX (tqueue));
- while (1)
- {
- msg_t * message = (OS2_msg_fifo_remove (STD_TQUEUE_FIFO (tqueue)));
- if (message != 0)
- {
- OS2_release_mutex_semaphore (STD_TQUEUE_MUTEX (tqueue));
- write_subqueue (message);
- return (message);
- }
- if (!blockp)
- {
- OS2_release_mutex_semaphore (STD_TQUEUE_MUTEX (tqueue));
- return (0);
- }
- (void) OS2_reset_event_semaphore (STD_TQUEUE_EVENT (tqueue));
- (STD_TQUEUE_N_BLOCKED (tqueue)) += 1;
- OS2_release_mutex_semaphore (STD_TQUEUE_MUTEX (tqueue));
- (void) OS2_wait_event_semaphore ((STD_TQUEUE_EVENT (tqueue)), 1);
- OS2_request_mutex_semaphore (STD_TQUEUE_MUTEX (tqueue));
- (STD_TQUEUE_N_BLOCKED (tqueue)) -= 1;
- /* This prevents the 16 bit counter inside the event
- semaphore from overflowing. */
- if ((STD_TQUEUE_N_BLOCKED (tqueue)) == 0)
- (void) OS2_reset_event_semaphore (STD_TQUEUE_EVENT (tqueue));
- /* Don't wait more than once; the caller must be prepared to
- call again if a message is required. The reason this is
- necessary is that two threads may be waiting on the same
- tqueue at the same time, and when a message shows up, the
- wrong thread might read it. If we allowed the loop to
- continue, the thread that was waiting for the message would
- wake up, see no message, and go to sleep; meanwhile, the
- other thread has already stored the message in the correct
- subqueue. */
- blockp = 0;
- }
-}
-
-static void
-write_std_tqueue (tqueue_t * tqueue, msg_t * message)
-{
- OS2_request_mutex_semaphore (STD_TQUEUE_MUTEX (tqueue));
- OS2_msg_fifo_insert ((STD_TQUEUE_FIFO (tqueue)), message);
- if ((STD_TQUEUE_N_BLOCKED (tqueue)) > 0)
- {
- (void) OS2_post_event_semaphore (STD_TQUEUE_EVENT (tqueue));
- OS2_release_mutex_semaphore (STD_TQUEUE_MUTEX (tqueue));
- /* Immediately transfer control to the receiver.
- This should improve responsiveness of the system. */
- (void) DosSleep (0);
- }
- else
- OS2_release_mutex_semaphore (STD_TQUEUE_MUTEX (tqueue));
-}
-
-#endif /* not USE_OS2_QUEUES */
-\f
-static tqueue_t *
-make_scm_tqueue (void)
-{
- tqueue_t * tqueue = (OS2_make_std_tqueue ());
- (TQUEUE_TYPE (tqueue)) = tqt_scm;
- return (tqueue);
-}
-
-static msg_t *
-read_scm_tqueue (tqueue_t * tqueue, int blockp)
-{
- /* The handling of the interrupt bit is a little tricky. We clear
- the bit, then handle any events, and finally clear the bit again.
- If the bit is set during the second clear, we must loop since
- another event might have been queued in the window between the
- last read and the second clear -- and since we cleared the bit no
- one else is going to look at the queue until another event comes
- along.
-
- This code serves two purposes. First, this is the only way to
- reliably clear the interrupt bit to avoid having an event stuck
- in the queue and the Scheme thread not bothering to look.
- Second, if we arrive at this read-dispatch loop by some means
- other than the attention-interrupt mechanism, this will clear the
- bit and thus avoid ever invoking the mechanism. */
- msg_t * result = 0;
- (void) test_and_clear_attention_interrupt ();
- do
- {
- msg_t * message = (read_std_tqueue (tqueue, blockp));
- if (message != 0)
- {
- result = message;
- /* At most one message needs to be read in blocking mode. */
- blockp = 0;
- }
- }
- while (test_and_clear_attention_interrupt ());
- return (result);
-}
-
-static void
-write_scm_tqueue (tqueue_t * tqueue, msg_t * message)
-{
- write_std_tqueue (tqueue, message);
- request_attention_interrupt ();
-}
-\f
-void
-OS2_handle_attention_interrupt (void)
-{
- tqueue_t * tqueue = (QID_TQUEUE (OS2_interrupt_qid_local));
- while ((read_tqueue (tqueue, 0)) != 0)
- ;
- process_interrupt_messages ();
-}
-
-msg_avail_t
-OS2_scheme_tqueue_block (void)
-{
- int inputp = ((read_tqueue (OS2_scheme_tqueue, 1)) != 0);
- process_interrupt_messages ();
- return
- (inputp
- ? mat_available
- : (pending_interrupts_p ())
- ? mat_interrupt
- : mat_not_available);
-}
-
-static void
-process_interrupt_messages (void)
-{
- /* Reads all of the interrupts out of the interrupt queue, and sets
- the corresponding bits in the interrupt word. */
- while (1)
- {
- msg_t * message = (read_subqueue (OS2_interrupt_qid_local));
- if (message == 0)
- break;
- switch (MSG_TYPE (message))
- {
- case mt_console_interrupt:
- tty_set_next_interrupt_char (SM_CONSOLE_INTERRUPT_CODE (message));
- break;
- case mt_timer_event:
- request_timer_interrupt ();
- break;
- default:
- OS2_logic_error ("Illegal message type in interrupt queue.");
- break;
- }
- OS2_destroy_message (message);
- }
-}
-\f
-#define BUFFER_MIN_LENGTH 16
-
-typedef struct
-{
- unsigned int start;
- unsigned int end;
- unsigned int count;
- unsigned int buffer_length;
- void ** buffer;
-} msg_fifo_t;
-
-void *
-OS2_create_msg_fifo (void)
-{
- msg_fifo_t * fifo = (OS_malloc (sizeof (msg_fifo_t)));
- (fifo -> start) = 0;
- (fifo -> end) = 0;
- (fifo -> count) = 0;
- (fifo -> buffer_length) = BUFFER_MIN_LENGTH;
- (fifo -> buffer)
- = (OS_malloc ((fifo -> buffer_length) * (sizeof (void *))));
- return (fifo);
-}
-
-void
-OS2_destroy_msg_fifo (void * fp)
-{
- OS_free (((msg_fifo_t *) fp) -> buffer);
- OS_free (fp);
-}
-
-#define MAYBE_GROW_BUFFER(fifo) \
-{ \
- if ((fifo -> count) >= (fifo -> buffer_length)) \
- msg_fifo_grow (fifo); \
-}
-
-#define MAYBE_SHRINK_BUFFER(fifo) \
-{ \
- if (((fifo -> buffer_length) > BUFFER_MIN_LENGTH) \
- && ((fifo -> count) < ((fifo -> buffer_length) / 4))) \
- msg_fifo_shrink (fifo); \
-}
-
-#define REALLOC_BUFFER(fifo, new_length) \
-{ \
- ((fifo) -> buffer_length) = (new_length); \
- ((fifo) -> buffer) \
- = (OS_realloc (((fifo) -> buffer), \
- (((fifo) -> buffer_length) * (sizeof (void *))))); \
-}
-
-static void
-msg_fifo_grow (msg_fifo_t * fifo)
-{
- unsigned int old_length = (fifo -> buffer_length);
- REALLOC_BUFFER (fifo, (old_length * 2));
- if ((fifo -> end) <= (fifo -> start))
- {
- void ** from = (fifo -> buffer);
- void ** stop = ((fifo -> buffer) + (fifo -> end));
- void ** to = ((fifo -> buffer) + old_length);
- while (from < stop)
- (*to++) = (*from++);
- (fifo -> end) += old_length;
- }
-}
-
-static void
-msg_fifo_shrink (msg_fifo_t * fifo)
-{
- unsigned int new_length = ((fifo -> buffer_length) / 2);
- if ((fifo -> end) < (fifo -> start))
- {
- void ** from = ((fifo -> buffer) + (fifo -> start));
- void ** stop = ((fifo -> buffer) + (fifo -> buffer_length));
- void ** to = (from - new_length);
- while (from < stop)
- (*to++) = (*from++);
- (fifo -> start) -= new_length;
- }
- else if ((fifo -> end) > new_length)
- {
- void ** from = ((fifo -> buffer) + (fifo -> start));
- void ** stop = ((fifo -> buffer) + (fifo -> end));
- void ** to = (fifo -> buffer);
- while (from < stop)
- (*to++) = (*from++);
- (fifo -> end) -= (fifo -> start);
- (fifo -> start) = 0;
- }
- REALLOC_BUFFER (fifo, new_length);
-}
-
-void
-OS2_msg_fifo_insert (void * fp, void * element)
-{
- msg_fifo_t * fifo = fp;
- MAYBE_GROW_BUFFER (fifo);
- if ((fifo -> end) == (fifo -> buffer_length))
- (fifo -> end) = 0;
- ((fifo -> buffer) [(fifo -> end) ++]) = element;
- (fifo -> count) += 1;
-}
-
-void
-OS2_msg_fifo_insert_front (void * fp, void * element)
-{
- msg_fifo_t * fifo = fp;
- MAYBE_GROW_BUFFER (fifo);
- if ((fifo -> start) == 0)
- (fifo -> start) = (fifo -> buffer_length);
- ((fifo -> buffer) [-- (fifo -> start)]) = element;
- (fifo -> count) += 1;
-}
-
-void *
-OS2_msg_fifo_remove (void * fp)
-{
- msg_fifo_t * fifo = fp;
- void * element;
- if ((fifo -> count) == 0)
- return (0);
- element = ((fifo -> buffer) [(fifo -> start) ++]);
- if ((fifo -> start) == (fifo -> buffer_length))
- (fifo -> start) = 0;
- if ((-- (fifo -> count)) == 0)
- {
- (fifo -> start) = 0;
- (fifo -> end) = 0;
- }
- MAYBE_SHRINK_BUFFER (fifo);
- return (element);
-}
-
-void *
-OS2_msg_fifo_remove_last (void * fp)
-{
- msg_fifo_t * fifo = fp;
- void * element;
- if ((fifo -> count) == 0)
- return (0);
- element = ((fifo -> buffer) [-- (fifo -> end)]);
- if ((fifo -> end) == 0)
- (fifo -> end) = (fifo -> buffer_length);
- if ((-- (fifo -> count)) == 0)
- {
- (fifo -> start) = 0;
- (fifo -> end) = 0;
- }
- MAYBE_SHRINK_BUFFER (fifo);
- return (element);
-}
-
-void **
-OS2_msg_fifo_remove_all (void * fp)
-{
- msg_fifo_t * fifo = fp;
- void ** result = (OS_malloc (((fifo -> count) + 1) * (sizeof (void *))));
- void ** from = ((fifo -> buffer) + (fifo -> start));
- void ** stop;
- void ** to = result;
- if ((fifo -> start) < (fifo -> end))
- {
- stop = ((fifo -> buffer) + (fifo -> end));
- while (from < stop)
- (*to++) = (*from++);
- }
- else if ((fifo -> count) > 0)
- {
- stop = ((fifo -> buffer) + (fifo -> buffer_length));
- while (from < stop)
- (*to++) = (*from++);
- from = (fifo -> buffer);
- stop = ((fifo -> buffer) + (fifo -> end));
- while (from < stop)
- (*to++) = (*from++);
- }
- (*to) = 0;
- (fifo -> start) = 0;
- (fifo -> end) = 0;
- (fifo -> count) = 0;
- if ((fifo -> buffer_length) > BUFFER_MIN_LENGTH)
- REALLOC_BUFFER (fifo, BUFFER_MIN_LENGTH);
- return (result);
-}
-
-int
-OS2_msg_fifo_emptyp (void * fp)
-{
- msg_fifo_t * fifo = fp;
- return ((fifo -> count) == 0);
-}
-
-unsigned int
-OS2_msg_fifo_count (void * fp)
-{
- msg_fifo_t * fifo = fp;
- return (fifo -> count);
-}
-
-void *
-OS2_msg_fifo_last (void * fp)
-{
- msg_fifo_t * fifo = fp;
- return (((fifo -> count) == 0) ? 0 : ((fifo -> buffer) [(fifo -> end) - 1]));
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#ifndef SCM_OS2MSG_H
-#define SCM_OS2MSG_H
-\f
-typedef enum
-{
- /* This is sent to acknowledge that the other end of a qid pair has
- been opened. Sometimes it is necessary to wait until the
- connection is established before proceeding. */
- mt_init,
-
- /* This is sent by a "readahead" thread whenever it has some data to
- give to the other end of the connection. These messages are
- generated asynchronously whenever the readahead is available. */
- mt_readahead,
-
- /* This is sent by the receiver of a readahead message. It is used
- to regulate the amount of readahead in the connection.
- Typically, the readahead thread won't generate any more readahead
- messages until the readahead_ack is received. */
- mt_readahead_ack,
-
- /* This is a console interrupt event. It is generated automatically
- by the console readahead thread, and causes a Scheme character
- interrupt to be signalled in the interrupt-code register. */
- mt_console_interrupt,
-
- /* This is a timer interrupt event. It is generated automatically
- by the timer thread when the timer is active. */
- mt_timer_event,
-
- /* This event signals the termination of a child process. It is
- generated automatically by the thread that monitors child
- processes. */
- mt_child_death,
-
- /* These are error messages. They are sent as a reply to a request
- when an error is generated during the processing of the request. */
- mt_error,
- mt_syscall_error,
-
- /* This is a generic reply that is used to acknowledge requests that
- return no meaningful data other than that they have completed. */
- mt_generic_reply,
-
- /* This machine-generated file contains most of the PM message types. */
-#include "os2pm-mt.h"
-
- /* These are messages that command the PM thread to perform specific
- actions. A command that does not have a specific reply type will
- receive a generic reply when the PM code is configured to do
- handshaking; normally such a command has no reply. */
- mt_window_pos_request, /* request position of window's frame */
- mt_window_pos_reply,
- mt_window_size_request, /* request size of window's client area */
- mt_window_size_reply,
- mt_window_frame_size_request, /* request size of window's frame */
- mt_window_frame_size_reply,
-
- /* These are also PM thread commands, but they operate on
- presentation spaces rather than on windows. */
- mt_ps_set_bitmap_request, /* associate a bitmap with a memory PS */
- mt_ps_set_bitmap_reply,
-
- /* These are messages that are automatically generated by the PM
- thread when the corresponding events occur. */
- mt_pm_event, /* undecoded PM input event */
- mt_paint_event, /* window needs painting */
-
- /* This requests the thread on the other end of the connection to
- kill itself. At present this request is not used. */
- mt_kill_request,
- mt_supremum
-} msg_type_t;
-#define MSG_TYPE_SUP ((unsigned int) mt_supremum)
-#define MSG_TYPE_MAX (MSG_TYPE_SUP - 1)
-\f
-typedef unsigned char qid_t;
-#define QID_MAX (UCHAR_MAX - 1)
-#define QID_NONE UCHAR_MAX
-
-typedef unsigned short msg_length_t;
-#define MSG_LENGTH_MAX USHRT_MAX
-
-/* Fields of message header:
- type: msg_type_t identifying the type of message
- sender: qid identifying the message sender (used for replies)
- */
-
-#define DECLARE_MSG_HEADER_FIELDS \
- msg_type_t _msg_type; \
- qid_t _msg_sender
-
-typedef struct
-{
- DECLARE_MSG_HEADER_FIELDS;
-} msg_t;
-
-#define _MSG(m) ((msg_t *) (m))
-#define MSG_TYPE(m) ((_MSG (m)) -> _msg_type)
-#define MSG_SENDER(m) ((_MSG (m)) -> _msg_sender)
-
-typedef enum
-{
- tqt_std,
- tqt_scm,
- tqt_pm
-} tqueue_type_t;
-
-typedef struct
-{
- tqueue_type_t type;
-} tqueue_t;
-#define TQUEUE_TYPE(q) (((tqueue_t *) (q)) -> type)
-
-typedef msg_t * (* qid_receive_filter_t) (msg_t *);
-
-typedef enum { mat_not_available, mat_available, mat_interrupt } msg_avail_t;
-
-extern tqueue_t * OS2_scheme_tqueue;
-extern qid_t OS2_interrupt_qid;
-
-extern void OS2_make_qid_pair (qid_t *, qid_t *);
-extern void OS2_open_qid (qid_t, tqueue_t *);
-extern int OS2_qid_openp (qid_t);
-extern void OS2_close_qid (qid_t);
-extern tqueue_t * OS2_qid_tqueue (qid_t);
-extern qid_t OS2_qid_twin (qid_t);
-extern void OS2_close_qid_pair (qid_t);
-extern void OS2_set_qid_receive_filter (qid_t, qid_receive_filter_t);
-extern msg_length_t OS2_message_type_length (msg_type_t);
-extern void OS2_set_message_type_length (msg_type_t, msg_length_t);
-extern msg_t * OS2_create_message_1 (msg_type_t, msg_length_t);
-extern void OS2_destroy_message (msg_t *);
-extern void OS2_send_message (qid_t, msg_t *);
-extern msg_t * OS2_receive_message (qid_t, int, int);
-extern msg_avail_t OS2_message_availablep (qid_t, int);
-extern msg_t * OS2_wait_for_message (qid_t, msg_type_t);
-extern msg_t * OS2_message_transaction (qid_t, msg_t *, msg_type_t);
-extern void OS2_unread_message (qid_t, msg_t *);
-extern msg_avail_t OS2_scheme_tqueue_block (void);
-extern tqueue_t * OS2_make_std_tqueue (void);
-extern void OS2_close_std_tqueue (tqueue_t *);
-
-extern void * OS2_create_msg_fifo (void);
-void OS2_destroy_msg_fifo (void *);
-extern void OS2_msg_fifo_insert (void *, void *);
-extern void OS2_msg_fifo_insert_front (void *, void *);
-extern void * OS2_msg_fifo_remove (void *);
-extern void * OS2_msg_fifo_remove_last (void *);
-extern void ** OS2_msg_fifo_remove_all (void *);
-extern int OS2_msg_fifo_emptyp (void *);
-extern unsigned int OS2_msg_fifo_count (void *);
-extern void * OS2_msg_fifo_last (void *);
-\f
-#define MSG_LENGTH(m) (OS2_message_type_length (MSG_TYPE (m)))
-
-#define SET_MSG_TYPE_LENGTH(t, s) \
- OS2_set_message_type_length ((t), (sizeof (s)))
-
-#define OS2_create_message(type) OS2_create_message_1 ((type), 0)
-
-typedef struct
-{
- DECLARE_MSG_HEADER_FIELDS;
- int code;
-} sm_console_interrupt_t;
-#define SM_CONSOLE_INTERRUPT_CODE(m) (((sm_console_interrupt_t *) (m)) -> code)
-
-typedef msg_t sm_timer_event_t;
-typedef msg_t sm_init_t;
-typedef msg_t sm_generic_reply_t;
-
-#endif /* SCM_OS2MSG_H */
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#include "os2.h"
-
-static msg_t * input_pipe_reader (LHANDLE, qid_t, msg_t *, int *);
-static void input_pipe_operator
- (Tchannel, chop_t, choparg_t, choparg_t, choparg_t);
-\f
-void
-OS_make_pipe (Tchannel * readerp, Tchannel * writerp)
-{
- HFILE hread;
- HFILE hwrite;
- STD_API_CALL (dos_create_pipe, ((&hread), (&hwrite), 4096));
- transaction_begin ();
- OS2_handle_close_on_abort (hwrite);
- (*readerp) = (OS2_make_channel (hread, CHANNEL_READ));
- transaction_commit ();
- transaction_begin ();
- OS_channel_close_on_abort (*readerp);
- (*writerp) = (OS2_make_channel (hwrite, CHANNEL_WRITE));
- transaction_commit ();
-}
-
-void
-OS2_initialize_pipe_channel (Tchannel channel)
-{
- if (CHANNEL_INPUTP (channel))
- OS2_start_channel_thread (channel,
- input_pipe_reader,
- input_pipe_operator);
-}
-
-static msg_t *
-input_pipe_reader (LHANDLE handle, qid_t qid, msg_t * message, int * eofp)
-{
- ULONG nread;
- APIRET rc
- = (dos_read (handle,
- (SM_READAHEAD_DATA (message)),
- (sizeof (SM_READAHEAD_DATA (message))),
- (& nread)));
- if (rc == NO_ERROR)
- {
- (SM_READAHEAD_SIZE (message)) = nread;
- (*eofp) = (nread == 0);
- return (message);
- }
- OS2_destroy_message (message);
- if (rc == ERROR_INVALID_HANDLE)
- /* Handle was closed on us -- no need to do anything else. */
- return (0);
- (*eofp) = (rc == ERROR_BROKEN_PIPE);
- return (OS2_make_syscall_error (rc, syscall_dos_read));
-}
-
-static void
-input_pipe_operator (Tchannel channel, chop_t operation,
- choparg_t arg1, choparg_t arg2, choparg_t arg3)
-{
- switch (operation)
- {
- case chop_read:
- OS2_channel_thread_read_op (channel, arg1, arg2, arg3);
- break;
- case chop_close:
- OS2_channel_thread_close (channel);
- STD_API_CALL (dos_close, (CHANNEL_HANDLE (channel)));
- break;
- default:
- OS2_logic_error ("Unknown operation for input pipe.");
- break;
- }
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#define INCL_WIN
-#define INCL_GPI
-#include "os2.h"
-
-extern void add_reload_cleanup (void (*) (void));
-extern psid_t OS2_console_psid (void);
-extern void OS2_console_font_change_hook (font_metrics_t *);
-\f
-typedef enum { pst_window, pst_memory } pst_t;
-
-typedef struct _ps_t
-{
- psid_t id; /* psid for this ps */
- qid_t qid; /* qid to send commands to */
- HPS handle;
- COLOR foreground_color;
- COLOR background_color;
- pst_t visual_type; /* window or bitmap */
- void * visual; /* the associated window or bitmap */
- PLONG char_increments; /* character increments for outline fonts */
-} ps_t;
-#define PS_ID(ps) ((ps) -> id)
-#define PS_QID(ps) ((ps) -> qid)
-#define PS_HANDLE(ps) ((ps) -> handle)
-#define PS_FOREGROUND_COLOR(ps) ((ps) -> foreground_color)
-#define PS_BACKGROUND_COLOR(ps) ((ps) -> background_color)
-#define PS_VISUAL_TYPE(ps) ((ps) -> visual_type)
-#define PS_VISUAL(ps) ((ps) -> visual)
-#define PS_CHAR_INCREMENTS(ps) ((ps) -> char_increments)
-
-typedef struct _window_t
-{
- HWND frame; /* frame window handle */
- HWND client; /* client window handle */
- ps_t * client_ps; /* presentation space for client window */
- unsigned short grid_x; /* x dimension of resizing grid */
- unsigned short grid_y; /* y dimension of resizing grid */
- short cursor_x; /* x coordinate of the cursor */
- short cursor_y; /* y coordinate of the cursor */
- unsigned short cursor_width; /* width of the cursor */
- unsigned short cursor_height; /* height of the cursor */
- unsigned short cursor_style; /* style of the cursor */
- qid_t qid; /* qid to send commands to */
- qid_t event_qid; /* qid to send input events to */
- wid_t id; /* wid for this window */
- unsigned int cursor_createdp : 1; /* nonzero if cursor created */
- unsigned int cursor_enabledp : 1; /* nonzero if cursor enabled */
- unsigned int minimizingp : 1; /* nonzero if window being minimized */
- unsigned int minimizedp : 1; /* nonzero if window is minimized */
- unsigned int permanentp : 1; /* nonzero means don't close on reload */
- unsigned int mousetrackp : 1; /* nonzero means generate WM_MOUSEMOVE msgs */
-} window_t;
-#define WINDOW_FRAME(window) ((window) -> frame)
-#define WINDOW_CLIENT(window) ((window) -> client)
-#define WINDOW_CLIENT_PS(window) ((window) -> client_ps)
-#define WINDOW_GRID_X(window) ((window) -> grid_x)
-#define WINDOW_GRID_Y(window) ((window) -> grid_y)
-#define WINDOW_CURSOR_X(window) ((window) -> cursor_x)
-#define WINDOW_CURSOR_Y(window) ((window) -> cursor_y)
-#define WINDOW_CURSOR_WIDTH(window) ((window) -> cursor_width)
-#define WINDOW_CURSOR_HEIGHT(window) ((window) -> cursor_height)
-#define WINDOW_CURSOR_STYLE(window) ((window) -> cursor_style)
-#define WINDOW_QID(window) ((window) -> qid)
-#define WINDOW_EVENT_QID(window) ((window) -> event_qid)
-#define WINDOW_ID(window) ((window) -> id)
-#define WINDOW_CURSOR_CREATEDP(window) ((window) -> cursor_createdp)
-#define WINDOW_CURSOR_ENABLEDP(window) ((window) -> cursor_enabledp)
-#define WINDOW_MINIMIZINGP(window) ((window) -> minimizingp)
-#define WINDOW_MINIMIZEDP(window) ((window) -> minimizedp)
-#define WINDOW_PERMANENTP(window) ((window) -> permanentp)
-#define WINDOW_MOUSETRACKP(window) ((window) -> mousetrackp)
-
-typedef struct _bitmap_t
-{
- bid_t id; /* bid for this bitmap */
- qid_t qid; /* qid to send commands to */
- HBITMAP handle;
-} bitmap_t;
-#define BITMAP_ID(bitmap) ((bitmap) -> id)
-#define BITMAP_QID(bitmap) ((bitmap) -> qid)
-#define BITMAP_HANDLE(bitmap) ((bitmap) -> handle)
-
-typedef struct
-{
- tqueue_type_t type;
- HWND hwnd;
-} pm_tqueue_t;
-#define PM_TQUEUE_HWND(q) (((pm_tqueue_t *) (q)) -> hwnd)
-
-typedef struct
-{
- unsigned int length;
- void ** pointers;
-} id_table_t;
-#define ID_TABLE_LENGTH(table) ((table) -> length)
-#define ID_TABLE_POINTERS(table) ((table) -> pointers)
-\f
-/* This machine-generated file contains forward references and
- structure definitions for most of the procedures. */
-#include "os2pm-id.h"
-
-static void window_pos (window_t *, short *, short *);
-static void handle_window_pos_request (msg_t *);
-
-typedef struct
-{
- DECLARE_MSG_HEADER_FIELDS;
- window_t * window;
-} sm_pos_request_t;
-#define SM_POS_REQUEST_WINDOW(m) (((sm_pos_request_t *) (m)) -> window)
-
-typedef struct
-{
- DECLARE_MSG_HEADER_FIELDS;
- short x;
- short y;
-} sm_pos_reply_t;
-#define SM_POS_REPLY_X(m) (((sm_pos_reply_t *) (m)) -> x)
-#define SM_POS_REPLY_Y(m) (((sm_pos_reply_t *) (m)) -> y)
-
-static void window_size (window_t *, unsigned short *, unsigned short *);
-static void handle_window_size_request (msg_t *);
-
-typedef struct
-{
- DECLARE_MSG_HEADER_FIELDS;
- window_t * window;
-} sm_size_request_t;
-#define SM_SIZE_REQUEST_WINDOW(m) (((sm_size_request_t *) (m)) -> window)
-
-typedef struct
-{
- DECLARE_MSG_HEADER_FIELDS;
- unsigned short width;
- unsigned short height;
-} sm_size_reply_t;
-#define SM_SIZE_REPLY_WIDTH(m) (((sm_size_reply_t *) (m)) -> width)
-#define SM_SIZE_REPLY_HEIGHT(m) (((sm_size_reply_t *) (m)) -> height)
-
-static void window_frame_size
- (window_t *, unsigned short *, unsigned short *);
-static void handle_window_frame_size_request (msg_t *);
-
-typedef struct
-{
- DECLARE_MSG_HEADER_FIELDS;
- window_t * window;
-} sm_frame_size_request_t;
-#define SM_FRAME_SIZE_REQUEST_WINDOW(m) \
- (((sm_frame_size_request_t *) (m)) -> window)
-
-typedef struct
-{
- DECLARE_MSG_HEADER_FIELDS;
- unsigned short width;
- unsigned short height;
-} sm_frame_size_reply_t;
-#define SM_FRAME_SIZE_REPLY_WIDTH(m) \
- (((sm_frame_size_reply_t *) (m)) -> width)
-#define SM_FRAME_SIZE_REPLY_HEIGHT(m) \
- (((sm_frame_size_reply_t *) (m)) -> height)
-
-static void handle_ps_set_bitmap_request (msg_t *);
-static bitmap_t * ps_set_bitmap (ps_t *, bitmap_t *);
-
-typedef struct
-{
- DECLARE_MSG_HEADER_FIELDS;
- ps_t * ps;
- bitmap_t * bitmap;
-} sm_ps_set_bitmap_request_t;
-#define SM_PS_SET_BITMAP_REQUEST_PS(m) \
- (((sm_ps_set_bitmap_request_t *) (m)) -> ps)
-#define SM_PS_SET_BITMAP_REQUEST_BITMAP(m) \
- (((sm_ps_set_bitmap_request_t *) (m)) -> bitmap)
-
-typedef struct
-{
- DECLARE_MSG_HEADER_FIELDS;
- bitmap_t * bitmap;
-} sm_ps_set_bitmap_reply_t;
-#define SM_PS_SET_BITMAP_REPLY_BITMAP(m) \
- (((sm_ps_set_bitmap_reply_t *) (m)) -> bitmap)
-\f
-static void close_all_windows (void);
-
-static void sync_transaction (qid_t, msg_t *);
-static void sync_reply (qid_t);
-
-static void pm_thread_procedure (void *);
-static tqueue_t * make_pm_tqueue (HWND);
-
-static void initialize_id_table (id_table_t *);
-static unsigned int allocate_id (id_table_t *, void *);
-static void deallocate_id (id_table_t *, unsigned int);
-static void * id_to_pointer (id_table_t *, unsigned int);
-static int id_validp (id_table_t *, unsigned int);
-static ps_t * psid_to_ps (psid_t);
-static window_t * wid_to_window (wid_t);
-static bitmap_t * bid_to_bitmap (bid_t);
-
-static MRESULT EXPENTRY object_window_procedure (HWND, ULONG, MPARAM, MPARAM);
-static MRESULT EXPENTRY frame_window_procedure (HWND, ULONG, MPARAM, MPARAM);
-static MRESULT EXPENTRY window_procedure (HWND, ULONG, MPARAM, MPARAM);
-
-static window_t * hwnd_to_window (HWND);
-static msg_t * make_pm_event (wid_t, ULONG, MPARAM, MPARAM);
-static msg_t * make_paint_event
- (wid_t, unsigned short, unsigned short, unsigned short, unsigned short);
-
-static void recreate_cursor (window_t *);
-static void activate_cursor (window_t *);
-static void deactivate_cursor (window_t *);
-
-static window_t * make_window (qid_t, qid_t);
-
-static void win_create_cursor (HWND, LONG, LONG, LONG, LONG, ULONG, PRECTL);
-static void win_destroy_cursor (HWND);
-static void win_show_cursor (HWND, BOOL);
-static void recreate_cursor (window_t *);
-static void activate_cursor (window_t *);
-static void deactivate_cursor (window_t *);
-static void maybe_activate_cursor (ps_t *);
-static void maybe_deactivate_cursor (ps_t *);
-
-static HDC get_ps_device (HPS);
-static LONG get_device_capability (HDC, LONG);
-static ps_t * create_ps (pst_t, HDC, qid_t);
-static void destroy_ps (ps_t *);
-
-static int ps_set_font (ps_t *, unsigned short, const char *);
-static int parse_font_spec (const char *, PSZ *, LONG *, USHORT *);
-static const char * unparse_font_spec (PSZ, LONG, USHORT);
-static int ps_set_font_1 (ps_t * ps, PSZ, LONG, USHORT, LONG);
-static PLONG ps_make_char_increments (LONG);
-static int create_font (HPS, LONG, PFONTMETRICS, USHORT);
-static void copy_fontmetrics_to_fattrs (FONTMETRICS *, FATTRS *);
-static void ps_set_font_size (ps_t *, LONG);
-\f
-#define ID_FRAME 1
-
-#define UWM_ENCAPSULATION WM_USER
-
-#define QWP_WINDOW QWL_USER
-
-/* These should have been defined by PM header file. */
-#define MRVOID MRFROMP (0)
-#define MRTRUE MRFROMLONG (TRUE)
-#define MRFALSE MRFROMLONG (FALSE)
-
-static id_table_t psid_table;
-static id_table_t wid_table;
-static id_table_t bid_table;
-static qid_t pm_init_qid;
-TID OS2_pm_tid;
-static HAB pm_hab;
-static HMQ pm_hmq;
-static HWND pm_object_window;
-static tqueue_t * pm_tqueue;
-static PFNWP original_frame_window_procedure;
-static window_t * capture_window;
-
-static const char object_class [] = "mit-scheme.object";
-static const char window_class [] = "mit-scheme.window";
-
-#define SEND_EVENT(window, message) \
-{ \
- if ((WINDOW_EVENT_QID (window)) != QID_NONE) \
- OS2_send_message ((WINDOW_EVENT_QID (window)), (message)); \
-}
-
-#define SEND_PM_EVENT(hwnd, msg, mp1, mp2) \
-{ \
- window_t * window = (hwnd_to_window (hwnd)); \
- SEND_EVENT (window, \
- (make_pm_event ((WINDOW_ID (window)), msg, mp1, mp2))); \
-}
-
-#define window_error(name) window_error_1 (#name, 1)
-#define window_warning(name) window_error_1 (#name, 0)
-
-static void
-window_error_1 (const char * name, int fatalp)
-{
- char buffer [1024];
- ERRORID code = (WinGetLastError (pm_hab));
- if (fatalp)
- {
- sprintf (buffer, "Fatal error 0x%08x occurred in the %s procedure.",
- code, name);
- OS2_logic_error (buffer);
- }
- else
- {
- sprintf (buffer, "Non-fatal error 0x%08x occurred in the %s procedure. \
-This indicates a bug in the Scheme implementation. \
-Please report this information to a Scheme wizard.",
- code, name);
- (void) WinMessageBox (HWND_DESKTOP,
- NULLHANDLE,
- buffer,
- "Scheme Error",
- 0,
- (MB_OK | MB_WARNING));
- }
-}
-
-void
-OS2_initialize_pm_thread (void)
-{
- /* This machine-generated file contains code to initialize the
- message-type sizes for most of the procedure messages. */
-#include "os2pm-mi.h"
-
- SET_MSG_TYPE_LENGTH (mt_window_pos_request, sm_pos_request_t);
- SET_MSG_TYPE_LENGTH (mt_window_pos_reply, sm_pos_reply_t);
- SET_MSG_TYPE_LENGTH (mt_window_size_request, sm_size_request_t);
- SET_MSG_TYPE_LENGTH (mt_window_size_reply, sm_size_reply_t);
- SET_MSG_TYPE_LENGTH (mt_window_frame_size_request, sm_frame_size_request_t);
- SET_MSG_TYPE_LENGTH (mt_window_frame_size_reply, sm_frame_size_reply_t);
-
- SET_MSG_TYPE_LENGTH (mt_ps_set_bitmap_request, sm_ps_set_bitmap_request_t);
- SET_MSG_TYPE_LENGTH (mt_ps_set_bitmap_reply, sm_ps_set_bitmap_reply_t);
-
- SET_MSG_TYPE_LENGTH (mt_pm_event, sm_pm_event_t);
- SET_MSG_TYPE_LENGTH (mt_paint_event, sm_paint_event_t);
-
- initialize_id_table (& psid_table);
- initialize_id_table (& wid_table);
- initialize_id_table (& bid_table);
- original_frame_window_procedure = 0;
- capture_window = 0;
- {
- qid_t qid;
- OS2_make_qid_pair ((&pm_init_qid), (&qid));
- OS2_open_qid (qid, OS2_scheme_tqueue);
- OS2_pm_tid = (OS2_beginthread (pm_thread_procedure, 0, 0x8000));
- /* Wait for init message from PM thread. This message tells us
- that the other end of the connection is established and that it
- is safe to send messages on the connection. */
- OS2_destroy_message (OS2_wait_for_message (qid, mt_init));
- OS2_close_qid (qid);
- }
- add_reload_cleanup (close_all_windows);
-}
-
-static void
-close_all_windows (void)
-{
- window_t ** scan = ((window_t **) (ID_TABLE_POINTERS (& wid_table)));
- window_t ** end = (scan + (ID_TABLE_LENGTH (& wid_table)));
- while (scan < end)
- {
- window_t * window = (*scan++);
- if ((window != 0) && (!WINDOW_PERMANENTP (window)))
- window_close (window);
- }
-}
-\f
-/* Define this to cause a calling thread to wait for the PM thread to
- finish requests that have trivial replies. Otherwise, the calling
- thread waits only when the request has a non-trivial reply.
- Usually there is no good reason to wait for trivial replies, but
- this could be useful during debugging. */
-/* #define SYNC_SIMPLE_TRANSACTIONS */
-#ifdef SYNC_SIMPLE_TRANSACTIONS
-
-#define simple_transaction sync_transaction
-#define simple_reply sync_reply
-
-#else
-
-#define simple_transaction OS2_send_message
-#define simple_reply(qid)
-
-#endif
-
-static void
-sync_transaction (qid_t qid, msg_t * message)
-{
- OS2_destroy_message
- (OS2_message_transaction (qid, message, mt_generic_reply));
-}
-
-static void
-sync_reply (qid_t qid)
-{
- OS2_send_message (qid, (OS2_create_message (mt_generic_reply)));
-}
-
-/* These macros simplify the code needed to perform message
- transactions, by hiding the many type-casts needed. */
-
-#define CREATE_MESSAGE(mt) \
- ((void *) (OS2_create_message (mt)))
-
-#define CREATE_MESSAGE_1(mt, extra) \
- ((void *) (OS2_create_message_1 ((mt), (extra))))
-
-#define DESTROY_MESSAGE(msg) \
- OS2_destroy_message ((msg_t *) (msg))
-
-#define SEND_MESSAGE(qid, msg) \
- OS2_send_message ((qid), ((msg_t *) (msg)))
-
-#define SIMPLE_TRANSACTION(qid, msg) \
- simple_transaction ((qid), ((msg_t *) (msg)))
-
-#define SYNC_TRANSACTION(qid, msg) \
- sync_transaction ((qid), ((msg_t *) (msg)))
-
-#define MESSAGE_TRANSACTION(qid, msg, mt) \
- ((void *) (OS2_message_transaction ((qid), ((msg_t *) (msg)), (mt))))
-
-#define MEMCPY(to, from, length) \
- FASTCOPY (((const char *) (from)), ((char *) (to)), (length))
-
-#define STRCPY(to, from) \
- strcpy (((char *) (to)), (from))
-\f
-static void
-pm_thread_procedure (void * arg)
-{
- EXCEPTIONREGISTRATIONRECORD registration;
- QMSG qmsg;
-
- if ((OS2_thread_initialize_1 ((®istration), QID_NONE)) != 0)
- OS2_logic_error ("Error signalled within PM thread.");
- pm_hab = (WinInitialize (0));
- if (pm_hab == NULLHANDLE)
- window_error (WinInitialize);
- pm_hmq = (WinCreateMsgQueue (pm_hab, 1000));
- if (pm_hmq == NULLHANDLE)
- window_error (WinCreateMsgQueue);
- if (!WinRegisterClass (pm_hab,
- ((PSZ) object_class),
- object_window_procedure,
- 0, /* class style */
- 0))
- window_error (WinRegisterClass);
- if (!WinRegisterClass (pm_hab,
- ((PSZ) window_class),
- window_procedure,
- 0, /* class style */
- (sizeof (void *))))
- window_error (WinRegisterClass);
- pm_object_window
- = (WinCreateWindow (HWND_OBJECT,
- ((PSZ) object_class),
- "", /* text */
- 0, /* style */
- 0, 0, 0, 0, /* size and position */
- NULLHANDLE, /* owner */
- HWND_BOTTOM,
- 0, /* ID */
- 0, /* control data */
- 0 /* presentation parameters */
- ));
- if (pm_object_window == NULLHANDLE)
- window_error (WinCreateWindow);
- pm_tqueue = (make_pm_tqueue (pm_object_window));
- OS2_send_message (pm_init_qid, (OS2_create_message (mt_init)));
- while (WinGetMsg (pm_hab, (&qmsg), 0, 0, 0))
- WinDispatchMsg (pm_hab, (&qmsg));
- if (!WinDestroyWindow (pm_object_window))
- window_error (WinDestroyWindow);
- WinDestroyMsgQueue (pm_hmq);
- WinTerminate (pm_hab);
- /* There's no way to exit properly, because the normal exit depends
- on the PM thread being active enough to print the closing
- messages. So just use exit. */
- exit (1);
-}
-
-static tqueue_t *
-make_pm_tqueue (HWND hwnd)
-{
- tqueue_t * tqueue = (OS_malloc (sizeof (pm_tqueue_t)));
- (TQUEUE_TYPE (tqueue)) = tqt_pm;
- (PM_TQUEUE_HWND (tqueue)) = hwnd;
- return (tqueue);
-}
-
-msg_t *
-OS2_read_pm_tqueue (tqueue_t * tqueue, int blockp)
-{
- OS2_logic_error ("Read from PM tqueue.");
- return (0);
-}
-
-void
-OS2_write_pm_tqueue (tqueue_t * tqueue, msg_t * message)
-{
- if (!WinPostMsg ((PM_TQUEUE_HWND (tqueue)),
- UWM_ENCAPSULATION,
- (MPFROMP (message)),
- MPVOID))
- window_warning (WinPostMsg);
-}
-\f
-/* Object IDs
-
- These tables maintain data structures in the PM thread, and
- associate those structures with ID numbers that are given out to
- other threads (and to Scheme programs). */
-
-static void
-initialize_id_table (id_table_t * table)
-{
- unsigned int length = 16;
- void ** pointers = (OS_malloc ((sizeof (void *)) * length));
- void ** scan = pointers;
- void ** end = (scan + length);
- while (scan < end)
- (*scan++) = 0;
- (ID_TABLE_LENGTH (table)) = length;
- (ID_TABLE_POINTERS (table)) = pointers;
-}
-
-static unsigned int
-allocate_id (id_table_t * table, void * pointer)
-{
- unsigned int length = (ID_TABLE_LENGTH (table));
- void ** pointers = (ID_TABLE_POINTERS (table));
- void ** scan = (pointers + 1); /* don't allocate ID zero */
- void ** end = (pointers + length);
- while (scan < end)
- if ((*scan++) == 0)
- {
- (*--scan) = pointer;
- return (scan - pointers);
- }
- {
- unsigned int id = length;
- length *= 2;
- pointers = (OS_realloc (pointers, ((sizeof (void *)) * length)));
- scan = (pointers + id + 1);
- end = (pointers + length);
- while (scan < end)
- (*scan++) = 0;
- (ID_TABLE_LENGTH (table)) = length;
- (ID_TABLE_POINTERS (table)) = pointers;
- (pointers[id]) = pointer;
- return (id);
- }
-}
-
-static void
-deallocate_id (id_table_t * table, unsigned int id)
-{
- ((ID_TABLE_POINTERS (table)) [id]) = 0;
-}
-
-static void *
-id_to_pointer (id_table_t * table, unsigned int id)
-{
- void * pointer = ((ID_TABLE_POINTERS (table)) [id]);
- if (pointer == 0)
- OS2_logic_error ("Invalid PM ID.");
- return (pointer);
-}
-
-static int
-id_validp (id_table_t * table, unsigned int id)
-{
- return ((id > 0)
- && (id < (ID_TABLE_LENGTH (table)))
- && (((ID_TABLE_POINTERS (table)) [id]) != 0));
-}
-
-static ps_t *
-psid_to_ps (psid_t psid)
-{
- return (id_to_pointer ((& psid_table), psid));
-}
-
-static window_t *
-wid_to_window (wid_t wid)
-{
- return (id_to_pointer ((& wid_table), wid));
-}
-
-static bitmap_t *
-bid_to_bitmap (bid_t bid)
-{
- return (id_to_pointer ((& bid_table), bid));
-}
-\f
-/* Implementation of the object window. The object window handles
- encapsulated messages sent from the Scheme thread. This defines
- the protocol used to communicate with the Scheme thread. */
-
-static MRESULT EXPENTRY
-object_window_procedure (HWND window, ULONG msg, MPARAM mp1, MPARAM mp2)
-{
- if (msg == UWM_ENCAPSULATION)
- {
- msg_t * message = (PVOIDFROMMP (mp1));
- switch (MSG_TYPE (message))
- {
- /* This machine-generated file contains dispatch cases for
- most of the procedure messages. */
-#include "os2pm-dc.h"
-
- case mt_window_pos_request:
- handle_window_pos_request (message);
- break;
- case mt_window_size_request:
- handle_window_size_request (message);
- break;
- case mt_window_frame_size_request:
- handle_window_frame_size_request (message);
- break;
- case mt_ps_set_bitmap_request:
- handle_ps_set_bitmap_request (message);
- break;
-
- default:
- OS2_logic_error ("Unknown message type sent to PM thread.");
- break;
- }
- }
- return (MRVOID);
-}
-\f
-/* Implementation of the Frame Window */
-
-static MRESULT EXPENTRY
-frame_window_procedure (HWND hwnd, ULONG msg, MPARAM mp1, MPARAM mp2)
-{
- window_t * window = (hwnd_to_window (WinWindowFromID (hwnd, FID_CLIENT)));
- switch (msg)
- {
- case WM_QUERYTRACKINFO:
- /* Set the tracking grid for the resize operation. */
- {
- MRESULT mr
- = ((* original_frame_window_procedure) (hwnd, msg, mp1, mp2));
- if (mr == MRTRUE)
- {
- PTRACKINFO pti = (PVOIDFROMMP (mp2));
- if ((((pti -> fs) & TF_MOVE) != TF_MOVE)
- && ((((pti -> fs) & TF_MOVE) != 0)
- || (((pti -> fs) & TF_SETPOINTERPOS) != 0)))
- {
- (pti -> fs) |= TF_GRID;
- (pti -> cxGrid) = (WINDOW_GRID_X (window));
- (pti -> cyGrid) = (WINDOW_GRID_Y (window));
- (pti -> cxKeyboard) = (WINDOW_GRID_X (window));
- (pti -> cyKeyboard) = (WINDOW_GRID_Y (window));
- }
- }
- return (mr);
- }
- case WM_MINMAXFRAME:
- /* If minimizing, mark the window to indicate this. The client
- will shortly receive a WM_SIZE which indicates that the
- minimization has completed. */
- {
- PSWP pswp = (PVOIDFROMMP (mp1));
- if ((!WINDOW_MINIMIZEDP (window))
- && (((pswp -> fl) & SWP_MINIMIZE) != 0))
- {
- (WINDOW_MINIMIZINGP (window)) = 1;
- (WINDOW_MINIMIZEDP (window)) = 1;
- }
- else if ((WINDOW_MINIMIZEDP (window))
- && (((pswp -> fl) & (SWP_RESTORE | SWP_MAXIMIZE)) != 0))
- (WINDOW_MINIMIZEDP (window)) = 0;
- }
- break;
- }
- return ((* original_frame_window_procedure) (hwnd, msg, mp1, mp2));
-}
-\f
-/* Implementation of the Client Window */
-
-static MRESULT EXPENTRY
-window_procedure (HWND hwnd, ULONG msg, MPARAM mp1, MPARAM mp2)
-{
- switch (msg)
- {
- case WM_CREATE:
- {
- window_t * window = (PVOIDFROMMP (mp1));
- if (!WinSetWindowPtr (hwnd, QWP_WINDOW, window))
- window_error (WinSetWindowPtr);
- (WINDOW_CLIENT (window)) = hwnd;
- (WINDOW_CLIENT_PS (window))
- = (create_ps (pst_window,
- (WinOpenWindowDC (hwnd)),
- (WINDOW_QID (window))));
- (PS_VISUAL (WINDOW_CLIENT_PS (window))) = window;
- return (MRFALSE);
- }
- case WM_PAINT:
- {
- window_t * window = (hwnd_to_window (hwnd));
- if (((WinQueryWindowULong ((WINDOW_FRAME (window)), QWL_STYLE))
- & WS_MINIMIZED)
- != 0)
- break;
- {
- HPS hps = (PS_HANDLE (WINDOW_CLIENT_PS (window)));
- RECTL rectl;
- if ((WinBeginPaint ((WINDOW_CLIENT (window)), hps, (& rectl)))
- == NULLHANDLE)
- window_error (WinBeginPaint);
- if (!WinEndPaint (hps))
- window_error (WinEndPaint);
- SEND_EVENT (window,
- (make_paint_event ((WINDOW_ID (window)),
- (rectl . xLeft),
- (rectl . xRight),
- (rectl . yBottom),
- (rectl . yTop))));
- }
- return (MRVOID);
- }
- case WM_SETFOCUS:
- {
- window_t * window = (hwnd_to_window (hwnd));
- if (SHORT1FROMMP (mp2))
- recreate_cursor (window);
- else
- {
- win_destroy_cursor (WINDOW_CLIENT (window));
- (WINDOW_CURSOR_CREATEDP (window)) = 0;
- }
- }
- SEND_PM_EVENT (hwnd, msg, mp1, mp2);
- return (MRVOID);
- case WM_TRANSLATEACCEL:
- {
- PQMSG qmsg = (PVOIDFROMMP (mp1));
- USHORT flags = (SHORT1FROMMP (qmsg -> mp1));
- USHORT char_code = (SHORT1FROMMP (qmsg -> mp2));
- USHORT virtual_key = (SHORT2FROMMP (qmsg -> mp2));
- /* Disable specific default accelerator keys. */
- if ((flags & KC_VIRTUALKEY) != 0)
- switch (virtual_key)
- {
- case VK_ALT:
- case VK_ALTGRAF:
- /* Disable "Alt" keys, which normally pop up the system
- menu. These keys are used often in Edwin and the
- default behavior is unacceptable. */
- return (MRFALSE);
- case VK_SPACE:
- case VK_ESC:
- case VK_TAB:
- /* Disable "Alt-SPC", "Alt-ESC", and "Alt-TAB", which
- have standard key bindings in Edwin. */
- if ((flags & KC_ALT) != 0)
- return (MRFALSE);
- }
- else if ((flags & KC_CHAR) != 0)
- switch (char_code)
- {
- case ' ':
- case '\033':
- case '\t':
- /* Disable "Alt-SPC", "Alt-ESC", and "Alt-TAB", if for
- some reason they are reported as ASCII characters
- rather than as virtual keys. */
- if ((flags & KC_ALT) != 0)
- return (MRFALSE);
- }
- break;
- }
- case WM_DESTROY:
- {
- window_t * window = (hwnd_to_window (hwnd));
- destroy_ps (WINDOW_CLIENT_PS (window));
- (WINDOW_CLIENT_PS (window)) = 0;
- return (MRVOID);
- }
- case WM_SIZE:
- {
- window_t * window = (hwnd_to_window (hwnd));
- /* If this message is part of a minimization, ignore it. */
- if (WINDOW_MINIMIZINGP (window))
- {
- (WINDOW_MINIMIZINGP (window)) = 0;
- (WINDOW_MINIMIZEDP (window)) = 1;
- break;
- }
- if (WINDOW_CURSOR_CREATEDP (window))
- {
- win_destroy_cursor (WINDOW_CLIENT (window));
- (WINDOW_CURSOR_CREATEDP (window)) = 0;
- (WINDOW_CURSOR_X (window)) = 0;
- (WINDOW_CURSOR_Y (window)) = 0;
- recreate_cursor (window);
- }
- }
- SEND_PM_EVENT (hwnd, msg, mp1, mp2);
- return (MRVOID);
- case WM_CLOSE:
- case WM_COMMAND:
- case WM_CONTROL:
- case WM_HELP:
- case WM_SHOW:
- SEND_PM_EVENT (hwnd, msg, mp1, mp2);
- return (MRVOID);
- case WM_CHAR:
- case WM_BUTTON1DOWN:
- case WM_BUTTON1UP:
- case WM_BUTTON1CLICK:
- case WM_BUTTON1DBLCLK:
- case WM_BUTTON2DOWN:
- case WM_BUTTON2UP:
- case WM_BUTTON2CLICK:
- case WM_BUTTON2DBLCLK:
- case WM_BUTTON3DOWN:
- case WM_BUTTON3UP:
- case WM_BUTTON3CLICK:
- case WM_BUTTON3DBLCLK:
- SEND_PM_EVENT (hwnd, msg, mp1, mp2);
- return (MRTRUE);
- case WM_MOUSEMOVE:
- if (WINDOW_MOUSETRACKP (hwnd_to_window (hwnd)))
- {
- SEND_PM_EVENT (hwnd, msg, mp1, mp2);
- return (MRTRUE);
- }
- break;
- default:
- break;
- }
- return (WinDefWindowProc (hwnd, msg, mp1, mp2));
-}
-
-static window_t *
-hwnd_to_window (HWND hwnd)
-{
- window_t * window = (WinQueryWindowPtr (hwnd, QWP_WINDOW));
- if (window == 0)
- window_error (WinQueryWindowPtr);
- return (window);
-}
-
-static msg_t *
-make_pm_event (wid_t wid, ULONG msg, MPARAM mp1, MPARAM mp2)
-{
- msg_t * message = (OS2_create_message (mt_pm_event));
- (SM_PM_EVENT_WID (message)) = wid;
- (SM_PM_EVENT_MSG (message)) = msg;
- (SM_PM_EVENT_MP1 (message)) = mp1;
- (SM_PM_EVENT_MP2 (message)) = mp2;
- return (message);
-}
-
-static msg_t *
-make_paint_event (wid_t wid,
- unsigned short xl, unsigned short xh,
- unsigned short yl, unsigned short yh)
-{
- msg_t * message = (OS2_create_message (mt_paint_event));
- (SM_PAINT_EVENT_WID (message)) = wid;
- (SM_PAINT_EVENT_XL (message)) = xl;
- (SM_PAINT_EVENT_XH (message)) = xh;
- (SM_PAINT_EVENT_YL (message)) = yl;
- (SM_PAINT_EVENT_YH (message)) = yh;
- return (message);
-}
-
-int
-OS2_translate_wm_char (MPARAM mp1, MPARAM mp2,
- unsigned short * code,
- unsigned short * flags,
- unsigned char * repeat)
-{
- (*flags) = (SHORT1FROMMP (mp1));
- (*repeat) = (CHAR3FROMMP (mp1));
- /* Ignore compound keys for now. */
- if (((*flags) & (KC_DEADKEY | KC_COMPOSITE | KC_INVALIDCOMP | KC_KEYUP))
- != 0)
- return (0);
- if (((*flags) & KC_VIRTUALKEY) != 0)
- {
- (*code) = (SHORT2FROMMP (mp2));
- return (1);
- }
- if (((*flags) & (KC_CHAR | KC_CTRL | KC_ALT)) != 0)
- {
- (*code) = (SHORT1FROMMP (mp2));
- return (1);
- }
- return (0);
-}
-\f
-/* Direct Operations
-
- These are exported operations that can be implemented directly in
- the calling thread. Other operations that require communication
- with the PM thread appear on following pages. */
-
-int
-OS2_psid_validp (psid_t psid)
-{
- return (id_validp ((& psid_table), psid));
-}
-
-int
-OS2_wid_validp (wid_t wid)
-{
- return (id_validp ((& wid_table), wid));
-}
-
-int
-OS2_bid_validp (bid_t bid)
-{
- return (id_validp ((& bid_table), bid));
-}
-
-psid_t
-OS2_window_client_ps (wid_t wid)
-{
- return (PS_ID (WINDOW_CLIENT_PS (wid_to_window (wid))));
-}
-
-qid_t
-OS2_create_pm_qid (tqueue_t * tqueue)
-{
- qid_t pm_side;
- qid_t client_side;
- OS2_make_qid_pair ((&pm_side), (&client_side));
- OS2_open_qid (pm_side, pm_tqueue);
- OS2_open_qid (client_side, tqueue);
- return (client_side);
-}
-
-void
-OS2_window_permanent (wid_t wid)
-{
- (WINDOW_PERMANENTP (wid_to_window (wid))) = 1;
-}
-
-void
-OS2_window_mousetrack (wid_t wid, int trackp)
-{
- (WINDOW_MOUSETRACKP (wid_to_window (wid))) = trackp;
-}
-
-HWND
-OS2_window_frame_handle (wid_t wid)
-{
- return (WINDOW_FRAME (wid_to_window (wid)));
-}
-
-HWND
-OS2_window_client_handle (wid_t wid)
-{
- return (WINDOW_CLIENT (wid_to_window (wid)));
-}
-
-int
-OS2_memory_ps_p (psid_t psid)
-{
- return ((PS_VISUAL_TYPE (psid_to_ps (psid))) == pst_memory);
-}
-
-bid_t
-OS2_ps_get_bitmap (psid_t psid)
-{
- bitmap_t * bitmap = (PS_VISUAL (psid_to_ps (psid)));
- return ((bitmap == 0) ? BID_NONE : (BITMAP_ID (bitmap)));
-}
-\f
-/* Relayed Operations
-
- This page implements exported operations that require communication
- with the PM thread. The PM-thread-side of these operations appear
- on the following pages; this page implements only the mechanism to
- communicate the operation to the PM thread. The bulk of these
- communication procedures is machine-generated. */
-
-/* This macro supplies a NO-OP procedure needed by the
- machine-generated code for OS2_pm_synchronize. */
-#define pm_synchronize(qid)
-
-/* This machine-generated file contains most of the external procedure
- definitions, and their associated handler procedures. */
-#include "os2pm-rp.h"
-
-void
-OS2_window_pos (wid_t wid, short * x, short * y)
-{
- window_t * window = (wid_to_window (wid));
- msg_t * message = (OS2_create_message (mt_window_pos_request));
- (SM_POS_REQUEST_WINDOW (message)) = window;
- message
- = (OS2_message_transaction ((WINDOW_QID (window)),
- message,
- mt_window_pos_reply));
- (* x) = (SM_POS_REPLY_X (message));
- (* y) = (SM_POS_REPLY_Y (message));
- OS2_destroy_message (message);
-}
-
-static void
-handle_window_pos_request (msg_t * request)
-{
- qid_t sender = (MSG_SENDER (request));
- msg_t * reply = (OS2_create_message (mt_window_pos_reply));
- window_pos ((SM_POS_REQUEST_WINDOW (request)),
- (& (SM_POS_REPLY_X (reply))),
- (& (SM_POS_REPLY_Y (reply))));
- OS2_destroy_message (request);
- OS2_send_message (sender, reply);
-}
-
-void
-OS2_window_size (wid_t wid, unsigned short * width, unsigned short * height)
-{
- window_t * window = (wid_to_window (wid));
- msg_t * message = (OS2_create_message (mt_window_size_request));
- (SM_SIZE_REQUEST_WINDOW (message)) = window;
- message
- = (OS2_message_transaction ((WINDOW_QID (window)),
- message,
- mt_window_size_reply));
- (* width) = (SM_SIZE_REPLY_WIDTH (message));
- (* height) = (SM_SIZE_REPLY_HEIGHT (message));
- OS2_destroy_message (message);
-}
-
-static void
-handle_window_size_request (msg_t * request)
-{
- qid_t sender = (MSG_SENDER (request));
- msg_t * reply = (OS2_create_message (mt_window_size_reply));
- window_size ((SM_SIZE_REQUEST_WINDOW (request)),
- (& (SM_SIZE_REPLY_WIDTH (reply))),
- (& (SM_SIZE_REPLY_HEIGHT (reply))));
- OS2_destroy_message (request);
- OS2_send_message (sender, reply);
-}
-
-void
-OS2_window_frame_size (wid_t wid,
- unsigned short * width, unsigned short * height)
-{
- window_t * window = (wid_to_window (wid));
- msg_t * message = (OS2_create_message (mt_window_frame_size_request));
- (SM_FRAME_SIZE_REQUEST_WINDOW (message)) = window;
- message
- = (OS2_message_transaction ((WINDOW_QID (window)),
- message,
- mt_window_frame_size_reply));
- (* width) = (SM_FRAME_SIZE_REPLY_WIDTH (message));
- (* height) = (SM_FRAME_SIZE_REPLY_HEIGHT (message));
- OS2_destroy_message (message);
-}
-
-static void
-handle_window_frame_size_request (msg_t * request)
-{
- qid_t sender = (MSG_SENDER (request));
- msg_t * reply = (OS2_create_message (mt_window_frame_size_reply));
- window_frame_size ((SM_FRAME_SIZE_REQUEST_WINDOW (request)),
- (& (SM_FRAME_SIZE_REPLY_WIDTH (reply))),
- (& (SM_FRAME_SIZE_REPLY_HEIGHT (reply))));
- OS2_destroy_message (request);
- OS2_send_message (sender, reply);
-}
-
-bid_t
-OS2_ps_set_bitmap (psid_t psid, bid_t bid)
-{
- ps_t * ps = (psid_to_ps (psid));
- bitmap_t * bitmap = ((bid == BID_NONE) ? 0 : (bid_to_bitmap (bid)));
- msg_t * message = (OS2_create_message (mt_ps_set_bitmap_request));
- (SM_PS_SET_BITMAP_REQUEST_PS (message)) = ps;
- (SM_PS_SET_BITMAP_REQUEST_BITMAP (message)) = bitmap;
- message
- = (OS2_message_transaction ((PS_QID (ps)),
- message,
- mt_ps_set_bitmap_reply));
- bitmap = (SM_PS_SET_BITMAP_REPLY_BITMAP (message));
- OS2_destroy_message (message);
- return ((bitmap == 0) ? BID_NONE : (BITMAP_ID (bitmap)));
-}
-
-static void
-handle_ps_set_bitmap_request (msg_t * request)
-{
- qid_t sender = (MSG_SENDER (request));
- msg_t * reply = (OS2_create_message (mt_ps_set_bitmap_reply));
- (SM_PS_SET_BITMAP_REPLY_BITMAP (reply))
- = (ps_set_bitmap ((SM_PS_SET_BITMAP_REQUEST_PS (request)),
- (SM_PS_SET_BITMAP_REQUEST_BITMAP (request))));
- OS2_destroy_message (request);
- OS2_send_message (sender, reply);
-}
-
-font_metrics_t *
-OS2_ps_set_font (psid_t psid, unsigned short id, const char * name)
-{
- font_metrics_t * metrics = (OS2_ps_set_font_internal (psid, id, name));
- if ((metrics != 0) && (psid == (OS2_console_psid ())))
- OS2_console_font_change_hook (metrics);
- return (metrics);
-}
-\f
-/* PM-thread Operation Implementations
-
- All of the procedures from this point on are implementations of
- exported operations. These implementations are the code that is
- run in the PM thread to implement the operations that are invoked
- in other threads. */
-
-/* Windows */
-
-static wid_t
-window_open (qid_t qid, qid_t event_qid, ULONG flags, HMODULE module, ULONG id,
- ULONG style, const char * title)
-{
- window_t * window = (make_window (qid, event_qid));
- FRAMECDATA frame_data;
- HWND frame_window;
-
- (frame_data . cb) = (sizeof (frame_data));
- (frame_data . flCreateFlags) = flags;
- (frame_data . hmodResources) = module;
- (frame_data . idResources) = id;
- frame_window
- = (WinCreateWindow (HWND_DESKTOP,
- WC_FRAME,
- ((PSZ) title), /* title string */
- 0, /* window style */
- 0, 0, 0, 0, /* size and position */
- NULLHANDLE, /* owner window */
- HWND_TOP,
- ID_FRAME, /* window ID */
- (& frame_data),
- 0));
- if (frame_window == NULLHANDLE)
- window_error (WinCreateWindow);
- (WINDOW_FRAME (window)) = frame_window;
- {
- PFNWP procedure
- = (WinSubclassWindow (frame_window, frame_window_procedure));
- if (procedure == 0)
- window_error (WinSubclassWindow);
- if (original_frame_window_procedure == 0)
- original_frame_window_procedure = procedure;
- else if (original_frame_window_procedure != procedure)
- OS2_logic_error ("WinSubclassWindow returned two different answers.");
- }
- if ((WinCreateWindow (frame_window,
- ((PSZ) window_class),
- 0, /* window text (class-specific) */
- style, /* window style */
- 0, 0, 0, 0, /* size and position */
- frame_window, /* owner window */
- HWND_BOTTOM,
- FID_CLIENT, /* window ID */
- window,
- 0))
- == NULLHANDLE)
- window_error (WinCreateWindow);
- return (WINDOW_ID (window));
-}
-
-static window_t *
-make_window (qid_t qid, qid_t event_qid)
-{
- window_t * window = (OS_malloc (sizeof (window_t)));
- (WINDOW_FRAME (window)) = NULLHANDLE;
- (WINDOW_CLIENT (window)) = NULLHANDLE;
- (WINDOW_CLIENT_PS (window)) = 0;
- (WINDOW_GRID_X (window)) = 1;
- (WINDOW_GRID_Y (window)) = 1;
- (WINDOW_CURSOR_X (window)) = 0;
- (WINDOW_CURSOR_Y (window)) = 0;
- (WINDOW_CURSOR_WIDTH (window)) = 0;
- (WINDOW_CURSOR_HEIGHT (window)) = 0;
- (WINDOW_CURSOR_STYLE (window)) = (CURSOR_SOLID | CURSOR_FLASH);
- (WINDOW_QID (window)) = qid;
- (WINDOW_EVENT_QID (window)) = event_qid;
- (WINDOW_ID (window)) = (allocate_id ((& wid_table), window));
- (WINDOW_CURSOR_CREATEDP (window)) = 0;
- (WINDOW_CURSOR_ENABLEDP (window)) = 0;
- (WINDOW_MINIMIZINGP (window)) = 0;
- (WINDOW_MINIMIZEDP (window)) = 0;
- (WINDOW_PERMANENTP (window)) = 0;
- (WINDOW_MOUSETRACKP (window)) = 0;
- return (window);
-}
-
-static void
-window_close (window_t * window)
-{
- if (!WinDestroyWindow (WINDOW_FRAME (window)))
- window_warning (WinDestroyWindow);
- deallocate_id ((& wid_table), (WINDOW_ID (window)));
- OS_free (window);
-}
-
-static void
-window_show (window_t * window, int showp)
-{
- if (!WinShowWindow ((WINDOW_FRAME (window)), showp))
- window_warning (WinShowWindow);
-}
-
-static void
-window_scroll (window_t * window, short xl, short xh, short yl, short yh,
- short x_delta, short y_delta)
-{
- RECTL rectl;
- (rectl . xLeft) = xl;
- (rectl . xRight) = xh;
- (rectl . yBottom) = yl;
- (rectl . yTop) = yh;
- deactivate_cursor (window);
- if ((WinScrollWindow ((WINDOW_CLIENT (window)), x_delta, y_delta, (& rectl),
- 0, NULLHANDLE, 0, 0))
- == RGN_ERROR)
- window_warning (WinScrollWindow);
- activate_cursor (window);
-}
-
-static void
-window_invalidate (window_t * window, short xl, short xh, short yl, short yh)
-{
- RECTL rectl;
- (rectl . xLeft) = xl;
- (rectl . xRight) = xh;
- (rectl . yBottom) = yl;
- (rectl . yTop) = yh;
- if (!WinInvalidateRect ((WINDOW_CLIENT (window)), (& rectl), FALSE))
- window_warning (WinInvalidateRect);
-}
-
-static void
-window_set_grid (window_t * window, unsigned short x, unsigned short y)
-{
- (WINDOW_GRID_X (window)) = x;
- (WINDOW_GRID_Y (window)) = y;
-}
-
-static void
-window_activate (window_t * window)
-{
- if (!WinSetActiveWindow (HWND_DESKTOP, (WINDOW_FRAME (window))))
- window_warning (WinSetActiveWindow);
-}
-
-static void
-window_pos (window_t * window, short * x, short * y)
-{
- SWP swp;
- if (!WinQueryWindowPos ((WINDOW_FRAME (window)), (& swp)))
- window_error (WinQueryWindowPos);
- (* x) = (swp . x);
- (* y) = (swp . y);
-}
-
-static void
-window_set_pos (window_t * window, short x, short y)
-{
- if (!WinSetWindowPos ((WINDOW_FRAME (window)), NULLHANDLE, x, y,
- 0, 0, SWP_MOVE))
- window_warning (WinSetWindowPos);
-}
-
-static void
-window_size (window_t * window,
- unsigned short * width, unsigned short * height)
-{
- SWP swp;
- if (!WinQueryWindowPos ((WINDOW_CLIENT (window)), (& swp)))
- window_error (WinQueryWindowPos);
- (* width) = (swp . cx);
- (* height) = (swp . cy);
-}
-
-static void
-window_frame_size (window_t * window,
- unsigned short * width, unsigned short * height)
-{
- SWP swp;
- if (!WinQueryWindowPos ((WINDOW_FRAME (window)), (& swp)))
- window_error (WinQueryWindowPos);
- (* width) = (swp . cx);
- (* height) = (swp . cy);
-}
-
-static void
-window_set_size (window_t * window,
- unsigned short width, unsigned short height)
-{
- RECTL rcl;
- (rcl . xLeft) = 0;
- (rcl . xRight) = width;
- (rcl . yBottom) = 0;
- (rcl . yTop) = height;
- if (!WinMapWindowPoints ((WINDOW_CLIENT (window)), HWND_DESKTOP,
- ((PPOINTL) (& rcl)), 2))
- window_error (WinMapWindowPoints);
- if (!WinCalcFrameRect ((WINDOW_FRAME (window)), (& rcl), FALSE))
- window_error (WinCalcFrameRect);
- if (!WinSetWindowPos ((WINDOW_FRAME (window)),
- NULLHANDLE, 0, 0,
- ((rcl . xRight) - (rcl . xLeft)),
- ((rcl . yTop) - (rcl . yBottom)),
- SWP_SIZE))
- window_warning (WinSetWindowPos);
-}
-
-static int
-window_focusp (window_t * window)
-{
- return ((WINDOW_CLIENT (window)) == (WinQueryFocus (HWND_DESKTOP)));
-}
-
-static void
-window_set_state (window_t * window, window_state_t state)
-{
- ULONG op = 0;
- HWND behind = NULLHANDLE;
- switch (state)
- {
- case state_top:
- op = SWP_ZORDER;
- behind = HWND_TOP;
- break;
- case state_bottom:
- op = SWP_ZORDER;
- behind = HWND_BOTTOM;
- break;
- case state_show:
- op = SWP_SHOW;
- break;
- case state_hide:
- op = SWP_HIDE;
- break;
- case state_activate:
- op = SWP_ACTIVATE;
- break;
- case state_deactivate:
- op = SWP_DEACTIVATE;
- break;
- case state_minimize:
- op = SWP_MINIMIZE;
- break;
- case state_maximize:
- op = SWP_MAXIMIZE;
- break;
- case state_restore:
- op = SWP_RESTORE;
- break;
- }
- if (!WinSetWindowPos ((WINDOW_FRAME (window)), behind, 0, 0, 0, 0, op))
- window_warning (WinSetWindowPos);
-}
-
-static void
-window_set_title (window_t * window, const char * title)
-{
- if (!WinSetWindowText ((WINDOW_FRAME (window)), ((PSZ) title)))
- window_warning (WinSetWindowText);
-}
-
-static void
-window_update_frame (window_t * window, USHORT flags)
-{
- (void) WinSendMsg ((WINDOW_FRAME (window)), WM_UPDATEFRAME,
- (MPFROMSHORT (flags)),
- 0);
-}
-
-static HWND
-window_handle_from_id (qid_t qid, HWND window, ULONG id)
-{
- return (WinWindowFromID (window, id));
-}
-
-static BOOL
-window_set_capture (window_t * window, int capturep)
-{
- if (capturep)
- {
- if (capture_window == 0)
- {
- BOOL rc = (WinSetCapture (HWND_DESKTOP, (WINDOW_CLIENT (window))));
- if (rc)
- capture_window = window;
- return (rc);
- }
- else
- return (capture_window == window);
- }
- else
- {
- capture_window = 0;
- return (WinSetCapture (HWND_DESKTOP, NULLHANDLE));
- }
-}
-
-static LONG
-window_query_sys_value (qid_t qid, HWND window, LONG id)
-{
- LONG value = (WinQuerySysValue (window, id));
- if (value == 0)
- window_error (WinQuerySysValue);
- return (value);
-}
-\f
-/* Text Cursors */
-
-static void
-window_move_cursor (window_t * window, short x, short y)
-{
- (WINDOW_CURSOR_X (window)) = x;
- (WINDOW_CURSOR_Y (window)) = y;
- if (WINDOW_CURSOR_CREATEDP (window))
- win_create_cursor ((WINDOW_CLIENT (window)), x, y, 0, 0, CURSOR_SETPOS, 0);
-}
-
-static void
-window_shape_cursor (window_t * window, unsigned short width,
- unsigned short height, unsigned short style)
-{
- (WINDOW_CURSOR_WIDTH (window)) = width;
- (WINDOW_CURSOR_HEIGHT (window)) = height;
- (WINDOW_CURSOR_STYLE (window)) = style;
- if (WINDOW_CURSOR_CREATEDP (window))
- recreate_cursor (window);
-}
-
-static void
-window_show_cursor (window_t * window, int showp)
-{
- if ((WINDOW_CURSOR_CREATEDP (window))
- && ((showp != 0) != (WINDOW_CURSOR_ENABLEDP (window))))
- win_show_cursor ((WINDOW_CLIENT (window)), showp);
- (WINDOW_CURSOR_ENABLEDP (window)) = (showp != 0);
-}
-
-/* Helper Procedures */
-
-static void
-win_create_cursor (HWND client, LONG x, LONG y, LONG cx, LONG cy, ULONG fs,
- PRECTL clip_rectl)
-{
- if (!WinCreateCursor (client, x, y, cx, cy, fs, clip_rectl))
- window_warning (WinCreateCursor);
-}
-
-static void
-win_destroy_cursor (HWND client)
-{
- if (!WinDestroyCursor (client))
- window_warning (WinDestroyCursor);
-}
-
-static void
-win_show_cursor (HWND client, BOOL showp)
-{
- if (!WinShowCursor (client, showp))
- window_warning (WinShowCursor);
-}
-
-static void
-recreate_cursor (window_t * window)
-{
- win_create_cursor ((WINDOW_CLIENT (window)),
- (WINDOW_CURSOR_X (window)),
- (WINDOW_CURSOR_Y (window)),
- (WINDOW_CURSOR_WIDTH (window)),
- (WINDOW_CURSOR_HEIGHT (window)),
- (WINDOW_CURSOR_STYLE (window)),
- 0);
- (WINDOW_CURSOR_CREATEDP (window)) = 1;
- if (WINDOW_CURSOR_ENABLEDP (window))
- win_show_cursor ((WINDOW_CLIENT (window)), TRUE);
-}
-
-static void
-activate_cursor (window_t * window)
-{
- if ((WINDOW_CURSOR_CREATEDP (window)) && (WINDOW_CURSOR_ENABLEDP (window)))
- win_show_cursor ((WINDOW_CLIENT (window)), TRUE);
-}
-
-static void
-deactivate_cursor (window_t * window)
-{
- if ((WINDOW_CURSOR_CREATEDP (window)) && (WINDOW_CURSOR_ENABLEDP (window)))
- win_show_cursor ((WINDOW_CLIENT (window)), FALSE);
-}
-
-static void
-maybe_activate_cursor (ps_t * ps)
-{
- if ((PS_VISUAL_TYPE (ps)) == pst_window)
- activate_cursor (PS_VISUAL (ps));
-}
-
-static void
-maybe_deactivate_cursor (ps_t * ps)
-{
- if ((PS_VISUAL_TYPE (ps)) == pst_window)
- deactivate_cursor (PS_VISUAL (ps));
-}
-\f
-/* Presentation Spaces */
-
-static ps_t *
-create_memory_ps (qid_t qid)
-{
- HDC hdc = (DevOpenDC (pm_hab, OD_MEMORY, "*", 0, 0, NULLHANDLE));
- if (hdc == DEV_ERROR)
- window_error (DevOpenDC);
- return (create_ps (pst_memory, hdc, qid));
-}
-
-static void
-destroy_memory_ps (ps_t * ps)
-{
- HDC hdc = (get_ps_device (PS_HANDLE (ps)));
- bitmap_t * bitmap = (PS_VISUAL (ps));
- destroy_ps (ps);
- if ((hdc != NULLHANDLE) && ((DevCloseDC (hdc)) == DEV_ERROR))
- window_warning (DevCloseDC);
- if (bitmap != 0)
- destroy_bitmap (bitmap);
-}
-
-static bitmap_t *
-create_bitmap (ps_t * ps, USHORT width, USHORT height)
-{
- HPS hps = (PS_HANDLE (ps));
- HDC hdc = (get_ps_device (hps));
- BITMAPINFOHEADER2 header;
- HBITMAP hbm;
- bitmap_t * bitmap;
-
- memset ((& header), 0, (sizeof (header)));
- (header . cbFix) = (sizeof (header));
- (header . cx) = width;
- (header . cy) = height;
- (header . cPlanes) = (get_device_capability (hdc, CAPS_COLOR_PLANES));
- (header . cBitCount) = (get_device_capability (hdc, CAPS_COLOR_BITCOUNT));
- hbm = (GpiCreateBitmap (hps, (& header), 0, 0, 0));
- if (hbm == GPI_ERROR)
- window_error (GpiCreateBitmap);
- bitmap = (OS_malloc (sizeof (bitmap_t)));
- (BITMAP_ID (bitmap)) = (allocate_id ((& bid_table), bitmap));
- (BITMAP_QID (bitmap)) = (PS_QID (ps));
- (BITMAP_HANDLE (bitmap)) = hbm;
- return (bitmap);
-}
-
-static void
-destroy_bitmap (bitmap_t * bitmap)
-{
- if (!GpiDeleteBitmap (BITMAP_HANDLE (bitmap)))
- window_warning (GpiDeleteBitmap);
- deallocate_id ((& bid_table), (BITMAP_ID (bitmap)));
- OS_free (bitmap);
-}
-
-static bitmap_t *
-ps_set_bitmap (ps_t * ps, bitmap_t * bitmap)
-{
- bitmap_t * previous_bitmap = (PS_VISUAL (ps));
- if ((GpiSetBitmap ((PS_HANDLE (ps)),
- ((bitmap == 0) ? 0 : (BITMAP_HANDLE (bitmap)))))
- == HBM_ERROR)
- window_error (GpiSetBitmap);
- (PS_VISUAL (ps)) = bitmap;
- return (previous_bitmap);
-}
-
-static void
-ps_bitblt (ps_t * target, ps_t * source, LONG npoints, PPOINTL points,
- LONG rop, ULONG options)
-{
- maybe_deactivate_cursor (target);
- if ((GpiBitBlt ((PS_HANDLE (target)), (PS_HANDLE (source)), npoints, points,
- rop, options))
- == GPI_ERROR)
- window_warning (GpiBitBlt);
- maybe_activate_cursor (target);
-}
-
-static void
-ps_draw_text (ps_t * ps, short x, short y,
- const char * data, unsigned short size)
-{
- HPS hps = (PS_HANDLE (ps));
- PLONG increments = (PS_CHAR_INCREMENTS (ps));
- POINTL ptl;
- (ptl . x) = x;
- (ptl . y) = y;
- maybe_deactivate_cursor (ps);
- if (size <= 512)
- {
- if (increments == 0)
- GpiCharStringAt (hps, (& ptl), size, ((char *) data));
- else
- GpiCharStringPosAt (hps, (& ptl), 0, CHS_VECTOR, size, ((char *) data),
- increments);
- }
- else
- {
- const char * scan = data;
- GpiMove (hps, (& ptl));
- while (size > 0)
- {
- unsigned short n = ((size > 512) ? 512 : size);
- if (increments == 0)
- GpiCharString (hps, n, ((char *) scan));
- else
- GpiCharStringPos (hps, 0, CHS_VECTOR, n, ((char *) scan),
- increments);
- size -= n;
- scan += n;
- }
- }
- maybe_activate_cursor (ps);
-}
-
-static unsigned short
-ps_text_width (ps_t * ps, const char * data, unsigned short size)
-{
- if ((PS_CHAR_INCREMENTS (ps)) == 0)
- {
- POINTL points [TXTBOX_COUNT];
- if (!GpiQueryTextBox ((PS_HANDLE (ps)), size, ((char *) data),
- TXTBOX_COUNT, points))
- window_error (GpiQueryTextBox);
- return ((points [TXTBOX_CONCAT]) . x);
- }
- else
- return (size * ((PS_CHAR_INCREMENTS (ps)) [0]));
-}
-
-static void
-ps_clear (ps_t * ps, short xl, short xh, short yl, short yh)
-{
- RECTL rectl;
- (rectl . xLeft) = xl;
- (rectl . xRight) = xh;
- (rectl . yBottom) = yl;
- (rectl . yTop) = yh;
- maybe_deactivate_cursor (ps);
- if (!WinFillRect ((PS_HANDLE (ps)), (&rectl), (PS_BACKGROUND_COLOR (ps))))
- window_warning (WinFillRect);
- maybe_activate_cursor (ps);
-}
-
-static COLOR
-ps_get_foreground_color (ps_t * ps)
-{
- return (PS_FOREGROUND_COLOR (ps));
-}
-
-static COLOR
-ps_get_background_color (ps_t * ps)
-{
- return (PS_BACKGROUND_COLOR (ps));
-}
-
-static void
-ps_set_colors (ps_t * ps, COLOR foreground, COLOR background)
-{
- if (!GpiSetColor ((PS_HANDLE (ps)), foreground))
- window_warning (GpiSetColor);
- if (!GpiSetMix ((PS_HANDLE (ps)), FM_OVERPAINT))
- window_warning (GpiSetMix);
- if (!GpiSetBackColor ((PS_HANDLE (ps)), background))
- window_warning (GpiSetBackColor);
- if (!GpiSetBackMix ((PS_HANDLE (ps)), BM_OVERPAINT))
- window_warning (GpiSetBackMix);
- (PS_FOREGROUND_COLOR (ps)) = foreground;
- (PS_BACKGROUND_COLOR (ps)) = background;
-}
-
-static void
-ps_move_gcursor (ps_t * ps, short x, short y)
-{
- POINTL ptl;
- (ptl . x) = x;
- (ptl . y) = y;
- if (!GpiMove ((PS_HANDLE (ps)), (& ptl)))
- window_warning (GpiMove);
-}
-
-static void
-ps_draw_line (ps_t * ps, short x, short y)
-{
- POINTL ptl;
- (ptl . x) = x;
- (ptl . y) = y;
- if ((GpiLine ((PS_HANDLE (ps)), (& ptl))) == GPI_ERROR)
- window_warning (GpiLine);
-}
-
-static void
-ps_draw_point (ps_t * ps, short x, short y)
-{
- POINTL ptl;
- (ptl . x) = x;
- (ptl . y) = y;
- if ((GpiSetPel ((PS_HANDLE (ps)), (& ptl))) == GPI_ERROR)
- window_warning (GpiSetPel);
-}
-
-static void
-ps_poly_line (ps_t * ps, unsigned long npoints, PPOINTL points)
-{
- if ((GpiPolyLine ((PS_HANDLE (ps)), npoints, points)) == GPI_ERROR)
- window_warning (GpiPolyLine);
-}
-
-static void
-ps_poly_line_disjoint (ps_t * ps, unsigned long npoints, PPOINTL points)
-{
- if ((GpiPolyLineDisjoint ((PS_HANDLE (ps)), npoints, points))
- == GPI_ERROR)
- window_warning (GpiPolyLineDisjoint);
-}
-
-static void
-ps_set_line_type (ps_t * ps, LONG type)
-{
- if (!GpiSetLineType ((PS_HANDLE (ps)), type))
- window_warning (GpiSetLineType);
-}
-
-static void
-ps_set_mix (ps_t * ps, LONG mix)
-{
- if (!GpiSetMix ((PS_HANDLE (ps)), mix))
- window_warning (GpiSetMix);
-}
-
-static void
-ps_query_caps (ps_t * ps, LONG start, LONG count, PLONG values)
-{
- HDC hdc = (get_ps_device (PS_HANDLE (ps)));
- if (hdc == NULLHANDLE)
- window_error (GpiQueryDevice);
- if (!DevQueryCaps (hdc, start, count, values))
- window_error (DevQueryCaps);
-}
-
-static void
-ps_reset_clip_rectangle (ps_t * ps)
-{
- if (!GpiSetClipPath ((PS_HANDLE (ps)), 0, SCP_RESET))
- window_error (GpiSetClipPath);
-}
-
-static void
-ps_set_clip_rectangle (ps_t * ps, short xl, short xh, short yl, short yh)
-{
- HPS hps = (PS_HANDLE (ps));
- ps_reset_clip_rectangle (ps);
- if (!GpiBeginPath (hps, 1))
- window_error (GpiBeginPath);
- {
- POINTL points [4];
- ((points[0]) . x) = xl;
- ((points[0]) . y) = yl;
- ((points[1]) . x) = xl;
- ((points[1]) . y) = yh;
- ((points[2]) . x) = xh;
- ((points[2]) . y) = yh;
- ((points[3]) . x) = xh;
- ((points[3]) . y) = yl;
- if (!GpiMove (hps, (&points[3])))
- window_warning (GpiMove);
- if ((GpiPolyLine (hps, 4, points)) == GPI_ERROR)
- window_warning (GpiPolyLine);
- }
- if (!GpiEndPath (hps))
- window_error (GpiEndPath);
- if (!GpiSetClipPath (hps, 1, (SCP_AND | SCP_INCL)))
- window_error (GpiSetClipPath);
-}
-
-static void
-get_bitmap_parameters (bitmap_t * bitmap, PBITMAPINFOHEADER params)
-{
- if (!GpiQueryBitmapParameters ((BITMAP_HANDLE (bitmap)), params))
- window_error (GpiQueryBitmapParameters);
-}
-
-static unsigned long
-ps_get_bitmap_bits (ps_t * ps, unsigned long start, unsigned long length,
- PBYTE data, PBITMAPINFO2 info)
-{
- LONG r = (GpiQueryBitmapBits ((PS_HANDLE (ps)), start, length, data, info));
- if (r < 0)
- window_error (GpiQueryBitmapBits);
- return (r);
-}
-
-static unsigned long
-ps_set_bitmap_bits (ps_t * ps, unsigned long start, unsigned long length,
- PBYTE data, PBITMAPINFO2 info)
-{
- LONG r = (GpiSetBitmapBits ((PS_HANDLE (ps)), start, length, data, info));
- if (r < 0)
- window_error (GpiSetBitmapBits);
- return (r);
-}
-
-/* Helper Procedures */
-
-static HDC
-get_ps_device (HPS hps)
-{
- HDC hdc = (GpiQueryDevice (hps));
- if (hdc == HDC_ERROR)
- window_error (GpiQueryDevice);
- return (hdc);
-}
-
-static LONG
-get_device_capability (HDC hdc, LONG index)
-{
- LONG result;
- if (!DevQueryCaps (hdc, index, 1, (& result)))
- window_error (DevQueryCaps);
- return (result);
-}
-
-static ps_t *
-create_ps (pst_t type, HDC hdc, qid_t qid)
-{
- ps_t * ps = (OS_malloc (sizeof (ps_t)));
- SIZEL sizel;
- HPS hps;
- (sizel . cx) = 0;
- (sizel . cy) = 0;
- hps = (GpiCreatePS (pm_hab, hdc, (& sizel),
- (PU_PELS | GPIF_DEFAULT | GPIT_MICRO | GPIA_ASSOC)));
- if (hps == 0)
- window_error (GpiCreatePS);
- /* Put color table in RGB mode so we can specify colors
- directly in RGB values rather than as indices. */
- if (!GpiCreateLogColorTable (hps, LCOL_PURECOLOR, LCOLF_RGB, 0, 0, 0))
- window_warning (GpiCreateLogColorTable);
- (PS_HANDLE (ps)) = hps;
- (PS_ID (ps)) = (allocate_id ((& psid_table), ps));
- (PS_QID (ps)) = qid;
- (PS_VISUAL_TYPE (ps)) = type;
- (PS_VISUAL (ps)) = 0;
- (PS_CHAR_INCREMENTS (ps)) = 0;
- ps_set_colors (ps, RGB_BLACK, RGB_WHITE);
- return (ps);
-}
-
-static void
-destroy_ps (ps_t * ps)
-{
- if ((PS_CHAR_INCREMENTS (ps)) != 0)
- OS_free (PS_CHAR_INCREMENTS (ps));
- if (!GpiDestroyPS (PS_HANDLE (ps)))
- window_warning (GpiDestroyPS);
- deallocate_id ((& psid_table), (PS_ID (ps)));
- OS_free (ps);
-}
-\f
-/* Clipboard */
-
-static void
-clipboard_write_text (qid_t qid, const char * text)
-{
- unsigned int len = ((strlen (text)) + 1);
- PVOID shared_copy;
- int copy_used = 0;
-
- STD_API_CALL
- (dos_alloc_shared_mem,
- ((&shared_copy), 0, len,
- (PAG_COMMIT | PAG_READ | PAG_WRITE | OBJ_GIVEABLE)));
- FASTCOPY (text, ((char *) shared_copy), len);
-
- if (WinOpenClipbrd (pm_hab))
- {
- if (WinEmptyClipbrd (pm_hab))
- copy_used
- = (WinSetClipbrdData
- (pm_hab, ((ULONG) shared_copy), CF_TEXT, CFI_POINTER));
- (void) WinCloseClipbrd (pm_hab);
- }
- if (!copy_used)
- STD_API_CALL (dos_free_mem, (shared_copy));
-}
-
-static const char *
-clipboard_read_text (qid_t qid)
-{
- char * result = 0;
- if (WinOpenClipbrd (pm_hab))
- {
- const char * shared_copy
- = ((const char *) (WinQueryClipbrdData (pm_hab, CF_TEXT)));
- if (shared_copy != 0)
- {
- unsigned int len = ((strlen (shared_copy)) + 1);
- result = (OS_malloc (len));
- FASTCOPY (shared_copy, result, len);
- }
- (void) WinCloseClipbrd (pm_hab);
- }
- return (result);
-}
-\f
-/* Menus */
-
-static HWND
-menu_create (qid_t qid, HWND owner, USHORT style, USHORT id)
-{
- return
- (WinCreateWindow (owner, /* parent window */
- WC_MENU, /* class name */
- "", /* window text */
- style, /* window style */
- 0, 0, 0, 0, /* size and position */
- owner, /* owner window */
- HWND_TOP, /* sibling window */
- id, /* ID */
- 0, /* control data */
- 0 /* presentation parameters */
- ));
-}
-
-static BOOL
-menu_destroy (qid_t qid, HWND menu)
-{
- return (WinDestroyWindow (menu));
-}
-
-static USHORT
-menu_insert_item (qid_t qid, HWND menu, USHORT position, USHORT style,
- USHORT attributes, USHORT id, HWND submenu, char * text)
-{
- MENUITEM item;
- (item . iPosition) = position;
- (item . afStyle) = style;
- (item . afAttribute) = attributes;
- (item . id) = id;
- (item . hwndSubMenu) = submenu;
- (item . hItem) = 0;
- return (SHORT1FROMMR (WinSendMsg (menu, MM_INSERTITEM,
- (MPFROMP (&item)),
- (MPFROMP (text)))));
-}
-
-static USHORT
-menu_remove_item (qid_t qid, HWND menu, USHORT id, USHORT submenup,
- USHORT deletep)
-{
- return (SHORT1FROMMR (WinSendMsg (menu,
- (deletep ? MM_DELETEITEM : MM_REMOVEITEM),
- (MPFROM2SHORT (id, submenup)),
- 0)));
-}
-
-static PMENUITEM
-menu_get_item (qid_t qid, HWND menu, USHORT id, USHORT submenup)
-{
- PMENUITEM item = (OS_malloc (sizeof (MENUITEM)));
- if (LONGFROMMR (WinSendMsg (menu, MM_QUERYITEM,
- (MPFROM2SHORT (id, submenup)),
- (MPFROMP (item)))))
- return (item);
- OS_free (item);
- return (0);
-}
-
-static USHORT
-menu_n_items (qid_t qid, HWND menu)
-{
- return (SHORT1FROMMR (WinSendMsg (menu, MM_QUERYITEMCOUNT, 0, 0)));
-}
-
-static USHORT
-menu_nth_item_id (qid_t qid, HWND menu, USHORT position)
-{
- return (SHORT1FROMMR (WinSendMsg (menu, MM_ITEMIDFROMPOSITION,
- (MPFROMSHORT (position)),
- 0)));
-}
-
-static USHORT
-menu_get_item_attributes (qid_t qid, HWND menu, USHORT id, USHORT submenup,
- USHORT mask)
-{
- return (SHORT1FROMMR (WinSendMsg (menu, MM_QUERYITEMATTR,
- (MPFROM2SHORT (id, submenup)),
- (MPFROMSHORT (mask)))));
-}
-
-static BOOL
-menu_set_item_attributes (qid_t qid, HWND menu, USHORT id, USHORT submenup,
- USHORT mask, USHORT attributes)
-{
- return (LONGFROMMR (WinSendMsg (menu, MM_SETITEMATTR,
- (MPFROM2SHORT (id, submenup)),
- (MPFROM2SHORT (mask, attributes)))));
-}
-
-static HWND
-window_load_menu (window_t * window, HMODULE module, ULONG id)
-{
- return (WinLoadMenu ((WINDOW_FRAME (window)), module, id));
-}
-
-static BOOL
-window_popup_menu (qid_t qid, HWND parent, HWND owner, HWND menu,
- LONG x, LONG y, LONG id, ULONG options)
-{
- return (WinPopupMenu (parent, owner, menu, x, y, id, options));
-}
-\f
-/* Fonts */
-
-static font_metrics_t *
-ps_get_font_metrics (ps_t * ps)
-{
- font_metrics_t * metrics = (OS_malloc (sizeof (font_metrics_t)));
- FONTMETRICS fm;
- if (!GpiQueryFontMetrics ((PS_HANDLE (ps)), (sizeof (fm)), (& fm)))
- window_error (GpiQueryFontMetrics);
- (FONT_METRICS_WIDTH (metrics)) = (fm . lMaxCharInc);
- (FONT_METRICS_HEIGHT (metrics)) = (fm . lMaxBaselineExt);
- (FONT_METRICS_DESCENDER (metrics)) = (fm . lMaxDescender);
- return (metrics);
-}
-
-static font_metrics_t *
-ps_set_font_internal (ps_t * ps, unsigned short id, const char * spec)
-{
- return ((ps_set_font (ps, id, spec)) ? (ps_get_font_metrics (ps)) : 0);
-}
-
-static const char *
-window_font_dialog (window_t * window, const char * title)
-{
- ps_t * ps = (WINDOW_CLIENT_PS (window));
- HPS hps = (PS_HANDLE (ps));
- FONTDLG info;
- char name_buffer [FACESIZE];
- HWND result;
-
- memset ((&info), 0, (sizeof (info)));
- (name_buffer[0]) = '\0';
- (info . cbSize) = (sizeof (info));
- (info . hpsScreen) = hps;
- (info . pszTitle) = ((PSZ) title);
- (info . fl) = (FNTS_FIXEDWIDTHONLY | FNTS_CENTER); /* FNTS_INITFROMFATTRS */
- (info . pszFamilyname) = name_buffer;
- (info . usFamilyBufLen) = (sizeof (name_buffer));
- /* Because our PS is in RGB mode, the RGB color specs we are using
- are useless. It's undocumented, but only indexed colors work in
- the font dialog, so we must override with indexes. */
- (info . clrFore) = CLR_BLACK; /* (PS_FOREGROUND_COLOR (ps)) */
- (info . clrBack) = CLR_WHITE; /* (PS_BACKGROUND_COLOR (ps)) */
- {
- FONTMETRICS fm;
- if (GpiQueryFontMetrics (hps, (sizeof (fm)), (&fm)))
- {
- strcpy (name_buffer, (fm . szFamilyname));
- (info . usWeight) = (fm . usWeightClass);
- (info . usWidth) = (fm . usWidthClass);
- (info . fxPointSize)
- = (MAKEFIXED (((fm . sNominalPointSize) / 10), 0));
- (info . flStyle) = (fm . fsSelection);
- copy_fontmetrics_to_fattrs ((&fm), (& (info . fAttrs)));
-#if 0
- /* The following, for some unknown reason, causes the
- selection of incorrect fonts: */
- (info . fl) |= FNTS_INITFROMFATTRS;
-#endif
- }
- }
- result = (WinFontDlg (HWND_DESKTOP, (WINDOW_CLIENT (window)), (&info)));
- if ((result == NULLHANDLE) || ((info . lReturn) != DID_OK))
- return (0);
- {
- PSZ face_name;
- const char * font_spec;
- {
- FACENAMEDESC desc;
- ULONG face_name_length;
- char face_name_dummy [1];
- memset ((&desc), 0, (sizeof (desc)));
- (desc . usSize) = (sizeof (desc));
- (desc . usWeightClass) = (info . usWeight);
- (desc . usWidthClass) = (info . usWidth);
- (desc . flOptions) = (info . flType);
- face_name = face_name_dummy;
- face_name_length
- = (GpiQueryFaceString (hps, (info . pszFamilyname), (&desc),
- 0, face_name));
- if (face_name_length == GPI_ERROR)
- {
- window_warning (GpiQueryFaceString);
- return (0);
- }
- face_name = (OS_malloc (face_name_length));
- face_name_length
- = (GpiQueryFaceString (hps, (info . pszFamilyname), (&desc),
- face_name_length, face_name));
- if (face_name_length == GPI_ERROR)
- {
- OS_free (face_name);
- window_warning (GpiQueryFaceString);
- return (0);
- }
- }
- font_spec = (unparse_font_spec (face_name,
- ((FIXEDINT (info . fxPointSize)) * 10),
- (info . flStyle)));
- OS_free (face_name);
- return (font_spec);
- }
-}
-
-/* Helper Procedures */
-
-static int
-ps_set_font (ps_t * ps, unsigned short id, const char * spec)
-{
- PSZ name = 0;
- LONG size;
- USHORT selection;
- if (!parse_font_spec (spec, (& name), (& size), (& selection)))
- return (0);
- if (!ps_set_font_1 (ps, name, size, selection, id))
- {
- OS_free (name);
- return (0);
- }
- {
- FONTMETRICS fm;
- if (!GpiQueryFontMetrics ((PS_HANDLE (ps)), (sizeof (fm)), (& fm)))
- window_error (GpiQueryFontMetrics);
- if ((PS_CHAR_INCREMENTS (ps)) != 0)
- OS_free (PS_CHAR_INCREMENTS (ps));
- (PS_CHAR_INCREMENTS (ps))
- = ((((fm . fsDefn) & FM_DEFN_OUTLINE) != 0)
- ? (ps_make_char_increments (fm . lMaxCharInc))
- : 0);
- }
- return (1);
-}
-
-static int
-ps_set_font_1 (ps_t * ps, PSZ name, LONG size, USHORT selection, LONG id)
-{
- HPS hps = (PS_HANDLE (ps));
- LONG nfonts;
- ULONG index;
- PFONTMETRICS pfm;
-
- nfonts = 0;
- nfonts = (GpiQueryFonts (hps,
- (QF_PUBLIC | QF_PRIVATE),
- name,
- (& nfonts),
- (sizeof (FONTMETRICS)),
- 0));
- if (nfonts == GPI_ALTERROR)
- window_error (GpiQueryFonts);
- if (nfonts == 0)
- return (0);
- pfm = (OS_malloc (nfonts * (sizeof (FONTMETRICS))));
- if ((GpiQueryFonts (hps,
- (QF_PUBLIC | QF_PRIVATE),
- name,
- (& nfonts),
- (sizeof (FONTMETRICS)),
- pfm))
- == GPI_ALTERROR)
- window_error (GpiQueryFonts);
- {
- int result = 0;
- /* Choose an image font if one is available. */
- for (index = 0; (index < nfonts); index += 1)
- if (((((pfm [index]) . fsType) & FM_TYPE_FIXED) != 0)
- && ((((pfm [index]) . fsDefn) & FM_DEFN_OUTLINE) == 0)
- && (((pfm [index]) . sNominalPointSize) == size)
- && (create_font (hps, id, (& (pfm [index])), selection)))
- {
- GpiSetCharSet (hps, id);
- result = 1;
- goto done;
- }
- /* Otherwise, look for an outline font. */
- for (index = 0; (index < nfonts); index += 1)
- if (((((pfm [index]) . fsType) & FM_TYPE_FIXED) != 0)
- && ((((pfm [index]) . fsDefn) & FM_DEFN_OUTLINE) != 0)
- && (create_font (hps, id, (& (pfm [index])), selection)))
- {
- GpiSetCharSet (hps, id);
- ps_set_font_size (ps, size);
- result = 1;
- goto done;
- }
- done:
- OS_free (pfm);
- return (result);
- }
-}
-
-static int
-create_font (HPS hps, LONG font_id, PFONTMETRICS pfm, USHORT selection)
-{
- FATTRS fa;
- copy_fontmetrics_to_fattrs (pfm, (&fa));
- (fa . fsSelection) = selection;
- return ((GpiCreateLogFont (hps, 0, font_id, (&fa))) == FONT_MATCH);
-}
-
-static void
-copy_fontmetrics_to_fattrs (FONTMETRICS * pfm, FATTRS * pfa)
-{
- (pfa -> usRecordLength) = (sizeof (*pfa));
- (pfa -> fsSelection) = (pfm -> fsSelection);
- (pfa -> lMatch) = (pfm -> lMatch);
- strcpy ((pfa -> szFacename), (pfm -> szFacename));
- (pfa -> idRegistry) = (pfm -> idRegistry);
- (pfa -> usCodePage) = (pfm -> usCodePage);
- (pfa -> fsType) = 0;
- if (((pfm -> fsDefn) & FM_DEFN_OUTLINE) != 0)
- {
- (pfa -> lMaxBaselineExt) = 0;
- (pfa -> lAveCharWidth) = 0;
- (pfa -> fsFontUse)
- = (FATTR_FONTUSE_OUTLINE | FATTR_FONTUSE_TRANSFORMABLE);
- }
- else
- {
- (pfa -> lMaxBaselineExt) = (pfm -> lMaxBaselineExt);
- (pfa -> lAveCharWidth) = (pfm -> lAveCharWidth);
- (pfa -> fsFontUse) = 0;
- }
-}
-
-static void
-ps_set_font_size (ps_t * ps, LONG size)
-{
- POINTL ptl [2];
-
- ((ptl[0]) . x) = 0;
- ((ptl[0]) . y) = 0;
- {
- LONG xres;
- ps_query_caps (ps, CAPS_HORIZONTAL_FONT_RES, 1, (&xres));
- ((ptl[1]) . x) = ((((xres * size) << 4) + 360) / 720);
- }
- {
- LONG yres;
- ps_query_caps (ps, CAPS_VERTICAL_FONT_RES, 1, (&yres));
- ((ptl[1]) . y) = ((((yres * size) << 4) + 360) / 720);
- }
- if (!GpiConvert ((PS_HANDLE (ps)), CVTC_DEVICE, CVTC_WORLD, 2, ptl))
- window_error (GpiConvert);
- {
- SIZEF s;
- (s . cx) = ((((ptl[1]) . x) - ((ptl[0]) . x)) << 12);
- (s . cy) = ((((ptl[1]) . y) - ((ptl[0]) . y)) << 12);
- if (!GpiSetCharBox ((PS_HANDLE (ps)), (&s)))
- window_error (GpiSetCharBox);
- }
-}
-
-static PLONG
-ps_make_char_increments (LONG increment)
-{
- PLONG increments = (OS_malloc ((sizeof (LONG)) * 512));
- unsigned int index;
- for (index = 0; (index < 512); index += 1)
- (increments[index]) = increment;
- return (increments);
-}
-
-static struct font_selection
-{
- const char * name;
- unsigned int selector;
-} font_selections [] =
-{
- { ".bold", FATTR_SEL_BOLD },
- { ".italic", FATTR_SEL_ITALIC },
- { ".outline", FATTR_SEL_OUTLINE },
- { ".strikeout", FATTR_SEL_STRIKEOUT },
- { ".underscore", FATTR_SEL_UNDERSCORE },
- { 0, 0 }
-};
-
-static int
-parse_font_spec (const char * spec,
- PSZ * pname, LONG * psize, USHORT * pselection)
-{
- const char * scan = spec;
- unsigned int size = 0;
- unsigned int selection = 0;
- while (('0' <= (*scan)) && ((*scan) <= '9'))
- size = ((size * 10) + ((*scan++) - '0'));
- if (size == 0)
- return (0);
- while (1)
- {
- struct font_selection * selections = font_selections;
- unsigned int name_length;
- while (1)
- {
- if ((selections -> name) == 0)
- goto no_more_selections;
- name_length = (strlen (selections -> name));
- if ((strncmp (scan, (selections -> name), name_length)) == 0)
- {
- selection |= (selections -> selector);
- scan += name_length;
- break;
- }
- selections += 1;
- }
- }
- no_more_selections:
- if ((*scan++) != '.')
- return (0);
- (*pname) = (OS_malloc ((strlen (scan)) + 1));
- strcpy ((*pname), scan);
- (*psize) = (size * 10);
- (*pselection) = selection;
- return (1);
-}
-
-static const char *
-unparse_font_spec (PSZ name, LONG size, USHORT selection)
-{
- char size_buffer [16];
- char selection_buffer [16];
- struct font_selection * selections = font_selections;
- char * result;
-
- sprintf (size_buffer, "%d", (size / 10));
- strcpy (selection_buffer, "");
- while (1)
- {
- if ((selections -> name) == 0)
- break;
- if ((selection & (selections -> selector)) != 0)
- strcat (selection_buffer, (selections -> name));
- selections += 1;
- }
- result
- = (OS_malloc ((strlen (size_buffer))
- + (strlen (name))
- + (strlen (selection_buffer))
- + 2));
- strcpy (result, size_buffer);
- strcat (result, selection_buffer);
- strcat (result, ".");
- strcat (result, name);
- return (result);
-}
-\f
-/* Pointers and Icons */
-
-static HPOINTER
-query_system_pointer (qid_t qid, HWND desktop, LONG id, BOOL copyp)
-{
- return (WinQuerySysPointer (desktop, id, copyp));
-}
-
-static BOOL
-set_pointer (qid_t qid, HWND desktop, HPOINTER pointer)
-{
- return (WinSetPointer (desktop, pointer));
-}
-
-static HPOINTER
-window_load_pointer (qid_t qid, HWND desktop, HMODULE module, ULONG id)
-{
- return (WinLoadPointer (desktop, module, id));
-}
-
-static BOOL
-window_destroy_pointer (qid_t qid, HPOINTER pointer)
-{
- return (WinDestroyPointer (pointer));
-}
-
-static BOOL
-window_set_icon (window_t * window, HPOINTER icon)
-{
- return (LONGFROMMR (WinSendMsg ((WINDOW_FRAME (window)), WM_SETICON,
- (MPFROMLONG (icon)),
- (MPFROMLONG (0)))));
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#ifndef SCM_OS2PM_H
-#define SCM_OS2PM_H
-\f
-typedef unsigned short psid_t;
-#define PSID_NONE 0
-
-typedef unsigned short wid_t;
-#define WID_NONE 0
-
-typedef unsigned short bid_t;
-#define BID_NONE 0
-
-typedef struct
-{
- unsigned short width;
- unsigned short height;
- unsigned short descender;
-} font_metrics_t;
-#define FONT_METRICS_WIDTH(m) ((m) -> width)
-#define FONT_METRICS_HEIGHT(m) ((m) -> height)
-#define FONT_METRICS_DESCENDER(m) ((m) -> descender)
-
-typedef struct
-{
- DECLARE_MSG_HEADER_FIELDS;
- wid_t wid;
- ULONG msg;
- MPARAM mp1;
- MPARAM mp2;
-} sm_pm_event_t;
-#define SM_PM_EVENT_WID(m) (((sm_pm_event_t *) (m)) -> wid)
-#define SM_PM_EVENT_MSG(m) (((sm_pm_event_t *) (m)) -> msg)
-#define SM_PM_EVENT_MP1(m) (((sm_pm_event_t *) (m)) -> mp1)
-#define SM_PM_EVENT_MP2(m) (((sm_pm_event_t *) (m)) -> mp2)
-
-typedef struct
-{
- DECLARE_MSG_HEADER_FIELDS;
- wid_t wid;
- unsigned short xl;
- unsigned short xh;
- unsigned short yl;
- unsigned short yh;
-} sm_paint_event_t;
-#define SM_PAINT_EVENT_WID(m) (((sm_paint_event_t *) (m)) -> wid)
-#define SM_PAINT_EVENT_XL(m) (((sm_paint_event_t *) (m)) -> xl)
-#define SM_PAINT_EVENT_XH(m) (((sm_paint_event_t *) (m)) -> xh)
-#define SM_PAINT_EVENT_YL(m) (((sm_paint_event_t *) (m)) -> yl)
-#define SM_PAINT_EVENT_YH(m) (((sm_paint_event_t *) (m)) -> yh)
-\f
-typedef enum
-{
- state_top,
- state_bottom,
- state_show,
- state_hide,
- state_activate,
- state_deactivate,
- state_minimize,
- state_maximize,
- state_restore,
- state_supremum
-} window_state_t;
-
-extern msg_t * OS2_read_pm_tqueue (tqueue_t *, int);
-extern void OS2_write_pm_tqueue (tqueue_t *, msg_t *);
-
-/* This machine-generated file contains most of the procedure prototypes. */
-#include "os2pm-ed.h"
-
-extern int OS2_psid_validp (psid_t);
-extern int OS2_wid_validp (wid_t);
-extern int OS2_bid_validp (bid_t);
-extern psid_t OS2_window_client_ps (wid_t);
-extern qid_t OS2_create_pm_qid (tqueue_t *);
-extern void OS2_window_permanent (wid_t);
-extern void OS2_window_mousetrack (wid_t, int);
-extern HWND OS2_window_frame_handle (wid_t);
-extern HWND OS2_window_client_handle (wid_t);
-extern int OS2_memory_ps_p (psid_t);
-extern bid_t OS2_ps_get_bitmap (psid_t);
-
-extern void OS2_window_pos (wid_t, short *, short *);
-extern void OS2_window_size (wid_t, unsigned short *, unsigned short *);
-extern void OS2_window_frame_size (wid_t, unsigned short *, unsigned short *);
-extern bid_t OS2_ps_set_bitmap (psid_t, bid_t);
-extern font_metrics_t * OS2_ps_set_font (psid_t, unsigned short, const char *);
-
-extern int OS2_translate_wm_char
- (MPARAM, MPARAM, unsigned short *, unsigned short *, unsigned char *);
-
-#endif /* SCM_OS2PM_H */
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Program to generate OS/2 PM interface code.
-
-;;; The Scheme OS/2 Presentation Manager interface is implemented in
-;;; its own thread, which means that all operations involving the
-;;; interface must by encoded into messages and communicated to the PM
-;;; thread through its message queue. This is reasonably
-;;; straightforward, but the overhead for implementing a single
-;;; operation is daunting: in addition to the procedure that performs
-;;; the operation, the implementer must also write two additional
-;;; procedures, three function prototypes, one or two message-type
-;;; declarations, one or two message-structure declarations, and one
-;;; or two case statements in the message dispatch. The purpose of
-;;; this file is to generate all of the overhead code automatically
-;;; from a simple interface definition; the implementer supplies the
-;;; definition and the operation's procedure, and this program takes
-;;; care of the rest of the details.
-
-;;; The bulk of this file is the program to parse the interface
-;;; specifications and to generate the appropriate code. The
-;;; specifications themselves appear on the last page of the file.
-
-;;; To generate the output files, just load this file. The output
-;;; files will be written into the working directory.
-
-(declare (usual-integrations))
-
-(load-option 'FORMAT)
-\f
-;;;; Syntax
-
-(define-syntax define-pm-procedure
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (let ((external-name
- (if (pair? (cadr form)) (car (cadr form)) (cadr form)))
- (internal-name
- (if (pair? (cadr form)) (cadr (cadr form)) (cadr form)))
- (clauses (cddr form)))
- `(BEGIN
- (HASH-TABLE/PUT! PM-PROCEDURES ',external-name
- (MAKE-PMP (TRANSLATE-NAME ',external-name)
- (TRANSLATE-NAME ',internal-name)
- ,(let ((clause (assq 'VALUE clauses)))
- (if clause
- (let ((val (cadr clause)))
- (if (symbol? val)
- (if (eq? val 'SYNC)
- `',val
- `(TRANSLATE-TYPE/NAME
- ',`((ID ,val) ,val)))
- `(TRANSLATE-TYPE/NAME ',val)))
- '#F))
- ,(let ((args
- (let ((clause (assq 'ARGUMENTS clauses)))
- (if (not clause)
- (error "ARGUMENTS clause is required:"
- name))
- (cdr clause))))
- `(CONS (TRANSLATE-TYPE/NAME
- ',(if (symbol? (car args))
- `((ID ,(car args)) ,(car args))
- (car args)))
- (LIST ,@(map (lambda (arg)
- `(TRANSLATE-TYPE/NAME ',arg))
- (cdr args)))))))
- ',external-name)))))
-
-(define (translate-type/name tn)
- (cond ((and (pair? tn)
- (pair? (cdr tn))
- (null? (cddr tn)))
- (list (translate-type (car tn))
- (translate-name (cadr tn))))
- ((and (pair? tn)
- (pair? (cdr tn))
- (pair? (cddr tn))
- (null? (cdddr tn)))
- (list (translate-type (car tn))
- (translate-name (cadr tn))
- (translate-name (caddr tn))))
- (else
- (error "Ill-formed type/name pair:" tn))))
-\f
-(define (translate-type type)
- (cond ((string? type)
- type)
- ((symbol? type)
- (let ((abbrev (hash-table/get type-abbreviations type #f)))
- (if abbrev
- (translate-type abbrev)
- (symbol->string type))))
- ((and (pair? type)
- (or (string? (car type))
- (symbol? (car type)))
- (pair? (cdr type))
- (null? (cddr type)))
- (if (eq? (car type) 'ID)
- type
- (list (if (or (string? (car type))
- (memq (car type) '(POINTER ARRAY)))
- (car type)
- (symbol->string (car type)))
- (translate-type (cadr type)))))
- ((and (pair? type)
- (eq? (car type) 'ARRAY)
- (pair? (cdr type))
- (pair? (cddr type))
- (and (exact-integer? (caddr type))
- (positive? (caddr type)))
- (null? (cdddr type)))
- (list (car type)
- (translate-type (cadr type))
- (number->string (caddr type))))
- (else
- (error "Ill-formed type:" type))))
-
-(define (translate-name name)
- (cond ((string? name)
- name)
- ((symbol? name)
- (symbol->string name))
- (else
- (error "Ill-formed name:" name))))
-
-(define (define-type-abbreviation name type)
- (hash-table/put! type-abbreviations name type))
-
-(define type-abbreviations
- (make-strong-eq-hash-table))
-
-(define-type-abbreviation 'boolean 'int)
-(define-type-abbreviation 'uchar '(unsigned char))
-(define-type-abbreviation 'ushort '(unsigned short))
-(define-type-abbreviation 'uint '(unsigned int))
-(define-type-abbreviation 'ulong '(unsigned long))
-
-(define (id-type? type) (and (pair? type) (eq? (car type) 'ID)))
-(define-integrable id-type-name cadr)
-
-(define (pointer-type? type) (and (pair? type) (eq? (car type) 'POINTER)))
-(define (array-type? type) (and (pair? type) (eq? (car type) 'ARRAY)))
-(define-integrable subtype cadr)
-
-(define (array-dimension type)
- (and (pair? (cddr type))
- (caddr type)))
-
-(define (variable-length-array? arg)
- (let ((type (pmp-arg-type arg)))
- (and (array-type? type)
- (not (array-dimension type)))))
-\f
-;;;; ID Types
-
-(define (define-id internal-root external-root)
- (hash-table/put! id-external-roots
- internal-root
- (symbol->string external-root)))
-
-(define (id-internal-root type)
- (symbol->string (id-type-name type)))
-
-(define (id-external-root type)
- (hash-table/get id-external-roots (id-type-name type) #f))
-
-(define id-external-roots
- (make-strong-eq-hash-table))
-
-(define (id-external-type type)
- (list (id-external-root type) "_t"))
-
-(define (id-internal-type type)
- (if (eq? (id-type-name type) 'QID)
- (id-external-type type)
- (list (id-internal-root type) "_t *")))
-
-(define-integrable (id-internal-name arg)
- (pmp-arg-name arg))
-
-(define (id-external-name arg)
- (if (eq? (id-type-name (pmp-arg-type arg)) 'QID)
- (pmp-arg-name arg)
- (list (pmp-arg-name arg) "_id")))
-
-(define (id-internal-expression arg)
- (let ((type (pmp-arg-type arg)))
- (if (eq? (id-type-name type) 'QID)
- (id-external-name arg)
- (list "("
- (id-external-root type)
- "_to_"
- (id-internal-root type)
- " ("
- (id-external-name arg)
- "))"))))
-
-(define (id-external-expression arg)
- (let ((type (pmp-arg-type arg)))
- (if (eq? (id-type-name type) 'QID)
- (id-internal-name arg)
- (list "("
- (string-upcase (id-internal-root type))
- "_ID ("
- (id-internal-name arg)
- "))"))))
-
-(define (id-qid-expression arg)
- (let ((type (pmp-arg-type arg)))
- (if (eq? (id-type-name type) 'QID)
- (id-internal-name arg)
- (list "("
- (string-upcase (id-internal-root type))
- "_QID ("
- (id-internal-name arg)
- "))"))))
-
-(define-id 'QID 'QID)
-(define-id 'WINDOW 'WID)
-(define-id 'PS 'PSID)
-(define-id 'BITMAP 'BID)
-\f
-;;;; PM Procedures
-
-(define pm-procedures
- (make-strong-eq-hash-table))
-
-(define-structure pmp
- (root-name #f read-only #t)
- (internal-name #f read-only #t)
- (value #f read-only #t)
- (arguments #f read-only #t))
-
-(define-integrable pmp-arg-type car)
-(define-integrable pmp-arg-name cadr)
-(define-integrable (pmp-value? pmp) (pair? (pmp-value pmp)))
-(define-integrable (pmp-sync? pmp) (eq? (pmp-value pmp) 'SYNC))
-
-(define (pmp-arg-size-name arg)
- (and (not (null? (cddr arg)))
- (caddr arg)))
-
-(define (pmp-request-struct-name pmp)
- (list "sm_" (pmp-root-name pmp) "_request_t"))
-
-(define (pmp-reply-struct-name pmp)
- (list "sm_" (pmp-root-name pmp) "_reply_t"))
-
-(define (pmp-request-message-name pmp)
- (list "mt_" (pmp-root-name pmp) "_request"))
-
-(define (pmp-reply-message-name pmp)
- (list "mt_" (pmp-root-name pmp) "_reply"))
-
-(define (pmp-external-name pmp)
- (list "OS2_" (pmp-root-name pmp)))
-
-(define (pmp-request-handler-name pmp)
- (list "handle_" (pmp-root-name pmp) "_request"))
-
-(define (for-each-pmp procedure)
- (for-each procedure
- (sort (hash-table/datum-list pm-procedures)
- (lambda (x y)
- (string<? (pmp-root-name x) (pmp-root-name y))))))
-\f
-;;;; Printing
-
-(define (print tree port)
- (if (list? tree)
- (for-each (lambda (element) (print element port)) tree)
- (display tree port)))
-
-(define (indent n . tree)
- (let ((indent (make-string n #\space)))
- (let at-line-start ((objects (flatten-for-indentation tree)))
- (if (null? objects)
- '()
- (cons indent
- (let in-line ((objects objects))
- (cons (car objects)
- (cond ((eqv? (car objects) #\newline)
- (at-line-start (cdr objects)))
- ((null? (cdr objects))
- '())
- (else
- (in-line (cdr objects)))))))))))
-
-(define (indent-following n . tree)
- (let ((indent (make-string n #\space)))
- (let in-line ((objects (flatten-for-indentation tree)))
- (cons (car objects)
- (cond ((eqv? (car objects) #\newline)
- (let at-line-start ((objects (cdr objects)))
- (if (null? objects)
- '()
- (cons indent (in-line objects)))))
- ((null? (cdr objects))
- '())
- (else
- (in-line (cdr objects))))))))
-
-(define (flatten-for-indentation tree)
- (cond ((list? tree)
- (append-map flatten-for-indentation tree))
- ((string? tree)
- (reveal-embedded-newlines tree))
- (else
- (list tree))))
-
-(define (reveal-embedded-newlines string)
- (let ((indices (find-embedded-newlines string)))
- (if (null? indices)
- (list string)
- (let loop ((start 0) (indices indices))
- (if (null? indices)
- (list (string-tail string start))
- (cons* (substring string start (car indices))
- #\newline
- (loop (fix:+ (car indices) 1) (cdr indices))))))))
-
-(define (find-embedded-newlines string)
- (let ((end (string-length string)))
- (let loop ((start 0))
- (let ((index (substring-find-next-char string start end #\newline)))
- (if index
- (cons index (loop (fix:+ index 1)))
- '())))))
-
-(define (first-char-in-tree tree)
- (cond ((list? tree)
- (and (pair? tree)
- (or (first-char-in-tree (car tree))
- (first-char-in-tree (cdr tree)))))
- ((string? tree)
- (and (not (string-null? tree))
- (string-ref tree 0)))
- ((char? tree) tree)
- (else #f)))
-\f
-;;;; C Syntax Combinators
-
-(define (brace-group . body)
- (list "{" #\newline
- (apply indent 2 body)
- "}" #\newline))
-
-(define (statement . elements)
- (list elements ";" #\newline))
-
-(define (assignment target source)
- (statement target " = " source))
-
-(define (indented-assignment target source)
- (statement target #\newline " = " (indent-following 4 source)))
-
-(define (function name static? value arguments . body)
- (list (if static? "static " "") value #\newline
- name " " arguments #\newline
- (apply brace-group body)))
-
-(define (funcall function . arguments)
- (list "(" function " " (funcall-arguments arguments) ")"))
-
-(define (indented-funcall function . arguments)
- (list "(" function #\newline (indent 2 (funcall-arguments arguments) ")")))
-
-(define (call function . arguments)
- (statement function " " (funcall-arguments arguments)))
-
-(define (indented-call function . arguments)
- (statement function #\newline (indent 2 (funcall-arguments arguments))))
-
-(define (funcall-arguments arguments)
- (cond ((null? arguments)
- (list "()"))
- ((null? (cdr arguments))
- (list (guarantee-parentheses (car arguments))))
- (else
- (let loop ((arguments arguments) (prefix "("))
- (cons* prefix
- (car arguments)
- (if (null? (cdr arguments))
- (list ")")
- (loop (cdr arguments) ", ")))))))
-
-(define (guarantee-parentheses expression)
- (if (eqv? #\( (first-char-in-tree expression))
- expression
- (list "(" expression ")")))
-
-(define (cast type expression)
- (list "((" type ") " expression ")"))
-\f
-;;;; Per-Procedure Output
-
-(define (generate-message-types pmp)
- (cons* " " (pmp-request-message-name pmp) "," #\newline
- (if (pmp-value? pmp)
- (list " " (pmp-reply-message-name pmp) "," #\newline)
- '())))
-
-(define (generate-handler-prototype pmp)
- (statement "static void "
- (pmp-request-handler-name pmp)
- #\newline " ("
- (pmp-request-struct-name pmp)
- " *)"))
-
-(define (generate-prototype pmp external?)
- (statement (if external? "extern" "static")
- " "
- (val-type pmp external?)
- " "
- (if external? (pmp-external-name pmp) (pmp-internal-name pmp))
- #\newline " "
- (arg-declarators (pmp-arguments pmp) external? #f)))
-
-(define (generate-message-initializers pmp)
- (indent 2
- (let ((generate-init
- (lambda (mn sn)
- (statement "SET_MSG_TYPE_LENGTH (" mn "," #\newline
- " " sn ")"))))
- (list (generate-init (pmp-request-message-name pmp)
- (pmp-request-struct-name pmp))
- (if (pmp-value? pmp)
- (generate-init (pmp-reply-message-name pmp)
- (pmp-reply-struct-name pmp))
- '())))))
-
-(define (generate-dispatch-case pmp)
- (indent 8
- "case " (pmp-request-message-name pmp) ":" #\newline
- (indent 2
- (indented-call
- (pmp-request-handler-name pmp)
- (cast (list (pmp-request-struct-name pmp) " *")
- "message"))
- (statement "break"))))
-\f
-(define (generate-struct-definitions pmp)
- (list (generate-struct-definition
- (pmp-request-struct-name pmp)
- (map (lambda (arg)
- (let ((type (pmp-arg-type arg)))
- (if (array-type? type)
- (list (arg-type-1 (subtype type))
- " "
- (arg-name arg #f)
- " ["
- (or (array-dimension type) "1")
- "]")
- (arg-declarator arg #f))))
- (let ((args (pmp-arguments pmp)))
- (let ((array
- (list-search-positive args
- variable-length-array?)))
- (if array
- (append (delq array args) (list array))
- args)))))
- (if (pmp-value? pmp)
- (list #\newline
- (generate-struct-definition
- (pmp-reply-struct-name pmp)
- (list (arg-declarator (pmp-value pmp) #f))))
- '())))
-
-(define (generate-struct-definition name elements)
- (statement "typedef struct" #\newline
- "{" #\newline
- (indent 2
- (map statement
- (cons "DECLARE_MSG_HEADER_FIELDS" elements)))
- "}" " " name))
-\f
-(define (generate-request-procedure pmp)
- (let ((args (pmp-arguments pmp)))
- (function (pmp-external-name pmp)
- #f
- (val-type pmp #t)
- (arg-declarators args #t #t)
- (map (lambda (arg)
- (let ((type (pmp-arg-type arg)))
- (if (and (id-type? type)
- (not (eq? (id-type-name type) 'QID)))
- (assignment (arg-declarator arg #f)
- (id-internal-expression arg))
- '())))
- args)
- (indented-assignment
- (list (pmp-request-struct-name pmp) " * request")
- (message-creator pmp
- (pmp-request-struct-name pmp)
- (pmp-request-message-name pmp)
- (request-extra pmp)))
- (map (lambda (arg) (request-initializer pmp arg)) args)
- (if (pmp-value? pmp)
- (let ((val (pmp-value pmp)))
- (brace-group
- (indented-assignment
- (list (pmp-reply-struct-name pmp) " * reply")
- (indented-funcall
- "MESSAGE_TRANSACTION"
- (id-qid-expression (car (pmp-arguments pmp)))
- "request"
- (pmp-reply-message-name pmp)))
- (assignment (arg-declarator val #f)
- (reply-accessor val))
- (call "DESTROY_MESSAGE" "reply")
- (call "return"
- (if (id-type? (pmp-arg-type val))
- (id-external-expression val)
- (arg-name val #f)))))
- (call (if (pmp-sync? pmp)
- "SYNC_TRANSACTION"
- "SIMPLE_TRANSACTION")
- (id-qid-expression (car (pmp-arguments pmp)))
- "request")))))
-
-(define (request-extra pmp)
- (let ((array-arg
- (list-search-positive (pmp-arguments pmp)
- variable-length-array?)))
- (and array-arg
- (let ((size (pmp-arg-size-name array-arg)))
- (if size
- (list "(" size " - 1)")
- (funcall "strlen" (arg-name array-arg #f)))))))
-
-(define (request-initializer pmp arg)
- (if (array-type? (pmp-arg-type arg))
- (let ((source (arg-name arg #t))
- (target (request-accessor arg))
- (size (pmp-arg-size-name arg)))
- (if size
- (call "MEMCPY"
- target
- source
- (list "((sizeof ("
- (arg-type-1 (subtype (pmp-arg-type arg)))
- ")) * "
- size
- ")"))
- (call "STRCPY" target source)))
- (assignment (request-accessor arg) (arg-name arg #f))))
-\f
-(define (generate-request-handler pmp)
- (function (pmp-request-handler-name pmp)
- #t
- "void"
- (list "(" (list (pmp-request-struct-name pmp) " * request") ")")
- (assignment "qid_t sender" (funcall "MSG_SENDER" "request"))
- (if (pmp-value? pmp)
- (list (indented-assignment
- (list (pmp-reply-struct-name pmp) " * reply")
- (message-creator pmp
- (pmp-reply-struct-name pmp)
- (pmp-reply-message-name pmp)
- #f))
- (indented-assignment
- (reply-accessor (pmp-value pmp))
- (apply indented-funcall
- (pmp-internal-name pmp)
- (map (lambda (arg)
- (request-accessor arg))
- (pmp-arguments pmp))))
- (call "DESTROY_MESSAGE" "request")
- (call "SEND_MESSAGE" "sender" "reply"))
- (list (apply indented-call
- (pmp-internal-name pmp)
- (map (lambda (arg) (request-accessor arg))
- (pmp-arguments pmp)))
- (call "DESTROY_MESSAGE" "request")
- (call (if (pmp-sync? pmp) "sync_reply" "simple_reply")
- "sender")))))
-\f
-(define (message-creator pmp struct-type message-type extra)
- (if extra
- (funcall "CREATE_MESSAGE_1" message-type extra)
- (funcall "CREATE_MESSAGE" message-type)))
-
-(define (request-accessor arg)
- (message-accessor "request" arg))
-
-(define (reply-accessor arg)
- (message-accessor "reply" arg))
-
-(define (message-accessor message-name arg)
- (list "(" message-name " -> " (arg-name arg #f) ")"))
-
-(define (val-type pmp external?)
- (if (pmp-value? pmp)
- (arg-type (pmp-value pmp) external?)
- "void"))
-
-(define (arg-declarator arg external?)
- (list (arg-type arg external?)
- " "
- (arg-name arg external?)))
-
-(define (arg-declarators args external? names?)
- (if (null? args)
- "(void)"
- (let ((do-arg
- (lambda (arg)
- (if names?
- (arg-declarator arg external?)
- (arg-type arg external?)))))
- (cons* "("
- (do-arg (car args))
- (let loop ((args (cdr args)))
- (if (null? args)
- (list ")")
- (cons* ", "
- (do-arg (car args))
- (loop (cdr args)))))))))
-
-(define (arg-type arg external?)
- (let ((type (pmp-arg-type arg)))
- (if (id-type? type)
- (if external?
- (id-external-type type)
- (id-internal-type type))
- (arg-type-1 type))))
-
-(define (arg-type-1 type)
- (if (pair? type)
- (case (car type)
- ((POINTER ARRAY)
- (list (arg-type-1 (subtype type)) " *"))
- (else
- (list (car type) " " (arg-type-1 (subtype type)))))
- type))
-
-(define (arg-name arg external?)
- (let ((name (pmp-arg-name arg)))
- (if (id-type? (pmp-arg-type arg))
- (if external?
- (id-external-name arg)
- (id-internal-name arg))
- (pmp-arg-name arg))))
-\f
-;;;; Top-Level Output
-
-(define (generate-file filename per-pmp)
- (call-with-output-file filename
- (lambda (port)
- (format port
- file-header-format-string
- (universal-time->local-iso8601-string (get-universal-time)))
- (for-each-pmp (lambda (pmp) (print (per-pmp pmp) port))))))
-
-(define file-header-format-string
- "/* -*-C-*-
-
-**** Do not edit this file. It was generated by a program
-**** at ~A.
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-")
-\f
-(define (write-message-types-file)
- (generate-file "os2pm-mt.h" generate-message-types))
-
-(define (write-external-declarations-file)
- (generate-file "os2pm-ed.h"
- (lambda (pmp)
- (list #\newline
- (generate-prototype pmp #t)))))
-
-(define (write-internal-declarations-file)
- (generate-file "os2pm-id.h"
- (lambda (pmp)
- (list #\newline
- (generate-struct-definitions pmp)
- #\newline
- (generate-handler-prototype pmp)
- #\newline
- (generate-prototype pmp #f)))))
-
-(define (write-message-initializers-file)
- (generate-file "os2pm-mi.h" generate-message-initializers))
-
-(define (write-dispatch-cases-file)
- (generate-file "os2pm-dc.h" generate-dispatch-case))
-
-(define (write-request-procedures-file)
- (generate-file "os2pm-rp.h"
- (lambda (pmp)
- (list #\newline
- (generate-request-procedure pmp)
- #\newline
- (generate-request-handler pmp)))))
-
-(define (write-all-files)
- (write-message-types-file)
- (write-external-declarations-file)
- (write-internal-declarations-file)
- (write-message-initializers-file)
- (write-dispatch-cases-file)
- (write-request-procedures-file))
-\f
-;;;; Interface Definitions
-
-(define-pm-procedure pm_synchronize
- (value sync)
- (arguments qid))
-
-;;; Windows
-
-(define-pm-procedure window_open
- (value ("wid_t" wid))
- (arguments qid
- (qid_t event_qid)
- (ulong flags)
- ("HMODULE" module)
- (ulong id)
- (ulong style)
- ((array (const char)) title)))
-
-(define-pm-procedure window_close
- (arguments window))
-
-(define-pm-procedure window_show
- (arguments window (boolean showp)))
-
-(define-pm-procedure window_scroll
- (arguments window
- (short xl)
- (short xh)
- (short yl)
- (short yh)
- (short x_delta)
- (short y_delta)))
-
-(define-pm-procedure window_invalidate
- (arguments window (short xl) (short xh) (short yl) (short yh)))
-
-(define-pm-procedure window_set_grid
- (arguments window (ushort x) (ushort y)))
-
-(define-pm-procedure window_activate
- (arguments window))
-
-;;; (define_pm_procedure window_pos ...)
-
-(define-pm-procedure window_set_pos
- (arguments window (short x) (short y)))
-
-;;; (define_pm_procedure window_size ...)
-;;; (define_pm_procedure window_frame_size ...)
-
-(define-pm-procedure window_set_size
- (arguments window (ushort x) (ushort y)))
-
-(define-pm-procedure window_focusp
- (value (boolean focusp))
- (arguments window))
-
-(define-pm-procedure window_set_state
- (arguments window (window_state_t state)))
-
-(define-pm-procedure window_set_title
- (arguments window ((array (const char)) title)))
-
-(define-pm-procedure window_update_frame
- (arguments window (ushort flags)))
-
-(define-pm-procedure window_handle_from_id
- (value ("HWND" child))
- (arguments qid ("HWND" parent) (ulong id)))
-
-(define-pm-procedure window_set_capture
- (value ("BOOL" successp))
- (arguments window (int capturep)))
-
-(define-pm-procedure window_query_sys_value
- (value ("LONG" sysval))
- (arguments qid ("HWND" window) ("LONG" id)))
-
-;;; Text Cursors
-
-(define-pm-procedure window_move_cursor
- (arguments window (short x) (short y)))
-
-(define-pm-procedure window_shape_cursor
- (arguments window (ushort width) (ushort height) (ushort style)))
-
-(define-pm-procedure window_show_cursor
- (arguments window (boolean showp)))
-
-;;; Presentation Spaces
-
-(define-pm-procedure create_memory_ps
- (value ps)
- (arguments qid))
-
-(define-pm-procedure destroy_memory_ps
- (arguments ps))
-
-(define-pm-procedure create_bitmap
- (value bitmap)
- (arguments ps (ushort width) (ushort height)))
-
-(define-pm-procedure destroy_bitmap
- (arguments bitmap))
-
-;;; (define_pm_procedure ps_set_bitmap ...)
-
-(define-pm-procedure ps_bitblt
- (arguments ((id ps) target)
- ((id ps) source)
- (long npoints)
- ((array "POINTL" 4) points npoints)
- (long rop)
- (ulong options)))
-
-(define-pm-procedure ps_draw_text
- (arguments ps
- (short x)
- (short y)
- ((array (const char)) data size)
- (ushort size)))
-
-(define-pm-procedure ps_text_width
- (value (ushort width))
- (arguments ps
- ((array (const char)) data size)
- (ushort size)))
-
-(define-pm-procedure ps_clear
- (arguments ps (short xl) (short xh) (short yl) (short yh)))
-
-(define-pm-procedure ps_get_foreground_color
- (value ("COLOR" color))
- (arguments ps))
-
-(define-pm-procedure ps_get_background_color
- (value ("COLOR" color))
- (arguments ps))
-
-(define-pm-procedure ps_set_colors
- (arguments ps ("COLOR" foreground) ("COLOR" background)))
-
-(define-pm-procedure ps_move_gcursor
- (arguments ps (short x) (short y)))
-
-(define-pm-procedure ps_draw_line
- (arguments ps (short x) (short y)))
-
-(define-pm-procedure ps_draw_point
- (arguments ps (short x) (short y)))
-
-(define-pm-procedure ps_poly_line
- (value sync)
- (arguments ps
- (ulong npoints)
- ((pointer "POINTL") points)))
-
-(define-pm-procedure ps_poly_line_disjoint
- (value sync)
- (arguments ps
- (ulong npoints)
- ((pointer "POINTL") points)))
-
-(define-pm-procedure ps_set_line_type
- (arguments ps (long type)))
-
-(define-pm-procedure ps_set_mix
- (arguments ps (long mix)))
-
-(define-pm-procedure ps_query_caps
- (value sync)
- (arguments ps (long start) (long count) ((pointer long) values)))
-
-(define-pm-procedure ps_set_clip_rectangle
- (arguments ps (short xl) (short xh) (short yl) (short yh)))
-
-(define-pm-procedure ps_reset_clip_rectangle
- (arguments ps))
-
-(define-pm-procedure get_bitmap_parameters
- (value sync)
- (arguments bitmap ((pointer "BITMAPINFOHEADER") params)))
-
-(define-pm-procedure ps_get_bitmap_bits
- (value (ulong length))
- (arguments ps
- (ulong start)
- (ulong length)
- ((pointer "BYTE") data)
- ((pointer "BITMAPINFO2") info)))
-
-(define-pm-procedure ps_set_bitmap_bits
- (value (ulong length))
- (arguments ps
- (ulong start)
- (ulong length)
- ((pointer "BYTE") data)
- ((pointer "BITMAPINFO2") info)))
-
-;;; Clipboard
-
-(define-pm-procedure clipboard_write_text
- (value sync)
- (arguments qid ((pointer (const char)) text)))
-
-(define-pm-procedure clipboard_read_text
- (value ((pointer (const char)) text))
- (arguments qid))
-
-;;; Menus
-
-(define-pm-procedure menu_create
- (value ("HWND" menu))
- (arguments qid ("HWND" owner) (ushort style) (ushort id)))
-
-(define-pm-procedure menu_destroy
- (value ("BOOL" successp))
- (arguments qid ("HWND" menu)))
-
-(define-pm-procedure menu_insert_item
- (value (ushort position))
- (arguments qid
- ("HWND" menu)
- (ushort position)
- (ushort style)
- (ushort attributes)
- (ushort id)
- ("HWND" submenu)
- ((pointer char) text)))
-
-(define-pm-procedure menu_remove_item
- (value (ushort length))
- (arguments qid
- ("HWND" menu)
- (ushort id)
- (ushort submenup)
- (ushort deletep)))
-
-(define-pm-procedure menu_get_item
- (value ((pointer "MENUITEM") item))
- (arguments qid
- ("HWND" menu)
- (ushort id)
- (ushort submenup)))
-
-(define-pm-procedure menu_n_items
- (value (ushort length))
- (arguments qid ("HWND" menu)))
-
-(define-pm-procedure menu_nth_item_id
- (value (ushort id))
- (arguments qid ("HWND" menu) (ushort position)))
-
-(define-pm-procedure menu_get_item_attributes
- (value (ushort attributes))
- (arguments qid
- ("HWND" menu)
- (ushort id)
- (ushort submenup)
- (ushort mask)))
-
-(define-pm-procedure menu_set_item_attributes
- (value ("BOOL" successp))
- (arguments qid
- ("HWND" menu)
- (ushort id)
- (ushort submenup)
- (ushort mask)
- (ushort attributes)))
-
-(define-pm-procedure window_load_menu
- (value ("HWND" menu))
- (arguments window ("HMODULE" module) (ulong id)))
-
-(define-pm-procedure window_popup_menu
- (value ("BOOL" successp))
- (arguments qid
- ("HWND" parent)
- ("HWND" owner)
- ("HWND" menu)
- (long x)
- (long y)
- (long id)
- (ulong options)))
-
-;;; Font
-
-(define-pm-procedure ps_get_font_metrics
- (value ((pointer font_metrics_t) metrics))
- (arguments ps))
-
-(define-pm-procedure ps_set_font_internal
- (value ((pointer font_metrics_t) metrics))
- (arguments ps
- (ushort id)
- ((array (const char)) name)))
-
-(define-pm-procedure window_font_dialog
- (value ((pointer (const char)) spec))
- (arguments window ((pointer (const char)) title)))
-
-;;; Pointers
-
-(define-pm-procedure query_system_pointer
- (value ("HPOINTER" pointer))
- (arguments qid ("HWND" desktop) (long id) ("BOOL" copyp)))
-
-(define-pm-procedure set_pointer
- (value ("BOOL" successp))
- (arguments qid ("HWND" desktop) ("HPOINTER" pointer)))
-
-(define-pm-procedure window_load_pointer
- (value ("HPOINTER" pointer))
- (arguments qid ("HWND" desktop) ("HMODULE" module) (ulong id)))
-
-(define-pm-procedure window_destroy_pointer
- (value ("BOOL" successp))
- (arguments qid ("HPOINTER" icon)))
-
-(define-pm-procedure window_set_icon
- (value ("BOOL" successp))
- (arguments window ("HPOINTER" icon)))
-
-(write-all-files)
\ No newline at end of file
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#define INCL_WIN
-#include "os2.h"
-#include "os2pmcon.h"
-
-/* #define CONSOLE_WRAP */
-
-static void grab_console_lock (void);
-static void release_console_lock (void);
-static unsigned short cx2x (unsigned short);
-static unsigned short cy2y (unsigned short, int);
-static unsigned short x2cx (short, int);
-static unsigned short y2cy (short, int);
-static void process_events (int);
-static void initialize_marked_region (short, short);
-static void update_marked_region (short, short);
-static void unmark_marked_region (void);
-static int marked_region_nonempty_p (void);
-static char * extract_marked_region (int);
-static void compute_marked_region
- (short, short, short, short,
- unsigned short *, unsigned short *, unsigned short *, unsigned short *);
-static void highlight_marked_region
- (unsigned short, unsigned short, unsigned short, unsigned short, char);
-static void paint_marked_region_segment
- (unsigned short, unsigned short, unsigned short, unsigned short);
-static void disable_marked_region (void);
-static void enable_menu_copy_items (int);
-static void console_resize (unsigned short, unsigned short);
-static void console_paint
- (unsigned short, unsigned short, unsigned short, unsigned short);
-static unsigned short compute_run_length (const char *, const char *);
-static void console_clear
- (unsigned short, unsigned short, unsigned short, unsigned short);
-static void console_clear_all (void);
-static int do_paste (void);
-static int translate_key_event
- (MPARAM, MPARAM, unsigned short *, unsigned char *);
-static const char * find_nonprint (const char *, const char *);
-static void do_carriage_return (void);
-static void do_linefeed (void);
-static unsigned short find_invalid_line (unsigned short, unsigned short);
-static void do_formfeed (void);
-static void do_backspace (void);
-static void do_alert (void);
-\f
-static HMTX console_lock;
-static unsigned short console_pel_width;
-static unsigned short console_pel_height;
-static unsigned short console_width;
-static unsigned short console_height;
-static char * console_chars;
-static char * console_highlights;
-static unsigned short * console_line_lengths;
-static font_metrics_t * console_metrics;
-static unsigned short point_x;
-static unsigned short point_y;
-static int console_visiblep;
-static int console_closedp;
-static unsigned short readahead_repeat;
-static char readahead_char;
-static const char * readahead_insert;
-static const char * readahead_insert_scan;
-static void * pending_events;
-static tqueue_t * console_tqueue;
-static qid_t console_event_qid;
-static qid_t console_pm_qid;
-static wid_t console_wid;
-static psid_t console_psid;
-static int console_tracking_mouse_p;
-static HWND console_tracking_mouse_pointer;
-static int console_marked_region_active_p;
-static HWND console_menu;
-static short console_mark_x;
-static short console_mark_y;
-static short console_point_x;
-static short console_point_y;
-
-static const char * console_font_specs [] =
- { "8.Courier", "10.Courier", "12.Courier",
- "4.System VIO", "10.System Monospaced" };
-
-#define CHAR_WIDTH (FONT_METRICS_WIDTH (console_metrics))
-#define CHAR_HEIGHT (FONT_METRICS_HEIGHT (console_metrics))
-#define CHAR_DESCENDER (FONT_METRICS_DESCENDER (console_metrics))
-#define CHAR_LOC(x, y) (& (console_chars [((y) * console_width) + (x)]))
-#define CHAR_HL(x, y) (& (console_highlights [((y) * console_width) + (x)]))
-#define LINE_LEN_LOC(y) ((char *) (& (console_line_lengths [(y)])))
-
-#define FASTFILL(p, n, c) \
-{ \
- char * FASTFILL_scan = (p); \
- char * FASTFILL_end = (FASTFILL_scan + (n)); \
- while (FASTFILL_scan < FASTFILL_end) \
- (*FASTFILL_scan++) = (c); \
-}
-
-void
-OS2_initialize_pm_console (void)
-{
- console_lock = (OS2_create_mutex_semaphore (0, 0));
- console_pel_width = 0;
- console_pel_height = 0;
- console_width = 0;
- console_height = 0;
- console_chars = 0;
- console_highlights = 0;
- console_line_lengths = 0;
- point_x = 0;
- point_y = 0;
- console_visiblep = 0;
- console_closedp = 0;
- console_tracking_mouse_p = 0;
- console_tracking_mouse_pointer
- = (WinQuerySysPointer (HWND_DESKTOP, SPTR_TEXT, FALSE));
- readahead_repeat = 0;
- readahead_insert = 0;
- pending_events = (OS2_create_msg_fifo ());
- console_tqueue = (OS2_make_std_tqueue ());
- {
- qid_t remote;
- OS2_make_qid_pair ((&console_event_qid), (&remote));
- OS2_open_qid (console_event_qid, console_tqueue);
- console_pm_qid = (OS2_create_pm_qid (console_tqueue));
- console_wid
- = (OS2_window_open (console_pm_qid, remote,
- (FCF_TITLEBAR | FCF_SYSMENU
- | FCF_SHELLPOSITION | FCF_SIZEBORDER
- | FCF_MINMAX | FCF_TASKLIST | FCF_NOBYTEALIGN
- | FCF_MENU | FCF_ACCELTABLE | FCF_ICON),
- NULLHANDLE,
- ID_PMCON_RESOURCES,
- 0, "Scheme"));
- }
- OS2_window_permanent (console_wid);
- {
- psid_t psid = (OS2_window_client_ps (console_wid));
- const char ** scan_specs = console_font_specs;
- const char ** end_specs
- = (scan_specs
- + ((sizeof (console_font_specs)) / (sizeof (const char *))));
- console_metrics = 0;
- while (scan_specs < end_specs)
- {
- const char * spec = (*scan_specs++);
- /* This prevents the font-change hook from being invoked. */
- console_psid = 0;
- console_metrics = (OS2_ps_set_font (psid, 1, spec));
- if (console_metrics != 0)
- break;
- }
- if (console_metrics == 0)
- OS2_logic_error ("Unable to find usable console font.");
- console_psid = psid;
- }
- OS2_window_set_grid (console_wid, CHAR_WIDTH, CHAR_HEIGHT);
- OS2_window_shape_cursor
- (console_wid, CHAR_WIDTH, CHAR_HEIGHT, (CURSOR_SOLID | CURSOR_FLASH));
- OS2_window_show_cursor (console_wid, 1);
- OS2_window_show (console_wid, 1);
- OS2_window_activate (console_wid);
- {
- unsigned short width;
- unsigned short height;
- unsigned short max_width = (80 * CHAR_WIDTH);
- OS2_window_size (console_wid, (& width), (& height));
- console_resize (width, height);
- if (width > max_width)
- OS2_window_set_size (console_wid, max_width, height);
- }
- console_menu
- = (OS2_window_handle_from_id (console_pm_qid,
- (OS2_window_frame_handle (console_wid)),
- FID_MENU));
- disable_marked_region ();
-}
-
-wid_t
-OS2_console_wid (void)
-{
- return (console_wid);
-}
-
-psid_t
-OS2_console_psid (void)
-{
- return (console_psid);
-}
-
-void
-OS2_console_font_change_hook (font_metrics_t * metrics)
-{
- font_metrics_t * copy = (OS_malloc (sizeof (font_metrics_t)));
- FASTCOPY (((char *) metrics), ((char *) copy), (sizeof (font_metrics_t)));
- grab_console_lock ();
- OS_free (console_metrics);
- console_metrics = copy;
- OS2_window_set_grid (console_wid, CHAR_WIDTH, CHAR_HEIGHT);
- OS2_window_shape_cursor
- (console_wid, CHAR_WIDTH, CHAR_HEIGHT, (CURSOR_SOLID | CURSOR_FLASH));
- console_resize (console_pel_width, console_pel_height);
- OS2_window_invalidate (console_wid,
- 0, console_pel_width,
- 0, console_pel_height);
- release_console_lock ();
-}
-\f
-static void
-grab_console_lock (void)
-{
- OS2_request_mutex_semaphore (console_lock);
-}
-
-static void
-release_console_lock (void)
-{
- OS2_release_mutex_semaphore (console_lock);
-}
-
-static unsigned short
-cx2x (unsigned short x)
-{
- return (x * CHAR_WIDTH);
-}
-
-static unsigned short
-cy2y (unsigned short y, int lowerp)
-{
- /* lowerp => result is bottommost pel of cell. Otherwise result is
- bottommost pel of cell above. */
- unsigned short limit = (lowerp ? (console_height - 1) : console_height);
- return ((y < limit) ? ((limit - y) * CHAR_HEIGHT) : 0);
-}
-
-static unsigned short
-x2cx (short x, int lowerp)
-{
- /* lowerp => `x' is inclusive lower bound, and result is cell it
- falls in. Otherwise, `x' is exclusive upper bound, and result is
- cell to its right, unless it falls on leftmost edge of cell. If
- the argument is inclusive-lower, then the result is also;
- likewise for exclusive-upper. */
- short cx = (x / ((short) CHAR_WIDTH));
- if (! (lowerp || ((x % ((short) CHAR_WIDTH)) == 0)))
- cx += 1;
- return ((cx < 0) ? 0 : (cx > console_width) ? console_width : cx);
-}
-
-static unsigned short
-y2cy (short y, int lowerp)
-{
- /* lowerp => `y' is inclusive lower bound, and result is cell below
- the one it falls in. Otherwise, `y' is exclusive upper bound,
- and result is cell it falls in, unless it falls on bottommost
- edge of cell, when result is cell below. If the argument is
- inclusive-lower, then the result is exclusive-upper, and
- vice-versa. */
- short cy = (((short) (console_height - 1)) - (y / ((short) CHAR_HEIGHT)));
- if (lowerp || ((y % ((short) CHAR_HEIGHT)) == 0))
- cy += 1;
- return ((cy < 0) ? 0 : (cy > console_height) ? console_height : cy);
-}
-\f
-static void
-process_events (int blockp)
-{
- while (1)
- {
- msg_t * message
- = (OS2_receive_message (console_event_qid, blockp, 0));
- if (message == 0)
- break;
- switch (MSG_TYPE (message))
- {
- case mt_paint_event:
- {
- unsigned short xl = (SM_PAINT_EVENT_XL (message));
- unsigned short xh = (SM_PAINT_EVENT_XH (message));
- unsigned short yl = (SM_PAINT_EVENT_YL (message));
- unsigned short yh = (SM_PAINT_EVENT_YH (message));
- OS2_destroy_message (message);
- grab_console_lock ();
- OS2_ps_clear (console_psid, xl, xh, yl, yh);
- console_paint ((x2cx (xl, 1)),
- (x2cx (xh, 0)),
- (y2cy (yh, 0)),
- (y2cy (yl, 1)));
- release_console_lock ();
- break;
- }
- case mt_pm_event:
- {
- ULONG msg = (SM_PM_EVENT_MSG (message));
- MPARAM mp1 = (SM_PM_EVENT_MP1 (message));
- MPARAM mp2 = (SM_PM_EVENT_MP2 (message));
- switch (msg)
- {
- case WM_CHAR:
- case WM_CLOSE:
- postpone_event:
- OS2_msg_fifo_insert (pending_events, message);
- message = 0;
- if (blockp)
- return;
- break;
- case WM_SIZE:
- {
- unsigned short new_pel_width = (SHORT1FROMMP (mp2));
- unsigned short new_pel_height = (SHORT2FROMMP (mp2));
- grab_console_lock ();
- console_resize (new_pel_width, new_pel_height);
- release_console_lock ();
- break;
- }
- case WM_SHOW:
- if ((!console_visiblep) && (SHORT1FROMMP (mp1)))
- {
- grab_console_lock ();
- OS2_window_invalidate (console_wid,
- 0, console_pel_width,
- 0, console_pel_height);
- release_console_lock ();
- }
- console_visiblep = (SHORT1FROMMP (mp1));
- break;
- case WM_BUTTON1DOWN:
- grab_console_lock ();
- if (!OS2_window_focusp (console_wid))
- OS2_window_activate (console_wid);
- else if (OS2_window_set_capture (console_wid, 1))
- {
- console_tracking_mouse_p = 1;
- initialize_marked_region ((SHORT1FROMMP (mp1)),
- (SHORT2FROMMP (mp1)));
- OS2_window_mousetrack (console_wid, 1);
- OS2_set_pointer (console_pm_qid,
- HWND_DESKTOP,
- console_tracking_mouse_pointer);
- }
- else
- (void) WinAlarm (HWND_DESKTOP, WA_ERROR);
- release_console_lock ();
- break;
- case WM_BUTTON1UP:
- if (console_tracking_mouse_p)
- {
- grab_console_lock ();
- update_marked_region ((SHORT1FROMMP (mp1)),
- (SHORT2FROMMP (mp1)));
- (void) OS2_window_set_capture (console_wid, 0);
- OS2_window_mousetrack (console_wid, 0);
- enable_menu_copy_items (marked_region_nonempty_p ());
- console_tracking_mouse_p = 0;
- release_console_lock ();
- }
- break;
- case WM_MOUSEMOVE:
- if (console_tracking_mouse_p)
- {
- grab_console_lock ();
- update_marked_region ((SHORT1FROMMP (mp1)),
- (SHORT2FROMMP (mp1)));
- OS2_set_pointer (console_pm_qid,
- HWND_DESKTOP,
- console_tracking_mouse_pointer);
- release_console_lock ();
- }
- break;
- case WM_BUTTON2DOWN:
- case WM_BUTTON3DOWN:
- grab_console_lock ();
- if (!OS2_window_focusp (console_wid))
- OS2_window_activate (console_wid);
- release_console_lock ();
- break;
- case WM_COMMAND:
- switch (SHORT1FROMMP (mp1))
- {
- case IDM_CUT:
- case IDM_COPY:
- case IDM_PASTE:
- goto postpone_event;
- case IDM_FONT:
- grab_console_lock ();
- {
- const char * font_spec
- = (OS2_window_font_dialog (console_wid,
- "Console Window Font"));
- if (font_spec != 0)
- {
- (void) OS2_ps_set_font (console_psid, 1, font_spec);
- OS_free ((void *) font_spec);
- }
- }
- release_console_lock ();
- break;
- case IDM_EXIT:
- termination_normal (0);
- break;
- case IDM_ABOUT:
- (void) WinMessageBox
- (HWND_DESKTOP,
- NULLHANDLE,
- ("This is " PACKAGE_STRING),
- PACKAGE_VERSION,
- 0,
- MB_OK);
- break;
- }
- }
- if (message != 0)
- OS2_destroy_message (message);
- }
- break;
- default:
- OS2_destroy_message (message);
- break;
- }
- }
-}
-\f
-static void
-initialize_marked_region (short x, short y)
-{
- unmark_marked_region ();
- console_mark_x = x;
- console_mark_y = y;
- console_point_x = x;
- console_point_y = y;
- console_marked_region_active_p = 1;
-}
-
-static void
-update_marked_region (short x, short y)
-{
- unsigned short cx11;
- unsigned short cy11;
- unsigned short cx21;
- unsigned short cy21;
- unsigned short cx12;
- unsigned short cy12;
- unsigned short cx22;
- unsigned short cy22;
-
- unsigned short i11;
- unsigned short i21;
- unsigned short i12;
- unsigned short i22;
-
- if (!console_marked_region_active_p)
- return;
-
- compute_marked_region (console_mark_x, console_mark_y,
- console_point_x, console_point_y,
- (&cx11), (&cy11), (&cx21), (&cy21));
- highlight_marked_region (cx11, cy11, cx21, cy21, '\0');
-
- compute_marked_region (console_mark_x, console_mark_y, x, y,
- (&cx12), (&cy12), (&cx22), (&cy22));
- highlight_marked_region (cx12, cy12, cx22, cy22, '\1');
-
- i11 = ((cy11 * console_width) + cx11);
- i21 = ((cy21 * console_width) + cx21);
- i12 = ((cy12 * console_width) + cx12);
- i22 = ((cy22 * console_width) + cx22);
-
- if (i11 < i12)
- paint_marked_region_segment (cx11, cy11, cx12, cy12);
- else if (i12 < i11)
- paint_marked_region_segment (cx12, cy12, cx11, cy11);
- if (i21 < i22)
- paint_marked_region_segment (cx21, cy21, cx22, cy22);
- else if (i22 < i21)
- paint_marked_region_segment (cx22, cy22, cx21, cy21);
-
- console_point_x = x;
- console_point_y = y;
-}
-
-static void
-unmark_marked_region (void)
-{
- if (console_marked_region_active_p)
- {
- unsigned short cx1;
- unsigned short cy1;
- unsigned short cx2;
- unsigned short cy2;
- compute_marked_region (console_mark_x, console_mark_y,
- console_point_x, console_point_y,
- (&cx1), (&cy1), (&cx2), (&cy2));
- highlight_marked_region (cx1, cy1, cx2, cy2, '\0');
- paint_marked_region_segment (cx1, cy1, cx2, cy2);
- disable_marked_region ();
- }
-}
-
-static int
-marked_region_nonempty_p (void)
-{
- if (console_marked_region_active_p)
- {
- unsigned short cx1;
- unsigned short cy1;
- unsigned short cx2;
- unsigned short cy2;
- unsigned short y;
- compute_marked_region (console_mark_x, console_mark_y,
- console_point_x, console_point_y,
- (&cx1), (&cy1), (&cx2), (&cy2));
- return
- ((cy1 < cy2)
- || ((cx1 < cx2) && (cx1 < (console_line_lengths[cy1]))));
- }
- else
- return (0);
-}
-
-static char *
-extract_marked_region (int cutp)
-{
- if (console_marked_region_active_p)
- {
- unsigned short cx1;
- unsigned short cy1;
- unsigned short cx2;
- unsigned short cy2;
- unsigned short length;
- unsigned short y;
- char * result;
- char * scan;
-
- compute_marked_region (console_mark_x, console_mark_y,
- console_point_x, console_point_y,
- (&cx1), (&cy1), (&cx2), (&cy2));
- length = 1;
- for (y = cy1; (y <= cy2); y += 1)
- {
- unsigned short xl = ((y == cy1) ? cx1 : 0);
- unsigned short xh = ((y == cy2) ? cx2 : console_width);
- unsigned short lx = (console_line_lengths[y]);
- if (y > cy1)
- length += 2;
- if (xl < lx)
- length += (((xh < lx) ? xh : lx) - xl);
- }
- if (length == 1)
- return (0);
- result = (OS_malloc (length));
- scan = result;
- for (y = cy1; (y <= cy2); y += 1)
- {
- unsigned short xl = ((y == cy1) ? cx1 : 0);
- unsigned short xh = ((y == cy2) ? cx2 : console_width);
- unsigned short lx = (console_line_lengths[y]);
- if (y > cy1)
- {
- (*scan++) = '\r';
- (*scan++) = '\n';
- }
- if (xl < lx)
- {
- unsigned short ll = (((xh < lx) ? xh : lx) - xl);
- FASTCOPY ((CHAR_LOC (xl, y)), scan, ll);
- scan += ll;
- }
- }
- (*scan) = '\0';
- if (cutp)
- {
- unsigned short x1
- = ((cx1 < (console_line_lengths[cy1]))
- ? cx1
- : (console_line_lengths[cy1]));
- {
- unsigned short d
- = ((cx2 < (console_line_lengths[cy2]))
- ? ((console_line_lengths[cy2]) - cx2)
- : 0);
- FASTCOPY ((CHAR_LOC (cx2, cy2)), (CHAR_LOC (x1, cy1)), d);
- FASTFILL ((CHAR_LOC ((x1 + d), cy1)),
- (console_width - (x1 + d)),
- ' ');
- FASTCOPY ((CHAR_HL (cx2, cy2)), (CHAR_HL (x1, cy1)), d);
- FASTFILL ((CHAR_HL ((x1 + d), cy1)),
- (console_width - (x1 + d)),
- '\0');
- (console_line_lengths[cy1]) = (x1 + d);
- }
- if (cy1 < cy2)
- {
- unsigned short d = (console_height - (cy2 + 1));
- FASTCOPY ((CHAR_LOC (0, (cy2 + 1))),
- (CHAR_LOC (0, (cy1 + 1))),
- (d * console_width));
- FASTCOPY ((CHAR_HL (0, (cy2 + 1))),
- (CHAR_HL (0, (cy1 + 1))),
- (d * console_width));
- FASTCOPY ((LINE_LEN_LOC (cy2 + 1)),
- (LINE_LEN_LOC (cy1 + 1)),
- (d * (sizeof (unsigned short))));
- }
- if ((cy1 < point_y) || ((cy1 == point_y) && (x1 < point_x)))
- {
- if ((cy2 > point_y) || ((cy2 == point_y) && (cx2 >= point_x)))
- {
- point_x = x1;
- point_y = cy1;
- }
- else if (cy2 < point_y)
- point_y -= (cy2 - cy1);
- else
- point_x -= (cx2 - ((cy1 == cy2) ? x1 : 0));
- OS2_window_move_cursor (console_wid,
- (cx2x (point_x)),
- (cy2y (point_y, 1)));
- }
- console_paint (0, console_width, cy1, console_height);
- }
- return (result);
- }
- else
- return (0);
-}
-
-static void
-compute_marked_region (short x1, short y1, short x2, short y2,
- unsigned short * cx1, unsigned short * cy1,
- unsigned short * cx2, unsigned short * cy2)
-{
- /* (cx1,cy1) is inclusive, and (cx2,cy2) is exclusive. */
- unsigned short cx1a = (x2cx (x1, 1));
- unsigned short cy1a = (y2cy (y1, 0));
- unsigned short cx2a = (x2cx (x2, 1));
- unsigned short cy2a = (y2cy (y2, 0));
- if (((cy1a * console_width) + cx1a) > ((cy2a * console_width) + cx2a))
- {
- unsigned short cx = cx1a;
- unsigned short cy = cy1a;
- cx1a = cx2a;
- cy1a = cy2a;
- cx2a = cx;
- cy2a = cy;
- }
- if (cy1a >= console_height)
- {
- cx1a = (console_width - 1);
- cy1a = (console_height - 1);
- }
- else if (cx1a >= console_width)
- cx1a = (console_width - 1);
- if (cy2a >= console_height)
- {
- cx2a = 0;
- cy2a = console_height;
- }
- else if (cx2a > console_width)
- cx2a = console_width;
- (*cx1) = cx1a;
- (*cy1) = cy1a;
- (*cx2) = cx2a;
- (*cy2) = cy2a;
-}
-
-static void
-highlight_marked_region (unsigned short cx1, unsigned short cy1,
- unsigned short cx2, unsigned short cy2,
- char hl)
-{
- char * start = (CHAR_HL (cx1, cy1));
- FASTFILL (start, ((CHAR_HL (cx2, cy2)) - start), hl);
-}
-
-static void
-paint_marked_region_segment (unsigned short x1, unsigned short y1,
- unsigned short x2, unsigned short y2)
-{
- if (y1 == y2)
- console_paint (x1, x2, y1, (y1 + 1));
- else
- {
- console_paint (x1, console_width, y1, (y1 + 1));
- if ((y1 + 1) < y2)
- console_paint (0, console_width, (y1 + 1), y2);
- console_paint (0, x2, y2, (y2 + 1));
- }
-}
-
-static void
-disable_marked_region (void)
-{
- console_marked_region_active_p = 0;
- enable_menu_copy_items (0);
-}
-
-static void
-enable_menu_copy_items (int enablep)
-{
- if (console_menu != NULLHANDLE)
- {
- USHORT value = (enablep ? 0 : MIA_DISABLED);
-#if 0
- (void) OS2_menu_set_item_attributes
- (console_pm_qid, console_menu, IDM_CUT, TRUE, MIA_DISABLED, value);
-#endif
- (void) OS2_menu_set_item_attributes
- (console_pm_qid, console_menu, IDM_COPY, TRUE, MIA_DISABLED, value);
- }
-}
-\f
-static void
-console_resize (unsigned short new_pel_width, unsigned short new_pel_height)
-{
- unsigned short new_width = (new_pel_width / CHAR_WIDTH);
- unsigned short new_height = (new_pel_height / CHAR_HEIGHT);
- char * new_chars;
- char * new_highlights;
- unsigned short * new_line_lengths;
-
- if ((console_chars != 0)
- && (new_width == console_width)
- && (new_height == console_height))
- return;
-
- new_chars = (OS_malloc (new_width * new_height));
- new_highlights = (OS_malloc (new_width * new_height));
- new_line_lengths = (OS_malloc ((sizeof (unsigned short)) * new_height));
-
- FASTFILL (new_chars, (new_width * new_height), ' ');
- FASTFILL (new_highlights, (new_width * new_height), '\0');
- FASTFILL (((char *) new_line_lengths),
- ((sizeof (unsigned short)) * new_height),
- 0);
-
- if (console_chars != 0)
- {
- unsigned short xlim
- = ((new_width < console_width) ? new_width : console_width);
- unsigned short oy
- = (((point_y + 1) > new_height) ? ((point_y + 1) - new_height) : 0);
- unsigned short oylim
- = (oy + ((new_height < console_height) ? new_height : console_height));
- char * cfrom = (CHAR_LOC (0, oy));
- char * cto = new_chars;
- char * hfrom = (CHAR_HL (0, oy));
- char * hto = new_highlights;
- unsigned short ny = 0;
- while (oy < oylim)
- {
- FASTCOPY (cfrom, cto, xlim);
- FASTCOPY (hfrom, hto, xlim);
- (new_line_lengths[ny]) = (console_line_lengths[oy]);
- cfrom += console_width;
- cto += new_width;
- hfrom += console_width;
- hto += new_width;
- oy += 1;
- ny += 1;
- }
- OS_free (console_chars);
- OS_free (console_highlights);
- OS_free (console_line_lengths);
- }
- console_pel_width = new_pel_width;
- console_pel_height = new_pel_height;
- console_width = new_width;
- console_height = new_height;
- console_chars = new_chars;
- console_highlights = new_highlights;
- console_line_lengths = new_line_lengths;
- if (point_x >= new_width)
- point_x = (new_width - 1);
- if ((point_y + 1) >= new_height)
- point_y -= ((point_y + 1) - new_height);
- OS2_window_move_cursor (console_wid, (cx2x (point_x)), (cy2y (point_y, 1)));
- OS2_window_invalidate (console_wid,
- 0, console_pel_width,
- 0, console_pel_height);
-}
-
-static void
-console_paint (unsigned short cxl, unsigned short cxh,
- unsigned short cyl, unsigned short cyh)
-{
- if ((cxl < cxh) && (cyl < cyh))
- {
- COLOR foreground = (OS2_ps_get_foreground_color (console_psid));
- COLOR background = (OS2_ps_get_background_color (console_psid));
- unsigned short size = (cxh - cxl);
- char current_hl = '\0';
- while (cyl < cyh)
- {
- unsigned short x = (cx2x (cxl));
- unsigned short y = ((cy2y (cyl, 1)) + CHAR_DESCENDER);
- char * cstart = (CHAR_LOC (cxl, cyl));
- char * hstart = (CHAR_HL (cxl, cyl));
- char * hend = (hstart + size);
- while (hstart < hend)
- {
- unsigned short run_length = (compute_run_length (hstart, hend));
- if (current_hl != (*hstart))
- {
- if ((*hstart) == '\0')
- OS2_ps_set_colors (console_psid, foreground, background);
- else
- OS2_ps_set_colors (console_psid, background, foreground);
- current_hl = (*hstart);
- }
- OS2_ps_draw_text (console_psid, x, y, cstart, run_length);
- x += (run_length * CHAR_WIDTH);
- cstart += run_length;
- hstart += run_length;
- }
- cyl += 1;
- }
- if (current_hl != '\0')
- OS2_ps_set_colors (console_psid, foreground, background);
- }
-}
-
-static unsigned short
-compute_run_length (const char * start, const char * end)
-{
- if (start < end)
- {
- const char * scan = start;
- const char c = (*scan++);
- while (scan < end)
- if ((*scan) == c)
- scan += 1;
- else
- break;
- return (scan - start);
- }
- else
- return (0);
-}
-
-static void
-console_clear (unsigned short xl, unsigned short xh,
- unsigned short yl, unsigned short yh)
-{
- OS2_ps_clear (console_psid,
- (cx2x (xl)), (cx2x (xh)),
- (cy2y (yh, 0)), (cy2y (yl, 0)));
-}
-
-static void
-console_clear_all (void)
-{
- OS2_ps_clear (console_psid, 0, console_pel_width, 0, console_pel_height);
-}
-\f
-int
-OS2_pm_console_getch (void)
-{
- if (console_closedp)
- return (-1);
- if ((readahead_repeat == 0) && (readahead_insert == 0))
- while (1)
- {
- process_events (OS2_msg_fifo_emptyp (pending_events));
- {
- msg_t * message = (OS2_msg_fifo_remove (pending_events));
- ULONG msg = (SM_PM_EVENT_MSG (message));
- MPARAM mp1 = (SM_PM_EVENT_MP1 (message));
- MPARAM mp2 = (SM_PM_EVENT_MP2 (message));
- OS2_destroy_message (message);
- switch (msg)
- {
- case WM_CHAR:
- {
- unsigned short code;
- unsigned char repeat;
- if (translate_key_event (mp1, mp2, (&code), (&repeat)))
- {
- /* The feature that causes Delete and Backspace to
- delete the marked region is disabled because it
- is too much trouble to make the typeahead
- buffer conform to the displayed characters. */
-#if 0
- /* Delete and Backspace must discard the marked
- region if there is one. */
- if ((code == '\177') && (repeat > 0))
- {
- char * region = (extract_marked_region (1));
- if (region != 0)
- {
- OS_free (region);
- repeat -= 1;
- }
- }
-#endif
- if (repeat > 0)
- {
- readahead_char = code;
- readahead_repeat = repeat;
- goto do_read;
- }
- }
- }
- break;
- case WM_CLOSE:
- switch
- (WinMessageBox
- (HWND_DESKTOP,
- NULLHANDLE, /* client window handle */
- "You have requested that this window be closed.\n\n"
- "Press \"Yes\" to close this window and terminate Scheme; "
- "doing so will discard data in unsaved Edwin buffers.\n\n"
- "Press \"No\" to close only this window, leaving Scheme "
- "running; the program will continue to run until the "
- "next time it tries to read from the console.\n\n"
- "Press \"Cancel\" if you don't want to close this window.",
- "Terminate Scheme?",
- 0,
- (MB_YESNOCANCEL | MB_WARNING)))
- {
- case MBID_YES:
- termination_normal (0);
- break;
- case MBID_NO:
- console_closedp = 1;
- OS2_window_close (console_wid);
- OS2_close_qid (console_event_qid);
- OS2_close_std_tqueue (console_tqueue);
- goto do_read;
- }
- break;
- case WM_COMMAND:
- {
- ULONG msg = (SHORT1FROMMP (mp1));
- switch (msg)
- {
- case IDM_PASTE:
- if (do_paste ())
- goto do_read;
- break;
-#if 0
- /* IDM_CUT is disabled because it is too much
- trouble to make the typeahead buffer conform to
- the displayed characters. */
- case IDM_CUT:
-#endif
- case IDM_COPY:
- grab_console_lock ();
- {
- char * region = (extract_marked_region (msg == IDM_CUT));
- if (region != 0)
- {
- OS2_clipboard_write_text (console_pm_qid, region);
- OS_free (region);
- unmark_marked_region ();
- }
- }
- release_console_lock ();
- break;
- }
- }
- break;
- }
- }
- }
- do_read:
- if (readahead_insert != 0)
- {
- char c = (*readahead_insert_scan++);
- if ((*readahead_insert_scan) == '\0')
- {
- OS_free ((void *) readahead_insert);
- readahead_insert = 0;
- }
- return (c);
- }
- if (readahead_repeat != 0)
- {
- readahead_repeat -= 1;
- return (readahead_char);
- }
- return (-1);
-}
-
-static int
-do_paste (void)
-{
- const char * text = (OS2_clipboard_read_text (console_pm_qid));
- if ((text != 0) && ((*text) != '\0'))
- {
- readahead_insert = text;
- readahead_insert_scan = text;
- return (1);
- }
- else
- {
- OS_free ((void *) text);
- return (0);
- }
-}
-\f
-static int
-translate_key_event (MPARAM mp1, MPARAM mp2,
- unsigned short * code, unsigned char * repeat)
-{
- unsigned short flags;
- if (!OS2_translate_wm_char (mp1, mp2, code, (&flags), repeat))
- return (0);
- if ((flags & KC_VIRTUALKEY) != 0)
- switch (*code)
- {
- case VK_BACKSPACE:
- case VK_DELETE:
- (*code) = '\177';
- break;
- case VK_TAB:
- (*code) = '\t';
- break;
- case VK_ESC:
- (*code) = '\033';
- break;
- case VK_SPACE:
- (*code) = ' ';
- break;
- case VK_NEWLINE:
- case VK_ENTER:
- (*code) = '\r';
- break;
- default:
- return (0);
- }
- if (((*code) >= 0200) || ((flags & KC_ALT) != 0))
- return (0);
- if ((flags & KC_CTRL) != 0)
- if ((*code) >= 040)
- (*code) &= 037;
- else
- return (0);
- if ((*code) == 0)
- return (0);
- return (1);
-}
-\f
-void
-OS2_pm_console_write (const char * data, size_t size)
-{
- const char * end = (data + size);
- const char * nonprint;
- if (console_closedp)
- return;
- grab_console_lock ();
- unmark_marked_region ();
- while (data < end)
- {
- nonprint = (find_nonprint (data, end));
- if (data < nonprint)
- while (1)
- {
- unsigned short size = (nonprint - data);
- if (size > (console_width - point_x))
- size = (console_width - point_x);
- FASTCOPY (data, (CHAR_LOC (point_x, point_y)), size);
- FASTFILL ((CHAR_HL (point_x, point_y)), size, '\0');
- OS2_ps_draw_text (console_psid,
- (cx2x (point_x)),
- ((cy2y (point_y, 1)) + CHAR_DESCENDER),
- data,
- size);
- data += size;
- point_x += size;
- (console_line_lengths[point_y]) = point_x;
- if (point_x == console_width)
- {
- do_carriage_return ();
- do_linefeed ();
- }
- if (data == nonprint)
- break;
- }
- if (data < end)
- switch (*data++)
- {
- case '\r':
- do_carriage_return ();
- break;
- case '\012':
- do_linefeed ();
- break;
- case '\f':
- do_formfeed ();
- break;
- case '\b':
- do_backspace ();
- break;
- case '\a':
- do_alert ();
- break;
- }
- }
- OS2_window_move_cursor (console_wid, (cx2x (point_x)), (cy2y (point_y, 1)));
- release_console_lock ();
-}
-
-static const char *
-find_nonprint (const char * start, const char * end)
-{
- while (start < end)
- if (!isprint (*start++))
- return (--start);
- return (end);
-}
-\f
-static void
-do_carriage_return (void)
-{
- point_x = 0;
-}
-
-static void
-do_linefeed (void)
-{
- if (point_y < (console_height - 1))
- point_y += 1;
- else
- {
-#ifdef CONSOLE_WRAP
- point_y = 0;
-#else /* not CONSOLE_WRAP */
- point_y = (console_height - 1);
- FASTCOPY ((CHAR_LOC (0, 1)),
- (CHAR_LOC (0, 0)),
- (point_y * console_width));
- FASTCOPY ((CHAR_HL (0, 1)),
- (CHAR_HL (0, 0)),
- (point_y * console_width));
- FASTCOPY ((LINE_LEN_LOC (1)),
- (LINE_LEN_LOC (0)),
- (point_y * (sizeof (unsigned short))));
- OS2_window_scroll (console_wid,
- 0, console_pel_width,
- 0, (point_y * CHAR_HEIGHT),
- 0, CHAR_HEIGHT);
-#endif /* not CONSOLE_WRAP */
- }
- FASTFILL ((CHAR_LOC (0, point_y)), console_width, ' ');
- FASTFILL ((CHAR_HL (0, point_y)), console_width, '\0');
- (console_line_lengths[point_y]) = 0;
- console_clear (0, console_width, point_y, (point_y + 1));
-}
-
-static void
-do_formfeed (void)
-{
- point_x = 0;
- point_y = 0;
- FASTFILL ((CHAR_LOC (0, 0)), (console_height * console_width), ' ');
- FASTFILL ((CHAR_HL (0, 0)), (console_height * console_width), '\0');
- FASTFILL ((LINE_LEN_LOC (0)),
- (console_height * (sizeof (unsigned short))),
- 0);
- console_clear_all ();
-}
-
-static void
-do_backspace (void)
-{
- if (point_x > 0)
- {
- point_x -= 1;
- (console_line_lengths[point_y]) = point_x;
- }
-}
-
-static void
-do_alert (void)
-{
- WinAlarm (HWND_DESKTOP, WA_ERROR);
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* Resource IDs for OS/2 PM Console Window */
-
-#define ID_PMCON_RESOURCES 2
-
-#define IDM_FILE 1
-#define IDM_EDIT 2
-#define IDM_OPTIONS 3
-#define IDM_HELP 4
-
-#define IDM_EXIT 10
-
-#define IDM_CUT 20
-#define IDM_COPY 21
-#define IDM_PASTE 22
-
-#define IDM_FONT 30
-
-#define IDM_ABOUT 40
-
-#define IDI_BCH 10
-#define IDI_COFFEE 11
-#define IDI_CONSES 12
-#define IDI_EDWIN 13
-#define IDI_ENVIR1 14
-#define IDI_GRAPHICS 15
-#define IDI_LAMBDA 16
-#define IDI_LAMBDA2 17
-#define IDI_LIAR1 18
-#define IDI_LIAR2 19
-#define IDI_LIAR3 20
-#define IDI_MINCER 21
-#define IDI_SHIELD1 22
-#define IDI_SHIELD2 23
-#define IDI_SHIELD3 24
-#define IDI_SHIELD4 25
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* Resource IDs for OS/2 PM Console Window */
-
-#include <os2.h>
-#include "os2pmcon.h"
-
-#ifdef SCHEME
-ICON ID_PMCON_RESOURCES "os2utl\\lambda2.ico"
-#else
-#ifdef BCHSCHEM
-ICON ID_PMCON_RESOURCES "os2utl\\bch.ico"
-#endif
-#endif
-
-ICON IDI_BCH "os2utl\\bch.ico"
-ICON IDI_COFFEE "os2utl\\coffee.ico"
-ICON IDI_CONSES "os2utl\\conses.ico"
-ICON IDI_EDWIN "os2utl\\edwin.ico"
-ICON IDI_ENVIR1 "os2utl\\envir1.ico"
-ICON IDI_GRAPHICS "os2utl\\graphics.ico"
-ICON IDI_LAMBDA "os2utl\\lambda.ico"
-ICON IDI_LAMBDA2 "os2utl\\lambda2.ico"
-ICON IDI_LIAR1 "os2utl\\liar1.ico"
-ICON IDI_LIAR2 "os2utl\\liar2.ico"
-ICON IDI_LIAR3 "os2utl\\liar3.ico"
-ICON IDI_MINCER "os2utl\\mincer.ico"
-ICON IDI_SHIELD1 "os2utl\\shield1.ico"
-ICON IDI_SHIELD2 "os2utl\\shield2.ico"
-ICON IDI_SHIELD3 "os2utl\\shield3.ico"
-ICON IDI_SHIELD4 "os2utl\\shield4.ico"
-
-MENU ID_PMCON_RESOURCES
-{
- SUBMENU "~File", IDM_FILE
- {
- MENUITEM "E~xit", IDM_EXIT
- }
- SUBMENU "~Edit", IDM_EDIT
- {
- MENUITEM "Cu~t\tShift+Delete", IDM_CUT, 0, MIA_DISABLED
- MENUITEM "~Copy\tCtrl+Insert", IDM_COPY
- MENUITEM "~Paste\tShift+Insert", IDM_PASTE
- }
- SUBMENU "~Options", IDM_OPTIONS
- {
- MENUITEM "Set ~font...", IDM_FONT
- }
- SUBMENU "~Help", IDM_HELP
- {
- MENUITEM "~About...", IDM_ABOUT
- }
-}
-
-ACCELTABLE ID_PMCON_RESOURCES
-{
- VK_DELETE, IDM_CUT, AF_VIRTUALKEY | AF_SHIFT
- VK_INSERT, IDM_COPY, AF_VIRTUALKEY | AF_CONTROL
- VK_INSERT, IDM_PASTE, AF_VIRTUALKEY | AF_SHIFT
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#include "os2.h"
-#include "osproc.h"
-#include "osenv.h"
-
-extern const char * OS_working_dir_pathname (void);
-\f
-typedef struct
-{
- PID id;
- unsigned long tick;
- unsigned long sync_tick;
- ULONG raw_reason;
- ULONG reason;
- enum process_status raw_status;
- enum process_status status;
-} process_t;
-#define _PROCESS(process) (process_table [(process)])
-#define PROCESS_ID(process) ((_PROCESS(process)) . id)
-#define PROCESS_TICK(process) ((_PROCESS(process)) . tick)
-#define PROCESS_SYNC_TICK(process) ((_PROCESS(process)) . sync_tick)
-#define PROCESS_RAW_REASON(process) ((_PROCESS(process)) . raw_reason)
-#define PROCESS_REASON(process) ((_PROCESS(process)) . reason)
-#define PROCESS_RAW_STATUS(process) ((_PROCESS(process)) . raw_status)
-#define PROCESS_STATUS(process) ((_PROCESS(process)) . status)
-
-typedef struct
-{
- DECLARE_MSG_HEADER_FIELDS;
- PID pid;
-} sm_child_death_t;
-#define SM_CHILD_DEATH_PID(m) (((sm_child_death_t *) (m)) -> pid)
-
-static void lock_process_status (void);
-static void unlock_process_status (void *);
-static void save_process_state (int);
-static HFILE copy_handle (HFILE);
-static int valid_handle_p (HFILE);
-static void restore_process_state (void *);
-static void restore_stdio (HFILE, HFILE);
-static void transfer_stdio (HFILE, Tchannel, enum process_channel_type);
-static Tprocess allocate_process (void);
-static void allocate_process_abort (void *);
-static void child_wait_thread (void *);
-static Tprocess find_process (PID);
-
-Tprocess OS_process_table_size;
-enum process_jc_status scheme_jc_status;
-
-static HMTX process_lock;
-static process_t * process_table;
-static unsigned long process_tick;
-static unsigned long sync_tick;
-static HEV start_child_event;
-TID OS2_child_wait_tid;
-static qid_t child_wait_qid_reader;
-static qid_t child_wait_qid_writer;
-
-#define PROCESS_STATUS_SYNC(process) \
-{ \
- (PROCESS_STATUS (process)) = (PROCESS_RAW_STATUS (process)); \
- (PROCESS_REASON (process)) = (PROCESS_RAW_REASON (process)); \
- (PROCESS_SYNC_TICK (process)) = (PROCESS_TICK (process)); \
-}
-
-static void
-lock_process_status (void)
-{
- OS2_request_mutex_semaphore (process_lock);
- transaction_record_action (tat_always, unlock_process_status, 0);
-}
-
-static void
-unlock_process_status (void * ignore)
-{
- OS2_release_mutex_semaphore (process_lock);
-}
-
-void
-OS2_initialize_processes (void)
-{
- SET_MSG_TYPE_LENGTH (mt_child_death, sm_child_death_t);
- OS_process_table_size = 4096;
- process_table = (OS_malloc (OS_process_table_size * (sizeof (process_t))));
- {
- Tprocess process;
- for (process = 0; (process < OS_process_table_size); process += 1)
- OS_process_deallocate (process);
- }
- scheme_jc_status = process_jc_status_no_ctty;
- process_tick = 0;
- sync_tick = 0;
- process_lock = (OS2_create_mutex_semaphore (0, 0));
- start_child_event = (OS2_create_event_semaphore (0, 0));
- OS2_make_qid_pair ((& child_wait_qid_reader), (& child_wait_qid_writer));
- OS2_open_qid (child_wait_qid_reader, OS2_scheme_tqueue);
- OS2_child_wait_tid = (OS2_beginthread (child_wait_thread, 0, 0));
-}
-\f
-Tprocess
-OS2_make_subprocess (const char * filename,
- const char * command_line,
- const char * environment,
- const char * working_directory,
- enum process_channel_type channel_in_type,
- Tchannel channel_in,
- enum process_channel_type channel_out_type,
- Tchannel channel_out,
- enum process_channel_type channel_err_type,
- Tchannel channel_err)
-{
- transaction_begin ();
- save_process_state (working_directory != 0);
- transfer_stdio (0, channel_in, channel_in_type);
- transfer_stdio (1, channel_out, channel_out_type);
- transfer_stdio (2, channel_err, channel_err_type);
- if (working_directory != 0)
- OS_set_working_dir_pathname (working_directory);
- {
- Tprocess child;
- char error_object [100];
- RESULTCODES result_codes;
-
- lock_process_status ();
- child = (allocate_process ());
- STD_API_CALL
- (dos_exec_pgm, (error_object,
- (sizeof (error_object)),
- EXEC_ASYNCRESULT,
- ((PSZ) command_line),
- ((PSZ) environment),
- (& result_codes),
- ((PSZ) filename)));
- (PROCESS_ID (child)) = (result_codes . codeTerminate);
- (PROCESS_RAW_STATUS (child)) = process_status_running;
- (PROCESS_RAW_REASON (child)) = 0;
- (PROCESS_TICK (child)) = process_tick;
- PROCESS_STATUS_SYNC (child);
- transaction_commit ();
- /* Wake up the child-wait thread if it's sleeping. */
- (void) OS2_post_event_semaphore (start_child_event);
- return (child);
- }
-}
-\f
-typedef struct
-{
- HFILE std_in;
- HFILE std_out;
- HFILE std_err;
- const char * working_directory;
- int copied_p;
-} process_state_t;
-
-static void
-save_process_state (int save_working_dir_p)
-{
- process_state_t * state = (dstack_alloc (sizeof (process_state_t)));
- (state -> std_in) = NULLHANDLE;
- (state -> std_out) = NULLHANDLE;
- (state -> std_err) = NULLHANDLE;
- (state -> working_directory) = 0;
- (state -> copied_p) = 0;
- transaction_record_action (tat_always, restore_process_state, state);
- if (valid_handle_p (0))
- (state -> std_in) = (copy_handle (0));
- if (valid_handle_p (1))
- (state -> std_out) = (copy_handle (1));
- if (valid_handle_p (2))
- (state -> std_err) = (copy_handle (2));
- if (save_working_dir_p)
- {
- const char * dir = (OS_working_dir_pathname ());
- char * copy = (OS_malloc (strlen (dir)));
- strcpy (copy, dir);
- (state -> working_directory) = copy;
- }
- (state -> copied_p) = 1;
-}
-
-static int
-valid_handle_p (HFILE handle)
-{
- ULONG state;
- return ((dos_query_fh_state (handle, (& state))) == NO_ERROR);
-}
-
-static HFILE
-copy_handle (HFILE handle)
-{
- HFILE target = (-1);
- STD_API_CALL (dos_dup_handle, (handle, (& target)));
- return (target);
-}
-
-static void
-restore_process_state (void * env)
-{
- process_state_t * state = env;
- if (state -> copied_p)
- {
- restore_stdio (0, (state -> std_in));
- restore_stdio (1, (state -> std_out));
- restore_stdio (2, (state -> std_err));
- if ((state -> working_directory) != 0)
- {
- OS_set_working_dir_pathname (state -> working_directory);
- OS_free ((void *) (state -> working_directory));
- }
- }
- if ((state -> std_in) != NULLHANDLE)
- (void) dos_close (state -> std_in);
- if ((state -> std_out) != NULLHANDLE)
- (void) dos_close (state -> std_out);
- if ((state -> std_err) != NULLHANDLE)
- (void) dos_close (state -> std_err);
-}
-
-static void
-restore_stdio (HFILE target, HFILE source)
-{
- if (source != NULLHANDLE)
- (void) dos_dup_handle (source, (& target));
- else
- (void) dos_close (target);
-}
-\f
-static void
-transfer_stdio (HFILE target, Tchannel channel, enum process_channel_type type)
-{
- switch (type)
- {
- case process_channel_type_none:
- STD_API_CALL (dos_close, (target));
- break;
- case process_channel_type_explicit:
- STD_API_CALL (dos_dup_handle, ((CHANNEL_HANDLE (channel)), (& target)));
- break;
- }
- switch (type)
- {
- case process_channel_type_inherit:
- case process_channel_type_explicit:
- /* Turn off the no-inherit bit that is normally turned on by
- Scheme. Note that the no-inherit bit is not shared between a
- dup'ed handle and its original handle, so that changing the
- original does not affect the copy. This simplifies restoring
- the original state. */
- {
- ULONG state;
- STD_API_CALL (dos_query_fh_state, (target, (& state)));
- /* Magic mask 0xFF88 zeroes out high bits and two fields
- required to be zero by the spec. When testing, the high
- bits were not zero, and this caused the system call to
- complain. */
- state &= 0xFF88;
- STD_API_CALL
- (dos_set_fh_state, (target, (state &~ OPEN_FLAGS_NOINHERIT)));
- }
- break;
- }
-}
-
-static Tprocess
-allocate_process (void)
-{
- unsigned int process;
- for (process = 0; (process < OS_process_table_size); process += 1)
- if ((PROCESS_RAW_STATUS (process)) == process_status_free)
- {
- Tprocess * pp = (dstack_alloc (sizeof (Tprocess)));
- (*pp) = process;
- transaction_record_action (tat_abort, allocate_process_abort, pp);
- (PROCESS_RAW_STATUS (process)) = process_status_allocated;
- return (process);
- }
- error_out_of_processes ();
- return (NO_PROCESS);
-}
-
-static void
-allocate_process_abort (void * environment)
-{
- Tprocess process = (* ((Tprocess *) environment));
- if ((PROCESS_RAW_STATUS (process)) == process_status_running)
- dos_kill_process (DKP_PROCESSTREE, (PROCESS_ID (process)));
- OS_process_deallocate (process);
-}
-\f
-void
-OS_process_deallocate (Tprocess process)
-{
- (PROCESS_ID (process)) = 0;
- (PROCESS_RAW_STATUS (process)) = process_status_free;
-}
-
-int
-OS_process_valid_p (Tprocess process)
-{
- if (process > OS_process_table_size)
- return (0);
- switch (PROCESS_RAW_STATUS (process))
- {
- case process_status_exited:
- case process_status_signalled:
- case process_status_running:
- return (1);
- default:
- return (0);
- }
-}
-
-int
-OS_process_continuable_p (Tprocess process)
-{
- return ((PROCESS_RAW_STATUS (process)) == process_status_running);
-}
-
-int
-OS_process_foregroundable_p (Tprocess process)
-{
- return (0);
-}
-
-pid_t
-OS_process_id (Tprocess process)
-{
- return (PROCESS_ID (process));
-}
-
-enum process_jc_status
-OS_process_jc_status (Tprocess process)
-{
- return (process_jc_status_no_ctty);
-}
-
-int
-OS_process_status_sync (Tprocess process)
-{
- transaction_begin ();
- lock_process_status ();
- {
- int result = ((PROCESS_TICK (process)) != (PROCESS_SYNC_TICK (process)));
- if (result)
- PROCESS_STATUS_SYNC (process);
- transaction_commit ();
- return (result);
- }
-}
-
-int
-OS_process_status_sync_all (void)
-{
- transaction_begin ();
- lock_process_status ();
- {
- int result = (process_tick != sync_tick);
- if (result)
- sync_tick = process_tick;
- transaction_commit ();
- return (result);
- }
-}
-
-int
-OS_process_any_status_change (void)
-{
- return (process_tick != sync_tick);
-}
-
-enum process_status
-OS_process_status (Tprocess process)
-{
- return (PROCESS_STATUS (process));
-}
-
-unsigned short
-OS_process_reason (Tprocess process)
-{
- return (PROCESS_REASON (process));
-}
-
-void
-OS_process_send_signal (Tprocess process, int sig)
-{
- OS2_error_unimplemented_primitive ();
-}
-
-void
-OS_process_kill (Tprocess process)
-{
- XTD_API_CALL
- (dos_kill_process, (DKP_PROCESSTREE, (PROCESS_ID (process))),
- {
- if (rc == ERROR_ZOMBIE_PROCESS)
- return;
- });
-}
-
-void
-OS_process_stop (Tprocess process)
-{
- OS2_error_unimplemented_primitive ();
-}
-
-void
-OS_process_interrupt (Tprocess process)
-{
- STD_API_CALL
- (dos_send_signal_exception, ((PROCESS_ID (process)), XCPT_SIGNAL_INTR));
-}
-
-void
-OS_process_quit (Tprocess process)
-{
- STD_API_CALL
- (dos_send_signal_exception, ((PROCESS_ID (process)), XCPT_SIGNAL_BREAK));
-}
-
-void
-OS_process_hangup (Tprocess process)
-{
- /* Edwin assumes that this primitive works. Under unix, the default
- behavior of SIGHUP is to kill the process, so we will emulate
- SIGHUP by killing the process. */
- OS_process_kill (process);
-}
-
-void
-OS_process_continue_background (Tprocess process)
-{
- /* A no-op, this should only be called when OS_process_continuable_p
- is true, i.e. when the process is already running. */
-}
-
-void
-OS_process_continue_foreground (Tprocess process)
-{
- OS2_error_unimplemented_primitive ();
-}
-\f
-void
-OS_process_wait (Tprocess process)
-{
- while (((PROCESS_RAW_STATUS (process)) == process_status_running)
- && ((OS2_message_availablep (child_wait_qid_reader, 1))
- != mat_interrupt))
- {
- msg_t * message = (OS2_receive_message (child_wait_qid_reader, 1, 0));
- PID pid = (SM_CHILD_DEATH_PID (message));
- OS2_destroy_message (message);
- if (pid == (PROCESS_ID (process)))
- break;
- }
-}
-
-static void
-child_wait_thread (void * arg)
-{
- EXCEPTIONREGISTRATIONRECORD registration;
- (void) OS2_thread_initialize ((®istration), QID_NONE);
- main_loop:
- (void) OS2_wait_event_semaphore (start_child_event, 1);
- (void) OS2_reset_event_semaphore (start_child_event);
- while (1)
- {
- RESULTCODES codes;
- PID pid;
- Tprocess process;
- XTD_API_CALL
- (dos_wait_child, (DCWA_PROCESS, DCWW_WAIT, (& codes), (& pid), 0),
- {
- if (rc == ERROR_WAIT_NO_CHILDREN)
- goto main_loop;
- });
- OS2_request_mutex_semaphore (process_lock);
- process = (find_process (pid));
- if (process == NO_PROCESS)
- OS2_release_mutex_semaphore (process_lock);
- else
- {
- if ((codes . codeTerminate) == TC_EXIT)
- {
- (PROCESS_RAW_STATUS (process)) = process_status_exited;
- (PROCESS_RAW_REASON (process)) = (codes . codeResult);
- }
- else
- {
- (PROCESS_RAW_STATUS (process)) = process_status_signalled;
- (PROCESS_RAW_REASON (process)) = 0;
- }
- (PROCESS_TICK (process)) = (++process_tick);
- OS2_release_mutex_semaphore (process_lock);
- {
- msg_t * message = (OS2_create_message (mt_child_death));
- (SM_CHILD_DEATH_PID (message)) = pid;
- OS2_send_message (child_wait_qid_writer, message);
- }
- }
- }
-}
-
-static Tprocess
-find_process (PID pid)
-{
- Tprocess process;
- for (process = 0; (process < OS_process_table_size); process += 1)
- if ((PROCESS_ID (process)) == pid)
- return (process);
- return (NO_PROCESS);
-}
-\f
-/* OBSOLETE */
-
-static const char * rewrite_arguments (const char **);
-static const char * rewrite_environment (const char **);
-
-Tprocess
-OS_make_subprocess (const char * filename,
- const char ** argv,
- const char ** envp,
- const char * working_directory,
- enum process_ctty_type ctty_type,
- char * ctty_name,
- enum process_channel_type channel_in_type,
- Tchannel channel_in,
- enum process_channel_type channel_out_type,
- Tchannel channel_out,
- enum process_channel_type channel_err_type,
- Tchannel channel_err)
-{
- if ((ctty_type != process_ctty_type_none)
- || (channel_in_type == process_channel_type_ctty)
- || (channel_out_type == process_channel_type_ctty)
- || (channel_err_type == process_channel_type_ctty))
- OS2_error_anonymous ();
- return (OS2_make_subprocess (filename,
- (rewrite_arguments (argv)),
- (rewrite_environment (envp)),
- working_directory,
- channel_in_type, channel_in,
- channel_out_type, channel_out,
- channel_err_type, channel_err));
-}
-
-static const char *
-rewrite_arguments (const char ** argv)
-{
- unsigned long nargs = 0;
- unsigned long length = 0;
- while ((argv [nargs]) != 0)
- {
- length += (strlen (argv [nargs]));
- nargs += 1;
- }
- {
- char * result = (dstack_alloc (length + ((nargs < 2) ? 2 : nargs) + 1));
- char * scan_result = result;
- if (nargs == 0)
- (*scan_result++) = '\0';
- else
- {
- unsigned long limit = (nargs - 1);
- unsigned long index = 0;
- while (1)
- {
- const char * arg = (argv [index]);
- while (1)
- {
- char c = (*arg++);
- if (c == '\0')
- break;
- (*scan_result++) = c;
- }
- if (index == limit)
- break;
- (*scan_result++) = ((index == 0) ? '\0' : ' ');
- index += 1;
- }
- }
- (*scan_result++) = '\0';
- (*scan_result) = '\0';
- return (result);
- }
-}
-
-static const char *
-rewrite_environment (const char ** envp)
-{
- unsigned long length = 0;
- const char ** scan_env = envp;
- const char * binding;
- char * result;
- char * scan_result;
-
- if (envp == 0)
- return (0);
- while ((binding = (*scan_env++)) != 0)
- length += ((strlen (binding)) + 1);
- result = (dstack_alloc (length + 1));
- scan_result = result;
- scan_env = envp;
- while ((binding = (*scan_env++)) != 0)
- while (((*scan_result++) = (*binding++)) != '\0')
- ;
- (*scan_result) = '\0';
- return (result);
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#ifndef SCM_OS2PROC_H
-#define SCM_OS2PROC_H
-
-#include "osproc.h"
-
-extern Tprocess OS2_make_subprocess
- (const char *, const char *, const char *, const char *,
- enum process_channel_type, Tchannel,
- enum process_channel_type, Tchannel,
- enum process_channel_type, Tchannel);
-
-#endif /* SCM_OS2PROC_H */
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* This conditional encompasses the entire file. */
-#ifndef DISABLE_SOCKET_SUPPORT
-
-/* This definition is necessary for compilation with newer versions of
- the Developer's Toolkit for OS/2. The newer version default to
- using TCP/IP 4.1, but this code was designed for TCP/IP 4.0. */
-#define TCPV40HDRS
-
-#include "scheme.h"
-#include "prims.h"
-#include "osscheme.h"
-#include "os2.h"
-#include "uxsock.h"
-
-#include <types.h>
-#include <netinet/in.h>
-#include <netdb.h>
-#include <sys/un.h>
-#include <sys/socket.h>
-
-#ifndef INADDR_LOOPBACK
-# define INADDR_LOOPBACK 0x7F000001
-#endif
-
-static Tchannel initialize_stream_socket (int, enum channel_type);
-static msg_t * stream_socket_reader (LHANDLE, qid_t, msg_t *, int *);
-static void stream_socket_operator
- (Tchannel, chop_t, choparg_t, choparg_t, choparg_t);
-\f
-#define VOID_SOCKET_CALL(proc, args) \
-{ \
- while ((proc args) < 0) \
- { \
- if ((sock_errno ()) != SOCEINTR) \
- OS2_error_system_call ((sock_errno ()), syscall_ ## proc); \
- deliver_pending_interrupts (); \
- } \
-}
-
-#define VALUE_SOCKET_CALL(proc, args, var) \
-{ \
- while (1) \
- { \
- int rc = (proc args); \
- if (rc >= 0) \
- { \
- var = rc; \
- break; \
- } \
- if ((sock_errno ()) != SOCEINTR) \
- OS2_error_system_call ((sock_errno ()), syscall_ ## proc); \
- deliver_pending_interrupts (); \
- } \
-}
-
-static void
-socket_close_on_abort_1 (void * sp)
-{
- (void) soclose (* ((int *) sp));
-}
-
-static void
-socket_close_on_abort (int s)
-{
- int * sp = (dstack_alloc (sizeof (int)));
- (*sp) = s;
- transaction_record_action (tat_abort, socket_close_on_abort_1, sp);
-}
-\f
-Tchannel
-OS_open_tcp_stream_socket (void * host, unsigned int port)
-{
- int s;
- struct sockaddr_in address;
-
- transaction_begin ();
- VALUE_SOCKET_CALL (socket, (PF_INET, SOCK_STREAM, 0), s);
- socket_close_on_abort (s);
- memset ((&address), 0, (sizeof (address)));
- (address . sin_family) = AF_INET;
- memcpy ((& (address . sin_addr)), host, (sizeof (struct in_addr)));
- (address . sin_port) = port;
- VOID_SOCKET_CALL
- (connect, (s,
- ((struct sockaddr *) (&address)),
- (sizeof (address))));
- return (initialize_stream_socket (s, channel_type_tcp_stream_socket));
-}
-
-Tchannel
-OS_open_unix_stream_socket (const char * filename)
-{
- int s;
- struct sockaddr_un address;
-
- transaction_begin ();
- VALUE_SOCKET_CALL (socket, (PF_OS2, SOCK_STREAM, 0), s);
- socket_close_on_abort (s);
- memset ((&address), 0, (sizeof (address)));
- (address . sun_family) = AF_OS2;
- strncpy ((address . sun_path), filename, (sizeof (address . sun_path)));
- VOID_SOCKET_CALL
- (connect, (s,
- ((struct sockaddr *) (&address)),
- (sizeof (address))));
- return (initialize_stream_socket (s, channel_type_unix_stream_socket));
-}
-
-int
-OS_get_service_by_name (const char * service_name, const char * protocol_name)
-{
- struct servent * entry
- = (getservbyname (((char *) service_name),
- ((char *) protocol_name)));
- return ((entry == 0) ? (-1) : (entry -> s_port));
-}
-
-unsigned long
-OS_get_service_by_number (const unsigned long port_number)
-{
- return ((unsigned long) (htons ((unsigned short) port_number)));
-}
-
-unsigned int
-OS_host_address_length (void)
-{
- return (sizeof (struct in_addr));
-}
-
-char **
-OS_get_host_by_name (const char * host_name)
-{
- struct hostent * entry = (gethostbyname ((char *) host_name));
- return ((entry == 0) ? 0 : (entry -> h_addr_list));
-}
-
-#define HOSTNAMESIZE 1024
-
-const char *
-OS_get_host_name (void)
-{
- char host_name [HOSTNAMESIZE];
- if (gethostname (host_name, HOSTNAMESIZE))
- OS2_error_anonymous ();
- {
- char * result = (OS_malloc ((strlen (host_name)) + 1));
- strcpy (result, host_name);
- return (result);
- }
-}
-
-const char *
-OS_canonical_host_name (const char * host_name)
-{
- struct hostent * entry = (gethostbyname ((char *) host_name));
- if (entry == 0)
- return (0);
- {
- char * result = (OS_malloc ((strlen (entry -> h_name)) + 1));
- strcpy (result, (entry -> h_name));
- return (result);
- }
-}
-
-const char *
-OS_get_host_by_address (const char * host_addr)
-{
- struct hostent * entry
- = (gethostbyaddr (((char *) host_addr),
- (OS_host_address_length ()),
- AF_INET));
- if (entry == 0)
- return (0);
- {
- char * result = (OS_malloc ((strlen (entry -> h_name)) + 1));
- strcpy (result, (entry -> h_name));
- return (result);
- }
-}
-
-void
-OS_host_address_any (void * addr)
-{
- (((struct in_addr *) addr) -> s_addr) = (htonl (INADDR_ANY));
-}
-
-void
-OS_host_address_loopback (void * addr)
-{
- (((struct in_addr *) addr) -> s_addr) = (htonl (INADDR_LOOPBACK));
-}
-\f
-Tchannel
-OS_create_tcp_server_socket (void)
-{
- int s;
- VALUE_SOCKET_CALL (socket, (PF_INET, SOCK_STREAM, 0), s);
- return (initialize_stream_socket (s, channel_type_tcp_server_socket));
-}
-
-void
-OS_bind_tcp_server_socket (Tchannel channel, void * host, unsigned int port)
-{
- struct sockaddr_in address;
- memset ((&address), 0, (sizeof (address)));
- (address . sin_family) = AF_INET;
- memcpy ((& (address . sin_addr)), host, (sizeof (address . sin_addr)));
- (address . sin_port) = port;
- VOID_SOCKET_CALL
- (bind, (((int) (CHANNEL_HANDLE (channel))),
- ((struct sockaddr *) (&address)),
- (sizeof (struct sockaddr_in))));
-}
-
-#ifndef SOCKET_LISTEN_BACKLOG
-#define SOCKET_LISTEN_BACKLOG 5
-#endif
-
-void
-OS_listen_tcp_server_socket (Tchannel channel)
-{
- VOID_SOCKET_CALL
- (listen, (((int) (CHANNEL_HANDLE (channel))), SOCKET_LISTEN_BACKLOG));
-}
-
-Tchannel
-OS_tcp_server_connection_accept (Tchannel channel,
- void * peer_host, unsigned int * peer_port)
-{
- static struct sockaddr_in address;
- int s;
-
- transaction_begin ();
- while (1)
- {
- int address_length = (sizeof (struct sockaddr_in));
- s = (accept (((int) (CHANNEL_HANDLE (channel))),
- ((struct sockaddr *) (&address)),
- (&address_length)));
- if (s >= 0)
- break;
- if ((sock_errno ()) == SOCEWOULDBLOCK)
- return (NO_CHANNEL);
- if ((sock_errno ()) != SOCEINTR)
- OS2_error_system_call ((sock_errno ()), syscall_accept);
- deliver_pending_interrupts ();
- }
- socket_close_on_abort (s);
- if (peer_host != 0)
- memcpy (peer_host, (& (address . sin_addr)), (sizeof (struct in_addr)));
- if (peer_port != 0)
- (*peer_port) = (address . sin_port);
- return (initialize_stream_socket (s, channel_type_tcp_stream_socket));
-}
-\f
-static Tchannel
-initialize_stream_socket (int s, enum channel_type type)
-{
- Tchannel channel = (OS2_allocate_channel ());
- OS2_initialize_channel (channel, s, (CHANNEL_READ | CHANNEL_WRITE), type);
- OS2_start_channel_thread (channel,
- stream_socket_reader,
- stream_socket_operator);
- transaction_commit ();
- return (channel);
-}
-
-static msg_t *
-stream_socket_reader (LHANDLE handle, qid_t qid, msg_t * message, int * eofp)
-{
- int nread;
- do
- nread = (recv (((int) handle),
- (SM_READAHEAD_DATA (message)),
- (sizeof (SM_READAHEAD_DATA (message))),
- 0));
- while ((nread < 0) && ((sock_errno ()) == SOCEINTR));
- if (nread >= 0)
- {
- (SM_READAHEAD_SIZE (message)) = nread;
- (*eofp) = (nread == 0);
- return (message);
- }
- OS2_destroy_message (message);
- if ((sock_errno ()) == SOCENOTSOCK)
- /* Socket was closed on us -- no need to do anything else. */
- return (0);
- (*eofp) = 0;
- return (OS2_make_syscall_error ((sock_errno ()), syscall_recv));
-}
-
-static void
-stream_socket_operator (Tchannel channel, chop_t operation,
- choparg_t arg1, choparg_t arg2, choparg_t arg3)
-{
- switch (operation)
- {
- case chop_read:
- OS2_channel_thread_read_op (channel, arg1, arg2, arg3);
- break;
- case chop_write:
- VALUE_SOCKET_CALL
- (send, (((int) (CHANNEL_HANDLE (channel))),
- ((char *) arg1),
- ((size_t) arg2),
- 0),
- (* ((long *) arg3)));
- break;
- case chop_close:
- OS2_channel_thread_close (channel);
- VOID_SOCKET_CALL (soclose, ((int) (CHANNEL_HANDLE (channel))));
- break;
- default:
- OS2_logic_error ("Unknown operation for stream socket.");
- break;
- }
-}
-
-#endif /* not DISABLE_SOCKET_SUPPORT */
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#include "os2.h"
-#include "prims.h"
-\f
-unsigned int
-OS_terminal_get_ispeed (Tchannel channel)
-{
- return (9600);
-}
-
-unsigned int
-OS_terminal_get_ospeed (Tchannel channel)
-{
- return (9600);
-}
-
-void
-OS_terminal_set_ispeed (Tchannel channel, unsigned int baud)
-{
-}
-
-void
-OS_terminal_set_ospeed (Tchannel channel, unsigned int baud)
-{
-}
-
-unsigned int
-arg_baud_index (unsigned int argument)
-{
- return (arg_nonnegative_integer (argument));
-}
-
-unsigned int
-OS_baud_index_to_rate (unsigned int index)
-{
- return (index);
-}
-
-int
-OS_baud_rate_to_index (unsigned int rate)
-{
- return (rate);
-}
-
-unsigned int
-OS_terminal_state_size (void)
-{
- return (0);
-}
-
-void
-OS_terminal_get_state (Tchannel channel, void * statep)
-{
-}
-
-void
-OS_terminal_set_state (Tchannel channel, void * statep)
-{
-}
-\f
-int
-OS_terminal_cooked_output_p (Tchannel channel)
-{
- int flag;
- OS2_channel_operation (channel, chop_output_cooked,
- ((choparg_t) (-1)), ((choparg_t) (&flag)), 0);
- return (flag);
-}
-
-void
-OS_terminal_raw_output (Tchannel channel)
-{
- OS2_channel_operation (channel, chop_output_cooked, ((choparg_t) 0), 0, 0);
-}
-
-void
-OS_terminal_cooked_output (Tchannel channel)
-{
- OS2_channel_operation (channel, chop_output_cooked, ((choparg_t) 1), 0, 0);
-}
-
-int
-OS_terminal_buffered_p (Tchannel channel)
-{
- int flag;
- OS2_channel_operation (channel, chop_input_buffered,
- ((choparg_t) (-1)), ((choparg_t) (&flag)), 0);
- return (flag);
-}
-
-void
-OS_terminal_buffered (Tchannel channel)
-{
- OS2_channel_operation (channel, chop_input_buffered, ((choparg_t) 1), 0, 0);
-}
-
-void
-OS_terminal_nonbuffered (Tchannel channel)
-{
- OS2_channel_operation (channel, chop_input_buffered, ((choparg_t) 0), 0, 0);
-}
-
-void
-OS_terminal_flush_input (Tchannel channel)
-{
- OS2_channel_operation (channel, chop_input_flush, 0, 0, 0);
-}
-
-void
-OS_terminal_flush_output (Tchannel channel)
-{
- OS2_channel_operation (channel, chop_output_flush, 0, 0, 0);
-}
-
-void
-OS_terminal_drain_output (Tchannel channel)
-{
- OS2_channel_operation (channel, chop_output_drain, 0, 0, 0);
-}
-
-int
-OS_job_control_p (void)
-{
- return (0);
-}
-
-int
-OS_have_ptys_p (void)
-{
- return (0);
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#include "os2.h"
-#include "prims.h"
-#include "errors.h"
-
-#ifdef __IBMC__
-#define HAVE_BEGINTHREAD
-#endif
-
-#ifdef __WATCOMC__
-#include <process.h>
-#define HAVE_BEGINTHREAD
-#endif
-
-#ifdef __EMX__
-#define HAVE_BEGINTHREAD
-#endif
-
-extern void OS2_create_msg_queue (void);
-extern ULONG APIENTRY OS2_subthread_exception_handler
- (PEXCEPTIONREPORTRECORD, PEXCEPTIONREGISTRATIONRECORD, PCONTEXTRECORD,
- PVOID);
-\f
-TID
-OS2_beginthread (thread_procedure_t procedure,
- void * argument,
- unsigned int stack_size)
-{
- ULONG ss
- = ((stack_size < 0x2000)
- ? 0x2000
- : ((stack_size + 0xfff) & (~0xfff)));
-#ifdef HAVE_BEGINTHREAD
- int result = (_beginthread (procedure, 0, ss, argument));
- if (result < 0)
- OS2_error_system_call (ERROR_MAX_THRDS_REACHED, syscall_beginthread);
- return (result);
-#else /* not HAVE_BEGINTHREAD */
- TID tid;
- STD_API_CALL (dos_create_thread,
- ((&tid), ((PFNTHREAD) procedure), ((ULONG) argument), 0, ss));
- return (tid);
-#endif /* not HAVE_BEGINTHREAD */
-}
-
-void
-OS2_endthread (void)
-{
- DosUnsetExceptionHandler (THREAD_EXCEPTION_HANDLER ());
-#ifdef HAVE_BEGINTHREAD
- _endthread ();
-#else
- dos_exit (EXIT_THREAD, 0);
-#endif
-}
-
-void
-OS2_kill_thread (TID tid)
-{
- STD_API_CALL (dos_kill_thread, (tid));
-}
-
-TID
-OS2_current_tid (void)
-{
- PTIB ptib;
- PPIB ppib;
- STD_API_CALL (dos_get_info_blocks, ((&ptib), (&ppib)));
- return (ptib -> tib_ptib2 -> tib2_ultid);
-}
-
-#ifndef __IBMC__
-#define MAX_TID 999
-static thread_store_t * thread_store_array [MAX_TID + 1];
-
-thread_store_t **
-OS2_threadstore (void)
-{
- TID tid = (OS2_current_tid ());
- if (tid > MAX_TID)
- OS2_logic_error ("Unexpectedly large TID.");
- return (& (thread_store_array [tid]));
-}
-#endif
-\f
-PID OS2_scheme_pid;
-TID OS2_scheme_tid;
-
-static void thread_initialize_1 (qid_t);
-static void restore_errors (void *);
-static void signal_error (msg_t *);
-static void ignore_error (msg_t *);
-static void send_error (msg_t *);
-
-void
-OS2_initialize_scheme_thread (void)
-{
- SET_MSG_TYPE_LENGTH (mt_syscall_error, sm_syscall_error_t);
- SET_MSG_TYPE_LENGTH (mt_error, sm_error_t);
- SET_MSG_TYPE_LENGTH (mt_kill_request, sm_kill_request_t);
- {
- PTIB ptib;
- PPIB ppib;
- STD_API_CALL (dos_get_info_blocks, ((&ptib), (&ppib)));
- OS2_scheme_pid = (ppib -> pib_ulpid);
- OS2_scheme_tid = (ptib -> tib_ptib2 -> tib2_ultid);
- }
- thread_initialize_1 (QID_NONE);
- (THREAD_ERROR_HOOK ()) = signal_error;
-}
-
-int
-OS2_thread_initialize (PEXCEPTIONREGISTRATIONRECORD registration,
- qid_t error_qid)
-{
- /* Every thread has a message queue, so that we can use message
- dialogs to report fatal errors to the user. Otherwise, Scheme
- will just die with no explanation. */
- OS2_create_msg_queue ();
- return (OS2_thread_initialize_1 (registration, error_qid));
-}
-
-int
-OS2_thread_initialize_1 (PEXCEPTIONREGISTRATIONRECORD registration,
- qid_t error_qid)
-{
- thread_initialize_1 (error_qid);
- (registration -> ExceptionHandler) = OS2_subthread_exception_handler;
- DosSetExceptionHandler (registration);
- (THREAD_EXCEPTION_HANDLER ()) = registration;
- (THREAD_ERROR_HOOK ()) = send_error;
- return (setjmp (THREAD_ERROR_RESTART ()));
-}
-
-static void
-thread_initialize_1 (qid_t error_qid)
-{
- (* (OS2_threadstore ())) = (OS_malloc (sizeof (thread_store_t)));
- (THREAD_ERROR_QUEUE ()) = error_qid;
- ((THREAD_FATAL_ERROR_BUFFER ()) [0]) = '\0';
-}
-
-char *
-OS2_thread_fatal_error_buffer (void)
-{
- /* The default buffer may get used if an error occurs very early in
- a thread, before the regular error buffer is allocated. This can
- easily happen in the Scheme thread, but shouldn't happen in the
- other threads. */
- static char default_buffer [1024] = "";
- return
- (((* (OS2_threadstore ())) == 0)
- ? default_buffer
- : (THREAD_FATAL_ERROR_BUFFER ()));
-}
-\f
-int
-OS2_error_message_p (msg_t * message)
-{
- msg_type_t type = (MSG_TYPE (message));
- return ((type == mt_syscall_error) || (type == mt_error));
-}
-
-void
-OS2_handle_error_message (msg_t * message)
-{
- (* (THREAD_ERROR_HOOK ())) (message);
-}
-
-void
-OS2_ignore_errors (void)
-{
- error_hook_t * hp = (dstack_alloc (sizeof (error_hook_t)));
- (*hp) = (THREAD_ERROR_HOOK ());
- transaction_record_action (tat_always, restore_errors, hp);
- (THREAD_ERROR_HOOK ()) = ignore_error;
-}
-
-static void
-restore_errors (void * hp)
-{
- (THREAD_ERROR_HOOK ()) = (* ((error_hook_t *) hp));
-}
-
-void
-OS2_error_system_call (int code, enum syscall_names name)
-{
- OS2_handle_error_message (OS2_make_syscall_error (code, name));
-}
-
-void
-OS2_error_anonymous (void)
-{
- OS2_handle_error_message (OS2_make_error (ERR_EXTERNAL_RETURN));
-}
-
-void
-OS2_error_unimplemented_primitive (void)
-{
- OS2_handle_error_message (OS2_make_error (ERR_UNDEFINED_PRIMITIVE));
-}
-
-void
-OS2_error_out_of_channels (void)
-{
- OS2_handle_error_message (OS2_make_error (ERR_OUT_OF_FILE_HANDLES));
-}
-\f
-static void
-signal_error (msg_t * message)
-{
- switch (MSG_TYPE (message))
- {
- case mt_syscall_error:
- {
- int code = (SM_SYSCALL_ERROR_CODE (message));
- enum syscall_names name = (SM_SYSCALL_ERROR_NAME (message));
- OS2_destroy_message (message);
- error_system_call (code, name);
- }
- break;
- case mt_error:
- {
- long code = (SM_ERROR_CODE (message));
- OS2_destroy_message (message);
- signal_error_from_primitive (code);
- }
- break;
- default:
- OS2_logic_error ("Non-error message passed to signal_error.");
- break;
- }
-}
-
-static void
-ignore_error (msg_t * message)
-{
-}
-
-static void
-send_error (msg_t * message)
-{
- if ((THREAD_ERROR_QUEUE ()) == QID_NONE)
- OS2_logic_error ("send_error called when no error queue defined.");
- OS2_send_message ((THREAD_ERROR_QUEUE ()), message);
- longjmp ((THREAD_ERROR_RESTART ()), 1);
-}
-
-msg_t *
-OS2_make_syscall_error (int code, enum syscall_names name)
-{
- msg_t * message = (OS2_create_message (mt_syscall_error));
- (SM_SYSCALL_ERROR_CODE (message)) = code;
- (SM_SYSCALL_ERROR_NAME (message)) = name;
- return (message);
-}
-
-msg_t *
-OS2_make_error (long code)
-{
- msg_t * message = (OS2_create_message (mt_error));
- (SM_ERROR_CODE (message)) = code;
- return (message);
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#ifndef SCM_OS2THRD_H
-#define SCM_OS2THRD_H
-\f
-typedef void (* thread_procedure_t) (void *);
-typedef void (* error_hook_t) (msg_t *);
-
-typedef struct
-{
- error_hook_t error_hook;
- jmp_buf error_restart;
- PEXCEPTIONREGISTRATIONRECORD exception_handler;
- qid_t error_queue;
- char fatal_error_buffer [1024];
-} thread_store_t;
-#define THREAD_ERROR_HOOK() ((* (OS2_threadstore ())) -> error_hook)
-#define THREAD_ERROR_RESTART() ((* (OS2_threadstore ())) -> error_restart)
-#define THREAD_ERROR_QUEUE() ((* (OS2_threadstore ())) -> error_queue)
-#define THREAD_FATAL_ERROR_BUFFER() \
- ((* (OS2_threadstore ())) -> fatal_error_buffer)
-#define THREAD_EXCEPTION_HANDLER() \
- ((* (OS2_threadstore ())) -> exception_handler)
-
-typedef struct
-{
- DECLARE_MSG_HEADER_FIELDS;
- int code;
- enum syscall_names name;
-} sm_syscall_error_t;
-#define SM_SYSCALL_ERROR_CODE(m) (((sm_syscall_error_t *) (m)) -> code)
-#define SM_SYSCALL_ERROR_NAME(m) (((sm_syscall_error_t *) (m)) -> name)
-
-typedef struct
-{
- DECLARE_MSG_HEADER_FIELDS;
- long code;
-} sm_error_t;
-#define SM_ERROR_CODE(m) (((sm_error_t *) (m)) -> code)
-
-typedef msg_t sm_kill_request_t;
-#define OS2_make_kill_request() OS2_create_message (mt_kill_request)
-
-extern TID OS2_beginthread (thread_procedure_t, void *, unsigned int);
-extern void OS2_endthread (void);
-extern void OS2_kill_thread (TID);
-extern TID OS2_current_tid (void);
-
-#ifdef __IBMC__
-#define OS2_threadstore() ((thread_store_t **) (_threadstore ()))
-#else
-extern thread_store_t ** OS2_threadstore (void);
-#endif
-
-extern PID OS2_scheme_pid;
-extern TID OS2_scheme_tid;
-
-extern int OS2_thread_initialize (PEXCEPTIONREGISTRATIONRECORD, qid_t);
-extern int OS2_thread_initialize_1 (PEXCEPTIONREGISTRATIONRECORD, qid_t);
-extern int OS2_error_message_p (msg_t *);
-extern void OS2_handle_error_message (msg_t *);
-extern void OS2_ignore_errors (void);
-extern void OS2_error_system_call (int, enum syscall_names);
-extern void OS2_error_anonymous (void);
-extern void OS2_error_unimplemented_primitive (void);
-extern void OS2_error_out_of_channels (void);
-extern msg_t * OS2_make_syscall_error (int, enum syscall_names);
-extern msg_t * OS2_make_error (long);
-
-#endif /* SCM_OS2THRD_H */
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#define SCM_OS2TOP_C
-#define INCL_WIN
-
-#include "scheme.h"
-#include "os2.h"
-#include "ostop.h"
-#include "option.h"
-
-#ifndef DISABLE_SOCKET_SUPPORT
-# include <nerrno.h>
-#endif
-
-extern void execute_reload_cleanups (void);
-
-extern void OS2_initialize_channels (void);
-extern void OS2_initialize_channel_thread_messages (void);
-extern void OS2_initialize_console (void);
-extern void OS2_initialize_directory_reader (void);
-extern void OS2_initialize_environment (void);
-extern void OS2_initialize_exception_handling (void);
-extern void OS2_initialize_keyboard_interrupts (void);
-extern void OS2_initialize_malloc (void);
-extern void OS2_initialize_message_queues (void);
-extern void OS2_initialize_pm_thread (void);
-extern void OS2_initialize_processes (void);
-extern void OS2_initialize_scheme_thread (void);
-extern void OS2_initialize_tty (void);
-extern void OS2_initialize_window_primitives (void);
-
-extern void OS2_check_message_length_initializations (void);
-extern void * OS2_malloc_noerror (unsigned long);
-extern void * OS2_realloc_noerror (void *, unsigned long);
-
-extern void OS2_create_msg_queue (void); /* forward reference */
-
-extern const char * OS_Name;
-extern const char * OS_Variant;
-extern HMTX OS2_create_queue_lock;
-
-static const char * OS2_version_string (void);
-static void initialize_locks (void);
-
-static int initialization_completed = 0;
-\f
-int
-OS_under_emacs_p (void)
-{
- return (option_emacs_subprocess);
-}
-
-void
-OS2_initialize_early (void)
-{
- initialization_completed = 0;
- OS2_initialize_malloc ();
- initialize_locks ();
- OS2_create_msg_queue ();
-}
-
-void
-OS_initialize (void)
-{
- (void) DosError (FERR_DISABLEEXCEPTION | FERR_DISABLEHARDERR);
- OS2_initialize_exception_handling ();
- OS2_initialize_message_queues ();
- OS2_initialize_scheme_thread ();
- OS2_initialize_pm_thread ();
- OS2_initialize_channels ();
- OS2_initialize_channel_thread_messages ();
- OS2_initialize_keyboard_interrupts ();
- OS2_initialize_console ();
- OS2_initialize_environment ();
- OS2_initialize_directory_reader ();
- OS2_initialize_tty ();
- OS2_initialize_window_primitives ();
- OS2_initialize_processes ();
- initialization_completed = 1;
- /* This must be after all of the initializations that can set
- message lengths. */
- OS2_check_message_length_initializations ();
- OS_Name = "OS/2";
- {
- const char * version = (OS2_version_string ());
- OS_Variant = (OS_malloc ((strlen (OS_Name)) + (strlen (version)) + 2));
- sprintf (((char *) OS_Variant), "%s %s", OS_Name, version);
- }
-}
-
-void
-OS_announcement (void)
-{
-}
-
-static const char *
-OS2_version_string (void)
-{
- ULONG major = (OS2_system_variable (QSV_VERSION_MAJOR));
- ULONG minor = (OS2_system_variable (QSV_VERSION_MINOR));
- char revision = (OS2_system_variable (QSV_VERSION_REVISION));
- static char result [64];
- char sminor [16];
- char srev [2];
- if ((major == 20) && (minor >= 30))
- {
- major = (minor - (minor % 10));
- minor = ((minor % 10) * 10);
- }
- if ((minor < 10) && (minor != 0))
- sprintf (sminor, "0%d", minor);
- else
- sprintf (sminor, "%d",
- (((minor < 100) && ((minor % 10) == 0)) ? (minor / 10) : minor));
- if (revision == '\0')
- sprintf (srev, "");
- else
- sprintf (srev, "%c", revision);
- sprintf (result, "%d.%s%s", (major / 10), sminor, srev);
- return (result);
-}
-\f
-#define PAGESIZE 4096
-#define PAGE_PERMS (PAG_READ | PAG_WRITE | PAG_EXECUTE)
-#define N_STACK_GUARD_PAGES 2
-
-#define ROUND_UP_TO_PAGE(size) \
- (((((size) + (PAGESIZE - 1)) / PAGESIZE) + N_STACK_GUARD_PAGES + 1) \
- * PAGESIZE)
-
-typedef struct
-{
- char * low;
- unsigned int enabled_p : 1;
-} guard_page_state_t;
-
-static guard_page_state_t guard_page_states [N_STACK_GUARD_PAGES];
-
-static void *
-commit_heap_helper (void * base, unsigned long size)
-{
- /* Complicated arrangement to detect stack overflow with reasonable
- reliability. We allocate three extra pages past the end of the
- stack; the first two (adjacent to the stack) are committed as
- guard pages so that OS/2 will deliver an exception when we access
- them. If we overrun the first guard page, the trap handler
- should recognize this and terminate Scheme gracefully, using the
- second guard page as its stack. The third page, on the other
- side of the guard pages, is uncommitted -- if for some reason we
- overrun the second guard page, this uncommitted page will cause a
- hard fault that will kill Scheme right away.
-
- This is slightly kludgey, because we take advantage of the fact
- that the Scheme stack occupies the low-order addresses in the
- allocated block, and particularly that the stack grows towards
- lower addresses. Thus we can put the guard pages just below the
- allocated block. If the memory layout is altered, this will have
- to change. The reason for this fragile implementation is that it
- requires the least change to the existing memory allocation
- mechanism. */
- char * p = base;
- /* Skip uncommitted page, then commit rest of memory block. */
- p += PAGESIZE;
- if ((dos_set_mem (p, (size - PAGESIZE), (PAG_COMMIT | PAG_DEFAULT)))
- != NO_ERROR)
- return (0);
- /* Initialize the stack guard pages and get pointer to first page
- past the guard pages. */
- {
- guard_page_state_t * scan = guard_page_states;
- guard_page_state_t * end = (scan + N_STACK_GUARD_PAGES);
- while (scan < end)
- {
- (scan -> low) = p;
- (scan -> enabled_p) = 0;
- scan += 1;
- p += PAGESIZE;
- }
- OS2_stack_reset ();
- }
- return (p);
-}
-\f
-static void
-enable_stack_guard (guard_page_state_t * page, int enable_p)
-{
- (void) dos_set_mem ((page -> low),
- PAGESIZE,
- (enable_p ? (PAGE_PERMS | PAG_GUARD) : PAGE_PERMS));
- (page -> enabled_p) = enable_p;
-}
-
-int
-OS2_disable_stack_guard (void * p)
-{
- char * cp = p;
- guard_page_state_t * scan = guard_page_states;
- guard_page_state_t * end = (scan + N_STACK_GUARD_PAGES);
- while (1)
- {
- if (scan == end)
- return (0);
- if (((scan -> low) <= cp) && (cp < ((scan -> low) + PAGESIZE)))
- {
- enable_stack_guard (scan, 0);
- return (1);
- }
- scan += 1;
- }
-}
-
-void
-OS2_stack_reset (void)
-{
- {
- guard_page_state_t * scan = guard_page_states;
- guard_page_state_t * end = (scan + N_STACK_GUARD_PAGES);
- while (1)
- {
- if (scan == end)
- return;
- if (! (scan -> enabled_p))
- break;
- scan += 1;
- }
- }
- enable_stack_guard ((&guard_page_states[1]), 0);
- {
- SCHEME_OBJECT * p = ((SCHEME_OBJECT *) ((guard_page_states[1]) . low));
- (*p) = (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, p));
- }
- {
- guard_page_state_t * scan = guard_page_states;
- guard_page_state_t * end = (scan + N_STACK_GUARD_PAGES);
- while (scan < end)
- enable_stack_guard ((scan++), 1);
- }
-}
-
-int
-OS2_stack_overflowed_p (void)
-{
- SCHEME_OBJECT * p = ((SCHEME_OBJECT *) ((guard_page_states[1]) . low));
- return
- ((! ((guard_page_states[1]) . enabled_p))
- && ((*p) != (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, p))));
-}
-\f
-#if 0
-
-/* This is an attempt to allocate Scheme's memory as early as
- possible, in order to obtain the lowest possible addresses before
- `malloc' grabs them for some uninteresting purpose. However, there
- are two reasons not to do this: first, it doesn't seem to gain any
- advantage at present (in OS/2 Warp 3.0 with C Set++/2 2.1), because
- the returned addresses are about the same in both cases. Second,
- this sometimes causes a fatal error in the debugger, apparently
- because it cares about how much memory the debugged process has
- allocated, even if it's not committed. */
-
-static void * OS2_heap_base;
-
-void
-OS2_alloc_heap (void)
-{
- APIRET rc
- = (dos_alloc_mem ((& OS2_heap_base),
- 0x04000000,
- (PAG_EXECUTE | PAG_READ | PAG_WRITE)));
- if (rc != NO_ERROR)
- {
- fprintf (stderr, "Can't allocate heap memory.");
- fflush (stderr);
- exit (EXIT_FAILURE);
- }
-}
-
-void *
-OS2_commit_heap (unsigned long size)
-{
- return (commit_heap_helper (OS2_heap_base, (ROUND_UP_TO_PAGE (size))));
-}
-
-#else
-
-void
-OS2_alloc_heap (void)
-{
-}
-
-void *
-OS2_commit_heap (unsigned long size)
-{
- unsigned long actual = (ROUND_UP_TO_PAGE (size));
- void * heap_base;
- APIRET rc
- = (dos_alloc_mem ((& heap_base),
- actual,
- (PAG_EXECUTE | PAG_READ | PAG_WRITE)));
- return ((rc == NO_ERROR) ? (commit_heap_helper (heap_base, actual)) : 0);
-}
-
-#endif
-\f
-void
-OS2_create_msg_queue (void)
-{
- /* Create a PM message queue. This allows us to use message boxes
- to report fatal errors. */
- HAB hab = (WinInitialize (0));
- HMQ hmq;
- if (hab == NULLHANDLE)
- OS2_logic_error ("Unable to initialize anchor block.");
- hmq = (WinCreateMsgQueue (hab, 0));
- if (hmq == NULLHANDLE)
- OS2_logic_error ("Unable to create PM message queue.");
- /* This tells the system that this message queue should not receive
- WM_QUIT messages. */
- WinCancelShutdown (hmq, TRUE);
-}
-
-void
-OS2_message_box (const char * title, const char * message, int errorp)
-{
- (void) WinMessageBox (HWND_DESKTOP,
- NULLHANDLE,
- ((PSZ) message),
- ((PSZ) title),
- 0,
- (MB_OK | (errorp ? MB_ERROR : MB_WARNING)));
-}
-
-void
-OS2_exit_scheme (int value)
-{
- if (initialization_completed)
- {
-#if 0
- OS2_channel_close_all_noerror ();
-#endif
- }
- exit (value);
-}
-
-void
-OS_reset (void)
-{
- execute_reload_cleanups ();
-}
-
-void
-OS_quit (int code, int abnormal_p)
-{
- outf_flush_console ();
- OS_restore_external_state ();
-}
-
-void
-OS_save_external_state (void)
-{
-}
-
-void
-OS_save_internal_state (void)
-{
-}
-
-void
-OS_restore_internal_state (void)
-{
-}
-
-void
-OS_restore_external_state (void)
-{
-}
-
-void
-preserve_signal_mask (void)
-{
-}
-
-void
-block_signals (void)
-{
-}
-
-void
-unblock_signals (void)
-{
-}
-
-void
-OS_restartable_exit (void)
-{
-}
-
-#if defined(__IBMC__) || defined(__WATCOMC__)
-void
-bcopy (const char * from, char * to, unsigned int n)
-{
- FASTCOPY (from, to, n);
-}
-#endif
-\f
-static HMTX interrupt_registers_lock;
-
-static void
-initialize_locks (void)
-{
- interrupt_registers_lock = (OS2_create_mutex_semaphore (0, 0));
- OS2_create_queue_lock = (OS2_create_mutex_semaphore (0, 0));
-}
-
-void
-OS_grab_interrupt_registers (void)
-{
- OS2_request_mutex_semaphore (interrupt_registers_lock);
-}
-
-void
-OS_release_interrupt_registers (void)
-{
- OS2_release_mutex_semaphore (interrupt_registers_lock);
-}
-\f
-/* Machine-generated procedure, do not edit: */
-enum syserr_names
-OS_error_code_to_syserr (int code)
-{
- switch (code)
- {
- case ERROR_INVALID_FUNCTION: return (syserr_invalid_function);
- case ERROR_FILE_NOT_FOUND: return (syserr_file_not_found);
- case ERROR_PATH_NOT_FOUND: return (syserr_path_not_found);
- case ERROR_TOO_MANY_OPEN_FILES: return (syserr_too_many_open_files);
- case ERROR_ACCESS_DENIED: return (syserr_access_denied);
- case ERROR_INVALID_HANDLE: return (syserr_invalid_handle);
- case ERROR_ARENA_TRASHED: return (syserr_arena_trashed);
- case ERROR_NOT_ENOUGH_MEMORY: return (syserr_not_enough_memory);
- case ERROR_INVALID_BLOCK: return (syserr_invalid_block);
- case ERROR_BAD_ENVIRONMENT: return (syserr_bad_environment);
- case ERROR_BAD_FORMAT: return (syserr_bad_format);
- case ERROR_INVALID_ACCESS: return (syserr_invalid_access);
- case ERROR_INVALID_DATA: return (syserr_invalid_data);
- case ERROR_INVALID_DRIVE: return (syserr_invalid_drive);
- case ERROR_CURRENT_DIRECTORY: return (syserr_current_directory);
- case ERROR_NOT_SAME_DEVICE: return (syserr_not_same_device);
- case ERROR_NO_MORE_FILES: return (syserr_no_more_files);
- case ERROR_WRITE_PROTECT: return (syserr_write_protect);
- case ERROR_BAD_UNIT: return (syserr_bad_unit);
- case ERROR_NOT_READY: return (syserr_not_ready);
- case ERROR_BAD_COMMAND: return (syserr_bad_command);
- case ERROR_CRC: return (syserr_crc);
- case ERROR_BAD_LENGTH: return (syserr_bad_length);
- case ERROR_SEEK: return (syserr_seek);
- case ERROR_NOT_DOS_DISK: return (syserr_not_dos_disk);
- case ERROR_SECTOR_NOT_FOUND: return (syserr_sector_not_found);
- case ERROR_OUT_OF_PAPER: return (syserr_out_of_paper);
- case ERROR_WRITE_FAULT: return (syserr_write_fault);
- case ERROR_READ_FAULT: return (syserr_read_fault);
- case ERROR_GEN_FAILURE: return (syserr_gen_failure);
- case ERROR_SHARING_VIOLATION: return (syserr_sharing_violation);
- case ERROR_LOCK_VIOLATION: return (syserr_lock_violation);
- case ERROR_WRONG_DISK: return (syserr_wrong_disk);
- case ERROR_FCB_UNAVAILABLE: return (syserr_fcb_unavailable);
- case ERROR_SHARING_BUFFER_EXCEEDED: return (syserr_sharing_buffer_exceeded);
- case ERROR_CODE_PAGE_MISMATCHED: return (syserr_code_page_mismatched);
- case ERROR_HANDLE_EOF: return (syserr_handle_eof);
- case ERROR_HANDLE_DISK_FULL: return (syserr_handle_disk_full);
- case ERROR_NOT_SUPPORTED: return (syserr_not_supported);
- case ERROR_REM_NOT_LIST: return (syserr_rem_not_list);
- case ERROR_DUP_NAME: return (syserr_dup_name);
- case ERROR_BAD_NETPATH: return (syserr_bad_netpath);
- case ERROR_NETWORK_BUSY: return (syserr_network_busy);
- case ERROR_DEV_NOT_EXIST: return (syserr_dev_not_exist);
- case ERROR_TOO_MANY_CMDS: return (syserr_too_many_cmds);
- case ERROR_ADAP_HDW_ERR: return (syserr_adap_hdw_err);
- case ERROR_BAD_NET_RESP: return (syserr_bad_net_resp);
- case ERROR_UNEXP_NET_ERR: return (syserr_unexp_net_err);
- case ERROR_BAD_REM_ADAP: return (syserr_bad_rem_adap);
- case ERROR_PRINTQ_FULL: return (syserr_printq_full);
- case ERROR_NO_SPOOL_SPACE: return (syserr_no_spool_space);
- case ERROR_PRINT_CANCELLED: return (syserr_print_cancelled);
- case ERROR_NETNAME_DELETED: return (syserr_netname_deleted);
- case ERROR_NETWORK_ACCESS_DENIED: return (syserr_network_access_denied);
- case ERROR_BAD_DEV_TYPE: return (syserr_bad_dev_type);
- case ERROR_BAD_NET_NAME: return (syserr_bad_net_name);
- case ERROR_TOO_MANY_NAMES: return (syserr_too_many_names);
- case ERROR_TOO_MANY_SESS: return (syserr_too_many_sess);
- case ERROR_SHARING_PAUSED: return (syserr_sharing_paused);
- case ERROR_REQ_NOT_ACCEP: return (syserr_req_not_accep);
- case ERROR_REDIR_PAUSED: return (syserr_redir_paused);
- case ERROR_SBCS_ATT_WRITE_PROT: return (syserr_sbcs_att_write_prot);
- case ERROR_SBCS_GENERAL_FAILURE: return (syserr_sbcs_general_failure);
- case ERROR_XGA_OUT_MEMORY: return (syserr_xga_out_memory);
- case ERROR_FILE_EXISTS: return (syserr_file_exists);
- case ERROR_DUP_FCB: return (syserr_dup_fcb);
- case ERROR_CANNOT_MAKE: return (syserr_cannot_make);
- case ERROR_FAIL_I24: return (syserr_fail_i24);
- case ERROR_OUT_OF_STRUCTURES: return (syserr_out_of_structures);
- case ERROR_ALREADY_ASSIGNED: return (syserr_already_assigned);
- case ERROR_INVALID_PASSWORD: return (syserr_invalid_password);
- case ERROR_INVALID_PARAMETER: return (syserr_invalid_parameter);
- case ERROR_NET_WRITE_FAULT: return (syserr_net_write_fault);
- case ERROR_NO_PROC_SLOTS: return (syserr_no_proc_slots);
- case ERROR_NOT_FROZEN: return (syserr_not_frozen);
- case ERR_TSTOVFL: return (syserr_tstovfl);
- case ERR_TSTDUP: return (syserr_tstdup);
- case ERROR_NO_ITEMS: return (syserr_no_items);
- case ERROR_INTERRUPT: return (syserr_interrupt);
- case ERROR_DEVICE_IN_USE: return (syserr_device_in_use);
- case ERROR_TOO_MANY_SEMAPHORES: return (syserr_too_many_semaphores);
- case ERROR_EXCL_SEM_ALREADY_OWNED: return (syserr_excl_sem_already_owned);
- case ERROR_SEM_IS_SET: return (syserr_sem_is_set);
- case ERROR_TOO_MANY_SEM_REQUESTS: return (syserr_too_many_sem_requests);
- case ERROR_INVALID_AT_INTERRUPT_TIME: return (syserr_invalid_at_interrupt_time);
- case ERROR_SEM_OWNER_DIED: return (syserr_sem_owner_died);
- case ERROR_SEM_USER_LIMIT: return (syserr_sem_user_limit);
- case ERROR_DISK_CHANGE: return (syserr_disk_change);
- case ERROR_DRIVE_LOCKED: return (syserr_drive_locked);
- case ERROR_BROKEN_PIPE: return (syserr_broken_pipe);
- case ERROR_OPEN_FAILED: return (syserr_open_failed);
- case ERROR_BUFFER_OVERFLOW: return (syserr_buffer_overflow);
- case ERROR_DISK_FULL: return (syserr_disk_full);
- case ERROR_NO_MORE_SEARCH_HANDLES: return (syserr_no_more_search_handles);
- case ERROR_INVALID_TARGET_HANDLE: return (syserr_invalid_target_handle);
- case ERROR_PROTECTION_VIOLATION: return (syserr_protection_violation);
- case ERROR_VIOKBD_REQUEST: return (syserr_viokbd_request);
- case ERROR_INVALID_CATEGORY: return (syserr_invalid_category);
- case ERROR_INVALID_VERIFY_SWITCH: return (syserr_invalid_verify_switch);
- case ERROR_BAD_DRIVER_LEVEL: return (syserr_bad_driver_level);
- case ERROR_CALL_NOT_IMPLEMENTED: return (syserr_call_not_implemented);
- case ERROR_SEM_TIMEOUT: return (syserr_sem_timeout);
- case ERROR_INSUFFICIENT_BUFFER: return (syserr_insufficient_buffer);
- case ERROR_INVALID_NAME: return (syserr_invalid_name);
- case ERROR_INVALID_LEVEL: return (syserr_invalid_level);
- case ERROR_NO_VOLUME_LABEL: return (syserr_no_volume_label);
- case ERROR_MOD_NOT_FOUND: return (syserr_mod_not_found);
- case ERROR_PROC_NOT_FOUND: return (syserr_proc_not_found);
- case ERROR_WAIT_NO_CHILDREN: return (syserr_wait_no_children);
- case ERROR_CHILD_NOT_COMPLETE: return (syserr_child_not_complete);
- case ERROR_DIRECT_ACCESS_HANDLE: return (syserr_direct_access_handle);
- case ERROR_NEGATIVE_SEEK: return (syserr_negative_seek);
- case ERROR_SEEK_ON_DEVICE: return (syserr_seek_on_device);
- case ERROR_IS_JOIN_TARGET: return (syserr_is_join_target);
- case ERROR_IS_JOINED: return (syserr_is_joined);
- case ERROR_IS_SUBSTED: return (syserr_is_substed);
- case ERROR_NOT_JOINED: return (syserr_not_joined);
- case ERROR_NOT_SUBSTED: return (syserr_not_substed);
- case ERROR_JOIN_TO_JOIN: return (syserr_join_to_join);
- case ERROR_SUBST_TO_SUBST: return (syserr_subst_to_subst);
- case ERROR_JOIN_TO_SUBST: return (syserr_join_to_subst);
- case ERROR_SUBST_TO_JOIN: return (syserr_subst_to_join);
- case ERROR_BUSY_DRIVE: return (syserr_busy_drive);
- case ERROR_SAME_DRIVE: return (syserr_same_drive);
- case ERROR_DIR_NOT_ROOT: return (syserr_dir_not_root);
- case ERROR_DIR_NOT_EMPTY: return (syserr_dir_not_empty);
- case ERROR_IS_SUBST_PATH: return (syserr_is_subst_path);
- case ERROR_IS_JOIN_PATH: return (syserr_is_join_path);
- case ERROR_PATH_BUSY: return (syserr_path_busy);
- case ERROR_IS_SUBST_TARGET: return (syserr_is_subst_target);
- case ERROR_SYSTEM_TRACE: return (syserr_system_trace);
- case ERROR_INVALID_EVENT_COUNT: return (syserr_invalid_event_count);
- case ERROR_TOO_MANY_MUXWAITERS: return (syserr_too_many_muxwaiters);
- case ERROR_INVALID_LIST_FORMAT: return (syserr_invalid_list_format);
- case ERROR_LABEL_TOO_LONG: return (syserr_label_too_long);
- case ERROR_TOO_MANY_TCBS: return (syserr_too_many_tcbs);
- case ERROR_SIGNAL_REFUSED: return (syserr_signal_refused);
- case ERROR_DISCARDED: return (syserr_discarded);
- case ERROR_NOT_LOCKED: return (syserr_not_locked);
- case ERROR_BAD_THREADID_ADDR: return (syserr_bad_threadid_addr);
- case ERROR_BAD_ARGUMENTS: return (syserr_bad_arguments);
- case ERROR_BAD_PATHNAME: return (syserr_bad_pathname);
- case ERROR_SIGNAL_PENDING: return (syserr_signal_pending);
- case ERROR_UNCERTAIN_MEDIA: return (syserr_uncertain_media);
- case ERROR_MAX_THRDS_REACHED: return (syserr_max_thrds_reached);
- case ERROR_MONITORS_NOT_SUPPORTED: return (syserr_monitors_not_supported);
- case ERROR_UNC_DRIVER_NOT_INSTALLED: return (syserr_unc_driver_not_installed);
- case ERROR_LOCK_FAILED: return (syserr_lock_failed);
- case ERROR_SWAPIO_FAILED: return (syserr_swapio_failed);
- case ERROR_SWAPIN_FAILED: return (syserr_swapin_failed);
- case ERROR_BUSY: return (syserr_busy);
- case ERROR_CANCEL_VIOLATION: return (syserr_cancel_violation);
- case ERROR_ATOMIC_LOCK_NOT_SUPPORTED: return (syserr_atomic_lock_not_supported);
- case ERROR_READ_LOCKS_NOT_SUPPORTED: return (syserr_read_locks_not_supported);
- case ERROR_INVALID_SEGMENT_NUMBER: return (syserr_invalid_segment_number);
- case ERROR_INVALID_CALLGATE: return (syserr_invalid_callgate);
- case ERROR_INVALID_ORDINAL: return (syserr_invalid_ordinal);
- case ERROR_ALREADY_EXISTS: return (syserr_already_exists);
- case ERROR_NO_CHILD_PROCESS: return (syserr_no_child_process);
- case ERROR_CHILD_ALIVE_NOWAIT: return (syserr_child_alive_nowait);
- case ERROR_INVALID_FLAG_NUMBER: return (syserr_invalid_flag_number);
- case ERROR_SEM_NOT_FOUND: return (syserr_sem_not_found);
- case ERROR_INVALID_STARTING_CODESEG: return (syserr_invalid_starting_codeseg);
- case ERROR_INVALID_STACKSEG: return (syserr_invalid_stackseg);
- case ERROR_INVALID_MODULETYPE: return (syserr_invalid_moduletype);
- case ERROR_INVALID_EXE_SIGNATURE: return (syserr_invalid_exe_signature);
- case ERROR_EXE_MARKED_INVALID: return (syserr_exe_marked_invalid);
- case ERROR_BAD_EXE_FORMAT: return (syserr_bad_exe_format);
-#ifdef ERROR_ITERATED_DATA_EXCEEDS_64k
- case ERROR_ITERATED_DATA_EXCEEDS_64k: return (syserr_iterated_data_exceeds_64k);
-#endif
- case ERROR_INVALID_MINALLOCSIZE: return (syserr_invalid_minallocsize);
- case ERROR_DYNLINK_FROM_INVALID_RING: return (syserr_dynlink_from_invalid_ring);
- case ERROR_IOPL_NOT_ENABLED: return (syserr_iopl_not_enabled);
- case ERROR_INVALID_SEGDPL: return (syserr_invalid_segdpl);
-#ifdef ERROR_AUTODATASEG_EXCEEDS_64k
- case ERROR_AUTODATASEG_EXCEEDS_64k: return (syserr_autodataseg_exceeds_64k);
-#endif
- case ERROR_RING2SEG_MUST_BE_MOVABLE: return (syserr_ring2seg_must_be_movable);
-#ifdef ERROR_RELOC_CHAIN_XEEDS_SEGLIM
- case ERROR_RELOC_CHAIN_XEEDS_SEGLIM: return (syserr_reloc_chain_xeeds_seglim);
-#endif
- case ERROR_INFLOOP_IN_RELOC_CHAIN: return (syserr_infloop_in_reloc_chain);
- case ERROR_ENVVAR_NOT_FOUND: return (syserr_envvar_not_found);
- case ERROR_NOT_CURRENT_CTRY: return (syserr_not_current_ctry);
- case ERROR_NO_SIGNAL_SENT: return (syserr_no_signal_sent);
- case ERROR_FILENAME_EXCED_RANGE: return (syserr_filename_exced_range);
- case ERROR_RING2_STACK_IN_USE: return (syserr_ring2_stack_in_use);
- case ERROR_META_EXPANSION_TOO_LONG: return (syserr_meta_expansion_too_long);
- case ERROR_INVALID_SIGNAL_NUMBER: return (syserr_invalid_signal_number);
- case ERROR_THREAD_1_INACTIVE: return (syserr_thread_1_inactive);
- case ERROR_INFO_NOT_AVAIL: return (syserr_info_not_avail);
- case ERROR_LOCKED: return (syserr_locked);
- case ERROR_BAD_DYNALINK: return (syserr_bad_dynalink);
- case ERROR_TOO_MANY_MODULES: return (syserr_too_many_modules);
- case ERROR_NESTING_NOT_ALLOWED: return (syserr_nesting_not_allowed);
- case ERROR_CANNOT_SHRINK: return (syserr_cannot_shrink);
- case ERROR_ZOMBIE_PROCESS: return (syserr_zombie_process);
- case ERROR_STACK_IN_HIGH_MEMORY: return (syserr_stack_in_high_memory);
- case ERROR_INVALID_EXITROUTINE_RING: return (syserr_invalid_exitroutine_ring);
- case ERROR_GETBUF_FAILED: return (syserr_getbuf_failed);
- case ERROR_FLUSHBUF_FAILED: return (syserr_flushbuf_failed);
- case ERROR_TRANSFER_TOO_LONG: return (syserr_transfer_too_long);
- case ERROR_FORCENOSWAP_FAILED: return (syserr_forcenoswap_failed);
- case ERROR_SMG_NO_TARGET_WINDOW: return (syserr_smg_no_target_window);
- case ERROR_NO_CHILDREN: return (syserr_no_children);
- case ERROR_INVALID_SCREEN_GROUP: return (syserr_invalid_screen_group);
- case ERROR_BAD_PIPE: return (syserr_bad_pipe);
- case ERROR_PIPE_BUSY: return (syserr_pipe_busy);
- case ERROR_NO_DATA: return (syserr_no_data);
- case ERROR_PIPE_NOT_CONNECTED: return (syserr_pipe_not_connected);
- case ERROR_MORE_DATA: return (syserr_more_data);
- case ERROR_VC_DISCONNECTED: return (syserr_vc_disconnected);
- case ERROR_CIRCULARITY_REQUESTED: return (syserr_circularity_requested);
- case ERROR_DIRECTORY_IN_CDS: return (syserr_directory_in_cds);
- case ERROR_INVALID_FSD_NAME: return (syserr_invalid_fsd_name);
- case ERROR_INVALID_PATH: return (syserr_invalid_path);
- case ERROR_INVALID_EA_NAME: return (syserr_invalid_ea_name);
- case ERROR_EA_LIST_INCONSISTENT: return (syserr_ea_list_inconsistent);
- case ERROR_EA_LIST_TOO_LONG: return (syserr_ea_list_too_long);
- case ERROR_NO_META_MATCH: return (syserr_no_meta_match);
- case ERROR_FINDNOTIFY_TIMEOUT: return (syserr_findnotify_timeout);
- case ERROR_NO_MORE_ITEMS: return (syserr_no_more_items);
- case ERROR_SEARCH_STRUC_REUSED: return (syserr_search_struc_reused);
- case ERROR_CHAR_NOT_FOUND: return (syserr_char_not_found);
- case ERROR_TOO_MUCH_STACK: return (syserr_too_much_stack);
- case ERROR_INVALID_ATTR: return (syserr_invalid_attr);
- case ERROR_INVALID_STARTING_RING: return (syserr_invalid_starting_ring);
- case ERROR_INVALID_DLL_INIT_RING: return (syserr_invalid_dll_init_ring);
- case ERROR_CANNOT_COPY: return (syserr_cannot_copy);
- case ERROR_DIRECTORY: return (syserr_directory);
- case ERROR_OPLOCKED_FILE: return (syserr_oplocked_file);
- case ERROR_OPLOCK_THREAD_EXISTS: return (syserr_oplock_thread_exists);
- case ERROR_VOLUME_CHANGED: return (syserr_volume_changed);
- case ERROR_FINDNOTIFY_HANDLE_IN_USE: return (syserr_findnotify_handle_in_use);
- case ERROR_FINDNOTIFY_HANDLE_CLOSED: return (syserr_findnotify_handle_closed);
- case ERROR_NOTIFY_OBJECT_REMOVED: return (syserr_notify_object_removed);
- case ERROR_ALREADY_SHUTDOWN: return (syserr_already_shutdown);
- case ERROR_EAS_DIDNT_FIT: return (syserr_eas_didnt_fit);
- case ERROR_EA_FILE_CORRUPT: return (syserr_ea_file_corrupt);
- case ERROR_EA_TABLE_FULL: return (syserr_ea_table_full);
- case ERROR_INVALID_EA_HANDLE: return (syserr_invalid_ea_handle);
- case ERROR_NO_CLUSTER: return (syserr_no_cluster);
- case ERROR_CREATE_EA_FILE: return (syserr_create_ea_file);
- case ERROR_CANNOT_OPEN_EA_FILE: return (syserr_cannot_open_ea_file);
- case ERROR_EAS_NOT_SUPPORTED: return (syserr_eas_not_supported);
- case ERROR_NEED_EAS_FOUND: return (syserr_need_eas_found);
- case ERROR_DUPLICATE_HANDLE: return (syserr_duplicate_handle);
- case ERROR_DUPLICATE_NAME: return (syserr_duplicate_name);
- case ERROR_EMPTY_MUXWAIT: return (syserr_empty_muxwait);
- case ERROR_MUTEX_OWNED: return (syserr_mutex_owned);
- case ERROR_NOT_OWNER: return (syserr_not_owner);
- case ERROR_PARAM_TOO_SMALL: return (syserr_param_too_small);
- case ERROR_TOO_MANY_HANDLES: return (syserr_too_many_handles);
- case ERROR_TOO_MANY_OPENS: return (syserr_too_many_opens);
- case ERROR_WRONG_TYPE: return (syserr_wrong_type);
- case ERROR_UNUSED_CODE: return (syserr_unused_code);
- case ERROR_THREAD_NOT_TERMINATED: return (syserr_thread_not_terminated);
- case ERROR_INIT_ROUTINE_FAILED: return (syserr_init_routine_failed);
- case ERROR_MODULE_IN_USE: return (syserr_module_in_use);
- case ERROR_NOT_ENOUGH_WATCHPOINTS: return (syserr_not_enough_watchpoints);
- case ERROR_TOO_MANY_POSTS: return (syserr_too_many_posts);
- case ERROR_ALREADY_POSTED: return (syserr_already_posted);
- case ERROR_ALREADY_RESET: return (syserr_already_reset);
- case ERROR_SEM_BUSY: return (syserr_sem_busy);
- case ERROR_INVALID_PROCID: return (syserr_invalid_procid);
- case ERROR_INVALID_PDELTA: return (syserr_invalid_pdelta);
- case ERROR_NOT_DESCENDANT: return (syserr_not_descendant);
- case ERROR_NOT_SESSION_MANAGER: return (syserr_not_session_manager);
- case ERROR_INVALID_PCLASS: return (syserr_invalid_pclass);
- case ERROR_INVALID_SCOPE: return (syserr_invalid_scope);
- case ERROR_INVALID_THREADID: return (syserr_invalid_threadid);
- case ERROR_DOSSUB_SHRINK: return (syserr_dossub_shrink);
- case ERROR_DOSSUB_NOMEM: return (syserr_dossub_nomem);
- case ERROR_DOSSUB_OVERLAP: return (syserr_dossub_overlap);
- case ERROR_DOSSUB_BADSIZE: return (syserr_dossub_badsize);
- case ERROR_DOSSUB_BADFLAG: return (syserr_dossub_badflag);
- case ERROR_DOSSUB_BADSELECTOR: return (syserr_dossub_badselector);
- case ERROR_MR_MSG_TOO_LONG: return (syserr_mr_msg_too_long);
- case ERROR_MR_MID_NOT_FOUND: return (syserr_mr_mid_not_found);
- case ERROR_MR_UN_ACC_MSGF: return (syserr_mr_un_acc_msgf);
- case ERROR_MR_INV_MSGF_FORMAT: return (syserr_mr_inv_msgf_format);
- case ERROR_MR_INV_IVCOUNT: return (syserr_mr_inv_ivcount);
- case ERROR_MR_UN_PERFORM: return (syserr_mr_un_perform);
- case ERROR_TS_WAKEUP: return (syserr_ts_wakeup);
- case ERROR_TS_SEMHANDLE: return (syserr_ts_semhandle);
- case ERROR_TS_NOTIMER: return (syserr_ts_notimer);
- case ERROR_TS_HANDLE: return (syserr_ts_handle);
- case ERROR_TS_DATETIME: return (syserr_ts_datetime);
- case ERROR_SYS_INTERNAL: return (syserr_sys_internal);
- case ERROR_QUE_CURRENT_NAME: return (syserr_que_current_name);
- case ERROR_QUE_PROC_NOT_OWNED: return (syserr_que_proc_not_owned);
- case ERROR_QUE_PROC_OWNED: return (syserr_que_proc_owned);
- case ERROR_QUE_DUPLICATE: return (syserr_que_duplicate);
- case ERROR_QUE_ELEMENT_NOT_EXIST: return (syserr_que_element_not_exist);
- case ERROR_QUE_NO_MEMORY: return (syserr_que_no_memory);
- case ERROR_QUE_INVALID_NAME: return (syserr_que_invalid_name);
- case ERROR_QUE_INVALID_PRIORITY: return (syserr_que_invalid_priority);
- case ERROR_QUE_INVALID_HANDLE: return (syserr_que_invalid_handle);
- case ERROR_QUE_LINK_NOT_FOUND: return (syserr_que_link_not_found);
- case ERROR_QUE_MEMORY_ERROR: return (syserr_que_memory_error);
- case ERROR_QUE_PREV_AT_END: return (syserr_que_prev_at_end);
- case ERROR_QUE_PROC_NO_ACCESS: return (syserr_que_proc_no_access);
- case ERROR_QUE_EMPTY: return (syserr_que_empty);
- case ERROR_QUE_NAME_NOT_EXIST: return (syserr_que_name_not_exist);
- case ERROR_QUE_NOT_INITIALIZED: return (syserr_que_not_initialized);
- case ERROR_QUE_UNABLE_TO_ACCESS: return (syserr_que_unable_to_access);
- case ERROR_QUE_UNABLE_TO_ADD: return (syserr_que_unable_to_add);
- case ERROR_QUE_UNABLE_TO_INIT: return (syserr_que_unable_to_init);
- case ERROR_VIO_INVALID_MASK: return (syserr_vio_invalid_mask);
- case ERROR_VIO_PTR: return (syserr_vio_ptr);
- case ERROR_VIO_APTR: return (syserr_vio_aptr);
- case ERROR_VIO_RPTR: return (syserr_vio_rptr);
- case ERROR_VIO_CPTR: return (syserr_vio_cptr);
- case ERROR_VIO_LPTR: return (syserr_vio_lptr);
- case ERROR_VIO_MODE: return (syserr_vio_mode);
- case ERROR_VIO_WIDTH: return (syserr_vio_width);
- case ERROR_VIO_ATTR: return (syserr_vio_attr);
- case ERROR_VIO_ROW: return (syserr_vio_row);
- case ERROR_VIO_COL: return (syserr_vio_col);
- case ERROR_VIO_TOPROW: return (syserr_vio_toprow);
- case ERROR_VIO_BOTROW: return (syserr_vio_botrow);
- case ERROR_VIO_RIGHTCOL: return (syserr_vio_rightcol);
- case ERROR_VIO_LEFTCOL: return (syserr_vio_leftcol);
- case ERROR_SCS_CALL: return (syserr_scs_call);
- case ERROR_SCS_VALUE: return (syserr_scs_value);
- case ERROR_VIO_WAIT_FLAG: return (syserr_vio_wait_flag);
- case ERROR_VIO_UNLOCK: return (syserr_vio_unlock);
- case ERROR_SGS_NOT_SESSION_MGR: return (syserr_sgs_not_session_mgr);
- case ERROR_SMG_INVALID_SESSION_ID: return (syserr_smg_invalid_session_id);
- case ERROR_SMG_NO_SESSIONS: return (syserr_smg_no_sessions);
- case ERROR_SMG_SESSION_NOT_FOUND: return (syserr_smg_session_not_found);
- case ERROR_SMG_SET_TITLE: return (syserr_smg_set_title);
- case ERROR_KBD_PARAMETER: return (syserr_kbd_parameter);
- case ERROR_KBD_NO_DEVICE: return (syserr_kbd_no_device);
- case ERROR_KBD_INVALID_IOWAIT: return (syserr_kbd_invalid_iowait);
- case ERROR_KBD_INVALID_LENGTH: return (syserr_kbd_invalid_length);
- case ERROR_KBD_INVALID_ECHO_MASK: return (syserr_kbd_invalid_echo_mask);
- case ERROR_KBD_INVALID_INPUT_MASK: return (syserr_kbd_invalid_input_mask);
- case ERROR_MON_INVALID_PARMS: return (syserr_mon_invalid_parms);
- case ERROR_MON_INVALID_DEVNAME: return (syserr_mon_invalid_devname);
- case ERROR_MON_INVALID_HANDLE: return (syserr_mon_invalid_handle);
- case ERROR_MON_BUFFER_TOO_SMALL: return (syserr_mon_buffer_too_small);
- case ERROR_MON_BUFFER_EMPTY: return (syserr_mon_buffer_empty);
- case ERROR_MON_DATA_TOO_LARGE: return (syserr_mon_data_too_large);
- case ERROR_MOUSE_NO_DEVICE: return (syserr_mouse_no_device);
- case ERROR_MOUSE_INV_HANDLE: return (syserr_mouse_inv_handle);
- case ERROR_MOUSE_INV_PARMS: return (syserr_mouse_inv_parms);
- case ERROR_MOUSE_CANT_RESET: return (syserr_mouse_cant_reset);
- case ERROR_MOUSE_DISPLAY_PARMS: return (syserr_mouse_display_parms);
- case ERROR_MOUSE_INV_MODULE: return (syserr_mouse_inv_module);
- case ERROR_MOUSE_INV_ENTRY_PT: return (syserr_mouse_inv_entry_pt);
- case ERROR_MOUSE_INV_MASK: return (syserr_mouse_inv_mask);
- case NO_ERROR_MOUSE_NO_DATA: return (syserr_mouse_no_data);
- case NO_ERROR_MOUSE_PTR_DRAWN: return (syserr_mouse_ptr_drawn);
- case ERROR_INVALID_FREQUENCY: return (syserr_invalid_frequency);
- case ERROR_NLS_NO_COUNTRY_FILE: return (syserr_nls_no_country_file);
- case ERROR_NLS_OPEN_FAILED: return (syserr_nls_open_failed);
-#ifdef ERROR_NO_COUNTRY_OR_CODEPAGE
- case ERROR_NO_COUNTRY_OR_CODEPAGE: return (syserr_no_country_or_codepage);
-#endif
- case ERROR_NLS_TABLE_TRUNCATED: return (syserr_nls_table_truncated);
- case ERROR_NLS_BAD_TYPE: return (syserr_nls_bad_type);
- case ERROR_NLS_TYPE_NOT_FOUND: return (syserr_nls_type_not_found);
- case ERROR_VIO_SMG_ONLY: return (syserr_vio_smg_only);
- case ERROR_VIO_INVALID_ASCIIZ: return (syserr_vio_invalid_asciiz);
- case ERROR_VIO_DEREGISTER: return (syserr_vio_deregister);
- case ERROR_VIO_NO_POPUP: return (syserr_vio_no_popup);
- case ERROR_VIO_EXISTING_POPUP: return (syserr_vio_existing_popup);
- case ERROR_KBD_SMG_ONLY: return (syserr_kbd_smg_only);
- case ERROR_KBD_INVALID_ASCIIZ: return (syserr_kbd_invalid_asciiz);
- case ERROR_KBD_INVALID_MASK: return (syserr_kbd_invalid_mask);
- case ERROR_KBD_REGISTER: return (syserr_kbd_register);
- case ERROR_KBD_DEREGISTER: return (syserr_kbd_deregister);
- case ERROR_MOUSE_SMG_ONLY: return (syserr_mouse_smg_only);
- case ERROR_MOUSE_INVALID_ASCIIZ: return (syserr_mouse_invalid_asciiz);
- case ERROR_MOUSE_INVALID_MASK: return (syserr_mouse_invalid_mask);
- case ERROR_MOUSE_REGISTER: return (syserr_mouse_register);
- case ERROR_MOUSE_DEREGISTER: return (syserr_mouse_deregister);
- case ERROR_SMG_BAD_ACTION: return (syserr_smg_bad_action);
- case ERROR_SMG_INVALID_CALL: return (syserr_smg_invalid_call);
- case ERROR_SCS_SG_NOTFOUND: return (syserr_scs_sg_notfound);
- case ERROR_SCS_NOT_SHELL: return (syserr_scs_not_shell);
- case ERROR_VIO_INVALID_PARMS: return (syserr_vio_invalid_parms);
- case ERROR_VIO_FUNCTION_OWNED: return (syserr_vio_function_owned);
- case ERROR_VIO_RETURN: return (syserr_vio_return);
- case ERROR_SCS_INVALID_FUNCTION: return (syserr_scs_invalid_function);
- case ERROR_SCS_NOT_SESSION_MGR: return (syserr_scs_not_session_mgr);
- case ERROR_VIO_REGISTER: return (syserr_vio_register);
- case ERROR_VIO_NO_MODE_THREAD: return (syserr_vio_no_mode_thread);
- case ERROR_VIO_NO_SAVE_RESTORE_THD: return (syserr_vio_no_save_restore_thd);
- case ERROR_VIO_IN_BG: return (syserr_vio_in_bg);
- case ERROR_VIO_ILLEGAL_DURING_POPUP: return (syserr_vio_illegal_during_popup);
- case ERROR_SMG_NOT_BASESHELL: return (syserr_smg_not_baseshell);
- case ERROR_SMG_BAD_STATUSREQ: return (syserr_smg_bad_statusreq);
- case ERROR_QUE_INVALID_WAIT: return (syserr_que_invalid_wait);
- case ERROR_VIO_LOCK: return (syserr_vio_lock);
- case ERROR_MOUSE_INVALID_IOWAIT: return (syserr_mouse_invalid_iowait);
- case ERROR_VIO_INVALID_HANDLE: return (syserr_vio_invalid_handle);
- case ERROR_VIO_ILLEGAL_DURING_LOCK: return (syserr_vio_illegal_during_lock);
- case ERROR_VIO_INVALID_LENGTH: return (syserr_vio_invalid_length);
- case ERROR_KBD_INVALID_HANDLE: return (syserr_kbd_invalid_handle);
- case ERROR_KBD_NO_MORE_HANDLE: return (syserr_kbd_no_more_handle);
- case ERROR_KBD_CANNOT_CREATE_KCB: return (syserr_kbd_cannot_create_kcb);
- case ERROR_KBD_CODEPAGE_LOAD_INCOMPL: return (syserr_kbd_codepage_load_incompl);
- case ERROR_KBD_INVALID_CODEPAGE_ID: return (syserr_kbd_invalid_codepage_id);
- case ERROR_KBD_NO_CODEPAGE_SUPPORT: return (syserr_kbd_no_codepage_support);
- case ERROR_KBD_FOCUS_REQUIRED: return (syserr_kbd_focus_required);
- case ERROR_KBD_FOCUS_ALREADY_ACTIVE: return (syserr_kbd_focus_already_active);
- case ERROR_KBD_KEYBOARD_BUSY: return (syserr_kbd_keyboard_busy);
- case ERROR_KBD_INVALID_CODEPAGE: return (syserr_kbd_invalid_codepage);
- case ERROR_KBD_UNABLE_TO_FOCUS: return (syserr_kbd_unable_to_focus);
- case ERROR_SMG_SESSION_NON_SELECT: return (syserr_smg_session_non_select);
- case ERROR_SMG_SESSION_NOT_FOREGRND: return (syserr_smg_session_not_foregrnd);
- case ERROR_SMG_SESSION_NOT_PARENT: return (syserr_smg_session_not_parent);
- case ERROR_SMG_INVALID_START_MODE: return (syserr_smg_invalid_start_mode);
- case ERROR_SMG_INVALID_RELATED_OPT: return (syserr_smg_invalid_related_opt);
- case ERROR_SMG_INVALID_BOND_OPTION: return (syserr_smg_invalid_bond_option);
- case ERROR_SMG_INVALID_SELECT_OPT: return (syserr_smg_invalid_select_opt);
- case ERROR_SMG_START_IN_BACKGROUND: return (syserr_smg_start_in_background);
- case ERROR_SMG_INVALID_STOP_OPTION: return (syserr_smg_invalid_stop_option);
- case ERROR_SMG_BAD_RESERVE: return (syserr_smg_bad_reserve);
- case ERROR_SMG_PROCESS_NOT_PARENT: return (syserr_smg_process_not_parent);
- case ERROR_SMG_INVALID_DATA_LENGTH: return (syserr_smg_invalid_data_length);
- case ERROR_SMG_NOT_BOUND: return (syserr_smg_not_bound);
- case ERROR_SMG_RETRY_SUB_ALLOC: return (syserr_smg_retry_sub_alloc);
- case ERROR_KBD_DETACHED: return (syserr_kbd_detached);
- case ERROR_VIO_DETACHED: return (syserr_vio_detached);
- case ERROR_MOU_DETACHED: return (syserr_mou_detached);
- case ERROR_VIO_FONT: return (syserr_vio_font);
- case ERROR_VIO_USER_FONT: return (syserr_vio_user_font);
- case ERROR_VIO_BAD_CP: return (syserr_vio_bad_cp);
- case ERROR_VIO_NO_CP: return (syserr_vio_no_cp);
- case ERROR_VIO_NA_CP: return (syserr_vio_na_cp);
- case ERROR_INVALID_CODE_PAGE: return (syserr_invalid_code_page);
- case ERROR_CPLIST_TOO_SMALL: return (syserr_cplist_too_small);
- case ERROR_CP_NOT_MOVED: return (syserr_cp_not_moved);
- case ERROR_MODE_SWITCH_INIT: return (syserr_mode_switch_init);
- case ERROR_CODE_PAGE_NOT_FOUND: return (syserr_code_page_not_found);
- case ERROR_UNEXPECTED_SLOT_RETURNED: return (syserr_unexpected_slot_returned);
- case ERROR_SMG_INVALID_TRACE_OPTION: return (syserr_smg_invalid_trace_option);
- case ERROR_VIO_INTERNAL_RESOURCE: return (syserr_vio_internal_resource);
- case ERROR_VIO_SHELL_INIT: return (syserr_vio_shell_init);
- case ERROR_SMG_NO_HARD_ERRORS: return (syserr_smg_no_hard_errors);
- case ERROR_CP_SWITCH_INCOMPLETE: return (syserr_cp_switch_incomplete);
- case ERROR_VIO_TRANSPARENT_POPUP: return (syserr_vio_transparent_popup);
- case ERROR_CRITSEC_OVERFLOW: return (syserr_critsec_overflow);
- case ERROR_CRITSEC_UNDERFLOW: return (syserr_critsec_underflow);
- case ERROR_VIO_BAD_RESERVE: return (syserr_vio_bad_reserve);
- case ERROR_INVALID_ADDRESS: return (syserr_invalid_address);
- case ERROR_ZERO_SELECTORS_REQUESTED: return (syserr_zero_selectors_requested);
- case ERROR_NOT_ENOUGH_SELECTORS_AVA: return (syserr_not_enough_selectors_ava);
- case ERROR_INVALID_SELECTOR: return (syserr_invalid_selector);
- case ERROR_SMG_INVALID_PROGRAM_TYPE: return (syserr_smg_invalid_program_type);
- case ERROR_SMG_INVALID_PGM_CONTROL: return (syserr_smg_invalid_pgm_control);
- case ERROR_SMG_INVALID_INHERIT_OPT: return (syserr_smg_invalid_inherit_opt);
- case ERROR_VIO_EXTENDED_SG: return (syserr_vio_extended_sg);
- case ERROR_VIO_NOT_PRES_MGR_SG: return (syserr_vio_not_pres_mgr_sg);
- case ERROR_VIO_SHIELD_OWNED: return (syserr_vio_shield_owned);
- case ERROR_VIO_NO_MORE_HANDLES: return (syserr_vio_no_more_handles);
- case ERROR_VIO_SEE_ERROR_LOG: return (syserr_vio_see_error_log);
- case ERROR_VIO_ASSOCIATED_DC: return (syserr_vio_associated_dc);
- case ERROR_KBD_NO_CONSOLE: return (syserr_kbd_no_console);
- case ERROR_MOUSE_NO_CONSOLE: return (syserr_mouse_no_console);
- case ERROR_MOUSE_INVALID_HANDLE: return (syserr_mouse_invalid_handle);
- case ERROR_SMG_INVALID_DEBUG_PARMS: return (syserr_smg_invalid_debug_parms);
- case ERROR_KBD_EXTENDED_SG: return (syserr_kbd_extended_sg);
- case ERROR_MOU_EXTENDED_SG: return (syserr_mou_extended_sg);
- case ERROR_SMG_INVALID_ICON_FILE: return (syserr_smg_invalid_icon_file);
- case ERROR_TRC_PID_NON_EXISTENT: return (syserr_trc_pid_non_existent);
- case ERROR_TRC_COUNT_ACTIVE: return (syserr_trc_count_active);
- case ERROR_TRC_SUSPENDED_BY_COUNT: return (syserr_trc_suspended_by_count);
- case ERROR_TRC_COUNT_INACTIVE: return (syserr_trc_count_inactive);
- case ERROR_TRC_COUNT_REACHED: return (syserr_trc_count_reached);
- case ERROR_NO_MC_TRACE: return (syserr_no_mc_trace);
- case ERROR_MC_TRACE: return (syserr_mc_trace);
- case ERROR_TRC_COUNT_ZERO: return (syserr_trc_count_zero);
- case ERROR_SMG_TOO_MANY_DDS: return (syserr_smg_too_many_dds);
- case ERROR_SMG_INVALID_NOTIFICATION: return (syserr_smg_invalid_notification);
- case ERROR_LF_INVALID_FUNCTION: return (syserr_lf_invalid_function);
- case ERROR_LF_NOT_AVAIL: return (syserr_lf_not_avail);
- case ERROR_LF_SUSPENDED: return (syserr_lf_suspended);
- case ERROR_LF_BUF_TOO_SMALL: return (syserr_lf_buf_too_small);
- case ERROR_LF_BUFFER_FULL: return (syserr_lf_buffer_full);
- case ERROR_LF_INVALID_RECORD: return (syserr_lf_invalid_record);
- case ERROR_LF_INVALID_SERVICE: return (syserr_lf_invalid_service);
- case ERROR_LF_GENERAL_FAILURE: return (syserr_lf_general_failure);
- case ERROR_LF_INVALID_ID: return (syserr_lf_invalid_id);
- case ERROR_LF_INVALID_HANDLE: return (syserr_lf_invalid_handle);
- case ERROR_LF_NO_ID_AVAIL: return (syserr_lf_no_id_avail);
- case ERROR_LF_TEMPLATE_AREA_FULL: return (syserr_lf_template_area_full);
- case ERROR_LF_ID_IN_USE: return (syserr_lf_id_in_use);
- case ERROR_MOU_NOT_INITIALIZED: return (syserr_mou_not_initialized);
- case ERROR_MOUINITREAL_DONE: return (syserr_mouinitreal_done);
- case ERROR_DOSSUB_CORRUPTED: return (syserr_dossub_corrupted);
- case ERROR_MOUSE_CALLER_NOT_SUBSYS: return (syserr_mouse_caller_not_subsys);
- case ERROR_ARITHMETIC_OVERFLOW: return (syserr_arithmetic_overflow);
- case ERROR_TMR_NO_DEVICE: return (syserr_tmr_no_device);
- case ERROR_TMR_INVALID_TIME: return (syserr_tmr_invalid_time);
- case ERROR_PVW_INVALID_ENTITY: return (syserr_pvw_invalid_entity);
- case ERROR_PVW_INVALID_ENTITY_TYPE: return (syserr_pvw_invalid_entity_type);
- case ERROR_PVW_INVALID_SPEC: return (syserr_pvw_invalid_spec);
- case ERROR_PVW_INVALID_RANGE_TYPE: return (syserr_pvw_invalid_range_type);
- case ERROR_PVW_INVALID_COUNTER_BLK: return (syserr_pvw_invalid_counter_blk);
- case ERROR_PVW_INVALID_TEXT_BLK: return (syserr_pvw_invalid_text_blk);
- case ERROR_PRF_NOT_INITIALIZED: return (syserr_prf_not_initialized);
- case ERROR_PRF_ALREADY_INITIALIZED: return (syserr_prf_already_initialized);
- case ERROR_PRF_NOT_STARTED: return (syserr_prf_not_started);
- case ERROR_PRF_ALREADY_STARTED: return (syserr_prf_already_started);
- case ERROR_PRF_TIMER_OUT_OF_RANGE: return (syserr_prf_timer_out_of_range);
- case ERROR_PRF_TIMER_RESET: return (syserr_prf_timer_reset);
- case ERROR_VDD_LOCK_USEAGE_DENIED: return (syserr_vdd_lock_useage_denied);
- case ERROR_TIMEOUT: return (syserr_timeout);
- case ERROR_VDM_DOWN: return (syserr_vdm_down);
- case ERROR_VDM_LIMIT: return (syserr_vdm_limit);
- case ERROR_VDD_NOT_FOUND: return (syserr_vdd_not_found);
- case ERROR_INVALID_CALLER: return (syserr_invalid_caller);
- case ERROR_PID_MISMATCH: return (syserr_pid_mismatch);
- case ERROR_INVALID_VDD_HANDLE: return (syserr_invalid_vdd_handle);
- case ERROR_VLPT_NO_SPOOLER: return (syserr_vlpt_no_spooler);
- case ERROR_VCOM_DEVICE_BUSY: return (syserr_vcom_device_busy);
- case ERROR_VLPT_DEVICE_BUSY: return (syserr_vlpt_device_busy);
- case ERROR_NESTING_TOO_DEEP: return (syserr_nesting_too_deep);
- case ERROR_VDD_MISSING: return (syserr_vdd_missing);
- case ERROR_BIDI_INVALID_LENGTH: return (syserr_bidi_invalid_length);
- case ERROR_BIDI_INVALID_INCREMENT: return (syserr_bidi_invalid_increment);
- case ERROR_BIDI_INVALID_COMBINATION: return (syserr_bidi_invalid_combination);
- case ERROR_BIDI_INVALID_RESERVED: return (syserr_bidi_invalid_reserved);
- case ERROR_BIDI_INVALID_EFFECT: return (syserr_bidi_invalid_effect);
- case ERROR_BIDI_INVALID_CSDREC: return (syserr_bidi_invalid_csdrec);
- case ERROR_BIDI_INVALID_CSDSTATE: return (syserr_bidi_invalid_csdstate);
- case ERROR_BIDI_INVALID_LEVEL: return (syserr_bidi_invalid_level);
- case ERROR_BIDI_INVALID_TYPE_SUPPORT: return (syserr_bidi_invalid_type_support);
- case ERROR_BIDI_INVALID_ORIENTATION: return (syserr_bidi_invalid_orientation);
- case ERROR_BIDI_INVALID_NUM_SHAPE: return (syserr_bidi_invalid_num_shape);
- case ERROR_BIDI_INVALID_CSD: return (syserr_bidi_invalid_csd);
- case ERROR_BIDI_NO_SUPPORT: return (syserr_bidi_no_support);
- case NO_ERROR_BIDI_RW_INCOMPLETE: return (syserr_bidi_rw_incomplete);
- case ERROR_IMP_INVALID_PARM: return (syserr_imp_invalid_parm);
- case ERROR_IMP_INVALID_LENGTH: return (syserr_imp_invalid_length);
-#ifdef MSG_HPFS_DISK_ERROR_WARN
- case MSG_HPFS_DISK_ERROR_WARN: return (syserr_hpfs_disk_error_warn);
-#endif
- case ERROR_MON_BAD_BUFFER: return (syserr_mon_bad_buffer);
- case ERROR_MODULE_CORRUPTED: return (syserr_module_corrupted);
- case ERROR_SM_OUTOF_SWAPFILE: return (syserr_sm_outof_swapfile);
- case ERROR_LF_TIMEOUT: return (syserr_lf_timeout);
- case ERROR_LF_SUSPEND_SUCCESS: return (syserr_lf_suspend_success);
- case ERROR_LF_RESUME_SUCCESS: return (syserr_lf_resume_success);
- case ERROR_LF_REDIRECT_SUCCESS: return (syserr_lf_redirect_success);
- case ERROR_LF_REDIRECT_FAILURE: return (syserr_lf_redirect_failure);
- case ERROR_SWAPPER_NOT_ACTIVE: return (syserr_swapper_not_active);
- case ERROR_INVALID_SWAPID: return (syserr_invalid_swapid);
- case ERROR_IOERR_SWAP_FILE: return (syserr_ioerr_swap_file);
- case ERROR_SWAP_TABLE_FULL: return (syserr_swap_table_full);
- case ERROR_SWAP_FILE_FULL: return (syserr_swap_file_full);
- case ERROR_CANT_INIT_SWAPPER: return (syserr_cant_init_swapper);
- case ERROR_SWAPPER_ALREADY_INIT: return (syserr_swapper_already_init);
- case ERROR_PMM_INSUFFICIENT_MEMORY: return (syserr_pmm_insufficient_memory);
- case ERROR_PMM_INVALID_FLAGS: return (syserr_pmm_invalid_flags);
- case ERROR_PMM_INVALID_ADDRESS: return (syserr_pmm_invalid_address);
- case ERROR_PMM_LOCK_FAILED: return (syserr_pmm_lock_failed);
- case ERROR_PMM_UNLOCK_FAILED: return (syserr_pmm_unlock_failed);
- case ERROR_PMM_MOVE_INCOMPLETE: return (syserr_pmm_move_incomplete);
- case ERROR_UCOM_DRIVE_RENAMED: return (syserr_ucom_drive_renamed);
- case ERROR_UCOM_FILENAME_TRUNCATED: return (syserr_ucom_filename_truncated);
- case ERROR_UCOM_BUFFER_LENGTH: return (syserr_ucom_buffer_length);
- case ERROR_MON_CHAIN_HANDLE: return (syserr_mon_chain_handle);
- case ERROR_MON_NOT_REGISTERED: return (syserr_mon_not_registered);
- case ERROR_SMG_ALREADY_TOP: return (syserr_smg_already_top);
- case ERROR_PMM_ARENA_MODIFIED: return (syserr_pmm_arena_modified);
- case ERROR_SMG_PRINTER_OPEN: return (syserr_smg_printer_open);
- case ERROR_PMM_SET_FLAGS_FAILED: return (syserr_pmm_set_flags_failed);
- case ERROR_INVALID_DOS_DD: return (syserr_invalid_dos_dd);
- case ERROR_BLOCKED: return (syserr_blocked);
- case ERROR_NOBLOCK: return (syserr_noblock);
- case ERROR_INSTANCE_SHARED: return (syserr_instance_shared);
- case ERROR_NO_OBJECT: return (syserr_no_object);
- case ERROR_PARTIAL_ATTACH: return (syserr_partial_attach);
- case ERROR_INCACHE: return (syserr_incache);
- case ERROR_SWAP_IO_PROBLEMS: return (syserr_swap_io_problems);
- case ERROR_CROSSES_OBJECT_BOUNDARY: return (syserr_crosses_object_boundary);
- case ERROR_LONGLOCK: return (syserr_longlock);
- case ERROR_SHORTLOCK: return (syserr_shortlock);
- case ERROR_UVIRTLOCK: return (syserr_uvirtlock);
- case ERROR_ALIASLOCK: return (syserr_aliaslock);
- case ERROR_ALIAS: return (syserr_alias);
- case ERROR_NO_MORE_HANDLES: return (syserr_no_more_handles);
- case ERROR_SCAN_TERMINATED: return (syserr_scan_terminated);
- case ERROR_TERMINATOR_NOT_FOUND: return (syserr_terminator_not_found);
- case ERROR_NOT_DIRECT_CHILD: return (syserr_not_direct_child);
- case ERROR_DELAY_FREE: return (syserr_delay_free);
- case ERROR_GUARDPAGE: return (syserr_guardpage);
- case ERROR_SWAPERROR: return (syserr_swaperror);
- case ERROR_LDRERROR: return (syserr_ldrerror);
- case ERROR_NOMEMORY: return (syserr_nomemory);
- case ERROR_NOACCESS: return (syserr_noaccess);
- case ERROR_NO_DLL_TERM: return (syserr_no_dll_term);
- case ERROR_CPSIO_CODE_PAGE_INVALID: return (syserr_cpsio_code_page_invalid);
- case ERROR_CPSIO_NO_SPOOLER: return (syserr_cpsio_no_spooler);
- case ERROR_CPSIO_FONT_ID_INVALID: return (syserr_cpsio_font_id_invalid);
- case ERROR_CPSIO_INTERNAL_ERROR: return (syserr_cpsio_internal_error);
- case ERROR_CPSIO_INVALID_PTR_NAME: return (syserr_cpsio_invalid_ptr_name);
- case ERROR_CPSIO_NOT_ACTIVE: return (syserr_cpsio_not_active);
- case ERROR_CPSIO_PID_FULL: return (syserr_cpsio_pid_full);
- case ERROR_CPSIO_PID_NOT_FOUND: return (syserr_cpsio_pid_not_found);
- case ERROR_CPSIO_READ_CTL_SEQ: return (syserr_cpsio_read_ctl_seq);
- case ERROR_CPSIO_READ_FNT_DEF: return (syserr_cpsio_read_fnt_def);
- case ERROR_CPSIO_WRITE_ERROR: return (syserr_cpsio_write_error);
- case ERROR_CPSIO_WRITE_FULL_ERROR: return (syserr_cpsio_write_full_error);
- case ERROR_CPSIO_WRITE_HANDLE_BAD: return (syserr_cpsio_write_handle_bad);
- case ERROR_CPSIO_SWIT_LOAD: return (syserr_cpsio_swit_load);
- case ERROR_CPSIO_INV_COMMAND: return (syserr_cpsio_inv_command);
- case ERROR_CPSIO_NO_FONT_SWIT: return (syserr_cpsio_no_font_swit);
- case ERROR_ENTRY_IS_CALLGATE: return (syserr_entry_is_callgate);
-
-#ifndef DISABLE_SOCKET_SUPPORT
- case SOCEPERM: return (syserr_socket_perm);
- case SOCESRCH: return (syserr_socket_srch);
- case SOCEINTR: return (syserr_socket_intr);
- case SOCENXIO: return (syserr_socket_nxio);
- case SOCEBADF: return (syserr_socket_badf);
- case SOCEACCES: return (syserr_socket_acces);
- case SOCEFAULT: return (syserr_socket_fault);
- case SOCEINVAL: return (syserr_socket_inval);
- case SOCEMFILE: return (syserr_socket_mfile);
- case SOCEPIPE: return (syserr_socket_pipe);
- case SOCEOS2ERR: return (syserr_socket_os2err);
- case SOCEWOULDBLOCK: return (syserr_socket_wouldblock);
- case SOCEINPROGRESS: return (syserr_socket_inprogress);
- case SOCEALREADY: return (syserr_socket_already);
- case SOCENOTSOCK: return (syserr_socket_notsock);
- case SOCEDESTADDRREQ: return (syserr_socket_destaddrreq);
- case SOCEMSGSIZE: return (syserr_socket_msgsize);
- case SOCEPROTOTYPE: return (syserr_socket_prototype);
- case SOCENOPROTOOPT: return (syserr_socket_noprotoopt);
- case SOCEPROTONOSUPPORT: return (syserr_socket_protonosupport);
- case SOCESOCKTNOSUPPORT: return (syserr_socket_socktnosupport);
- case SOCEOPNOTSUPP: return (syserr_socket_opnotsupp);
- case SOCEPFNOSUPPORT: return (syserr_socket_pfnosupport);
- case SOCEAFNOSUPPORT: return (syserr_socket_afnosupport);
- case SOCEADDRINUSE: return (syserr_socket_addrinuse);
- case SOCEADDRNOTAVAIL: return (syserr_socket_addrnotavail);
- case SOCENETDOWN: return (syserr_socket_netdown);
- case SOCENETUNREACH: return (syserr_socket_netunreach);
- case SOCENETRESET: return (syserr_socket_netreset);
- case SOCECONNABORTED: return (syserr_socket_connaborted);
- case SOCECONNRESET: return (syserr_socket_connreset);
- case SOCENOBUFS: return (syserr_socket_nobufs);
- case SOCEISCONN: return (syserr_socket_isconn);
- case SOCENOTCONN: return (syserr_socket_notconn);
- case SOCESHUTDOWN: return (syserr_socket_shutdown);
- case SOCETOOMANYREFS: return (syserr_socket_toomanyrefs);
- case SOCETIMEDOUT: return (syserr_socket_timedout);
- case SOCECONNREFUSED: return (syserr_socket_connrefused);
- case SOCELOOP: return (syserr_socket_loop);
- case SOCENAMETOOLONG: return (syserr_socket_nametoolong);
- case SOCEHOSTDOWN: return (syserr_socket_hostdown);
- case SOCEHOSTUNREACH: return (syserr_socket_hostunreach);
- case SOCENOTEMPTY: return (syserr_socket_notempty);
-#endif /* not DISABLE_SOCKET_SUPPORT */
-
- default: return (syserr_unknown);
- }
-}
-\f
-/* Machine-generated procedure, do not edit: */
-static APIRET
-syserr_to_error_code (enum syserr_names syserr)
-{
- switch (syserr)
- {
- case syserr_invalid_function: return (ERROR_INVALID_FUNCTION);
- case syserr_file_not_found: return (ERROR_FILE_NOT_FOUND);
- case syserr_path_not_found: return (ERROR_PATH_NOT_FOUND);
- case syserr_too_many_open_files: return (ERROR_TOO_MANY_OPEN_FILES);
- case syserr_access_denied: return (ERROR_ACCESS_DENIED);
- case syserr_invalid_handle: return (ERROR_INVALID_HANDLE);
- case syserr_arena_trashed: return (ERROR_ARENA_TRASHED);
- case syserr_not_enough_memory: return (ERROR_NOT_ENOUGH_MEMORY);
- case syserr_invalid_block: return (ERROR_INVALID_BLOCK);
- case syserr_bad_environment: return (ERROR_BAD_ENVIRONMENT);
- case syserr_bad_format: return (ERROR_BAD_FORMAT);
- case syserr_invalid_access: return (ERROR_INVALID_ACCESS);
- case syserr_invalid_data: return (ERROR_INVALID_DATA);
- case syserr_invalid_drive: return (ERROR_INVALID_DRIVE);
- case syserr_current_directory: return (ERROR_CURRENT_DIRECTORY);
- case syserr_not_same_device: return (ERROR_NOT_SAME_DEVICE);
- case syserr_no_more_files: return (ERROR_NO_MORE_FILES);
- case syserr_write_protect: return (ERROR_WRITE_PROTECT);
- case syserr_bad_unit: return (ERROR_BAD_UNIT);
- case syserr_not_ready: return (ERROR_NOT_READY);
- case syserr_bad_command: return (ERROR_BAD_COMMAND);
- case syserr_crc: return (ERROR_CRC);
- case syserr_bad_length: return (ERROR_BAD_LENGTH);
- case syserr_seek: return (ERROR_SEEK);
- case syserr_not_dos_disk: return (ERROR_NOT_DOS_DISK);
- case syserr_sector_not_found: return (ERROR_SECTOR_NOT_FOUND);
- case syserr_out_of_paper: return (ERROR_OUT_OF_PAPER);
- case syserr_write_fault: return (ERROR_WRITE_FAULT);
- case syserr_read_fault: return (ERROR_READ_FAULT);
- case syserr_gen_failure: return (ERROR_GEN_FAILURE);
- case syserr_sharing_violation: return (ERROR_SHARING_VIOLATION);
- case syserr_lock_violation: return (ERROR_LOCK_VIOLATION);
- case syserr_wrong_disk: return (ERROR_WRONG_DISK);
- case syserr_fcb_unavailable: return (ERROR_FCB_UNAVAILABLE);
- case syserr_sharing_buffer_exceeded: return (ERROR_SHARING_BUFFER_EXCEEDED);
- case syserr_code_page_mismatched: return (ERROR_CODE_PAGE_MISMATCHED);
- case syserr_handle_eof: return (ERROR_HANDLE_EOF);
- case syserr_handle_disk_full: return (ERROR_HANDLE_DISK_FULL);
- case syserr_not_supported: return (ERROR_NOT_SUPPORTED);
- case syserr_rem_not_list: return (ERROR_REM_NOT_LIST);
- case syserr_dup_name: return (ERROR_DUP_NAME);
- case syserr_bad_netpath: return (ERROR_BAD_NETPATH);
- case syserr_network_busy: return (ERROR_NETWORK_BUSY);
- case syserr_dev_not_exist: return (ERROR_DEV_NOT_EXIST);
- case syserr_too_many_cmds: return (ERROR_TOO_MANY_CMDS);
- case syserr_adap_hdw_err: return (ERROR_ADAP_HDW_ERR);
- case syserr_bad_net_resp: return (ERROR_BAD_NET_RESP);
- case syserr_unexp_net_err: return (ERROR_UNEXP_NET_ERR);
- case syserr_bad_rem_adap: return (ERROR_BAD_REM_ADAP);
- case syserr_printq_full: return (ERROR_PRINTQ_FULL);
- case syserr_no_spool_space: return (ERROR_NO_SPOOL_SPACE);
- case syserr_print_cancelled: return (ERROR_PRINT_CANCELLED);
- case syserr_netname_deleted: return (ERROR_NETNAME_DELETED);
- case syserr_network_access_denied: return (ERROR_NETWORK_ACCESS_DENIED);
- case syserr_bad_dev_type: return (ERROR_BAD_DEV_TYPE);
- case syserr_bad_net_name: return (ERROR_BAD_NET_NAME);
- case syserr_too_many_names: return (ERROR_TOO_MANY_NAMES);
- case syserr_too_many_sess: return (ERROR_TOO_MANY_SESS);
- case syserr_sharing_paused: return (ERROR_SHARING_PAUSED);
- case syserr_req_not_accep: return (ERROR_REQ_NOT_ACCEP);
- case syserr_redir_paused: return (ERROR_REDIR_PAUSED);
- case syserr_sbcs_att_write_prot: return (ERROR_SBCS_ATT_WRITE_PROT);
- case syserr_sbcs_general_failure: return (ERROR_SBCS_GENERAL_FAILURE);
- case syserr_xga_out_memory: return (ERROR_XGA_OUT_MEMORY);
- case syserr_file_exists: return (ERROR_FILE_EXISTS);
- case syserr_dup_fcb: return (ERROR_DUP_FCB);
- case syserr_cannot_make: return (ERROR_CANNOT_MAKE);
- case syserr_fail_i24: return (ERROR_FAIL_I24);
- case syserr_out_of_structures: return (ERROR_OUT_OF_STRUCTURES);
- case syserr_already_assigned: return (ERROR_ALREADY_ASSIGNED);
- case syserr_invalid_password: return (ERROR_INVALID_PASSWORD);
- case syserr_invalid_parameter: return (ERROR_INVALID_PARAMETER);
- case syserr_net_write_fault: return (ERROR_NET_WRITE_FAULT);
- case syserr_no_proc_slots: return (ERROR_NO_PROC_SLOTS);
- case syserr_not_frozen: return (ERROR_NOT_FROZEN);
- case syserr_tstovfl: return (ERR_TSTOVFL);
- case syserr_tstdup: return (ERR_TSTDUP);
- case syserr_no_items: return (ERROR_NO_ITEMS);
- case syserr_interrupt: return (ERROR_INTERRUPT);
- case syserr_device_in_use: return (ERROR_DEVICE_IN_USE);
- case syserr_too_many_semaphores: return (ERROR_TOO_MANY_SEMAPHORES);
- case syserr_excl_sem_already_owned: return (ERROR_EXCL_SEM_ALREADY_OWNED);
- case syserr_sem_is_set: return (ERROR_SEM_IS_SET);
- case syserr_too_many_sem_requests: return (ERROR_TOO_MANY_SEM_REQUESTS);
- case syserr_invalid_at_interrupt_time: return (ERROR_INVALID_AT_INTERRUPT_TIME);
- case syserr_sem_owner_died: return (ERROR_SEM_OWNER_DIED);
- case syserr_sem_user_limit: return (ERROR_SEM_USER_LIMIT);
- case syserr_disk_change: return (ERROR_DISK_CHANGE);
- case syserr_drive_locked: return (ERROR_DRIVE_LOCKED);
- case syserr_broken_pipe: return (ERROR_BROKEN_PIPE);
- case syserr_open_failed: return (ERROR_OPEN_FAILED);
- case syserr_buffer_overflow: return (ERROR_BUFFER_OVERFLOW);
- case syserr_disk_full: return (ERROR_DISK_FULL);
- case syserr_no_more_search_handles: return (ERROR_NO_MORE_SEARCH_HANDLES);
- case syserr_invalid_target_handle: return (ERROR_INVALID_TARGET_HANDLE);
- case syserr_protection_violation: return (ERROR_PROTECTION_VIOLATION);
- case syserr_viokbd_request: return (ERROR_VIOKBD_REQUEST);
- case syserr_invalid_category: return (ERROR_INVALID_CATEGORY);
- case syserr_invalid_verify_switch: return (ERROR_INVALID_VERIFY_SWITCH);
- case syserr_bad_driver_level: return (ERROR_BAD_DRIVER_LEVEL);
- case syserr_call_not_implemented: return (ERROR_CALL_NOT_IMPLEMENTED);
- case syserr_sem_timeout: return (ERROR_SEM_TIMEOUT);
- case syserr_insufficient_buffer: return (ERROR_INSUFFICIENT_BUFFER);
- case syserr_invalid_name: return (ERROR_INVALID_NAME);
- case syserr_invalid_level: return (ERROR_INVALID_LEVEL);
- case syserr_no_volume_label: return (ERROR_NO_VOLUME_LABEL);
- case syserr_mod_not_found: return (ERROR_MOD_NOT_FOUND);
- case syserr_proc_not_found: return (ERROR_PROC_NOT_FOUND);
- case syserr_wait_no_children: return (ERROR_WAIT_NO_CHILDREN);
- case syserr_child_not_complete: return (ERROR_CHILD_NOT_COMPLETE);
- case syserr_direct_access_handle: return (ERROR_DIRECT_ACCESS_HANDLE);
- case syserr_negative_seek: return (ERROR_NEGATIVE_SEEK);
- case syserr_seek_on_device: return (ERROR_SEEK_ON_DEVICE);
- case syserr_is_join_target: return (ERROR_IS_JOIN_TARGET);
- case syserr_is_joined: return (ERROR_IS_JOINED);
- case syserr_is_substed: return (ERROR_IS_SUBSTED);
- case syserr_not_joined: return (ERROR_NOT_JOINED);
- case syserr_not_substed: return (ERROR_NOT_SUBSTED);
- case syserr_join_to_join: return (ERROR_JOIN_TO_JOIN);
- case syserr_subst_to_subst: return (ERROR_SUBST_TO_SUBST);
- case syserr_join_to_subst: return (ERROR_JOIN_TO_SUBST);
- case syserr_subst_to_join: return (ERROR_SUBST_TO_JOIN);
- case syserr_busy_drive: return (ERROR_BUSY_DRIVE);
- case syserr_same_drive: return (ERROR_SAME_DRIVE);
- case syserr_dir_not_root: return (ERROR_DIR_NOT_ROOT);
- case syserr_dir_not_empty: return (ERROR_DIR_NOT_EMPTY);
- case syserr_is_subst_path: return (ERROR_IS_SUBST_PATH);
- case syserr_is_join_path: return (ERROR_IS_JOIN_PATH);
- case syserr_path_busy: return (ERROR_PATH_BUSY);
- case syserr_is_subst_target: return (ERROR_IS_SUBST_TARGET);
- case syserr_system_trace: return (ERROR_SYSTEM_TRACE);
- case syserr_invalid_event_count: return (ERROR_INVALID_EVENT_COUNT);
- case syserr_too_many_muxwaiters: return (ERROR_TOO_MANY_MUXWAITERS);
- case syserr_invalid_list_format: return (ERROR_INVALID_LIST_FORMAT);
- case syserr_label_too_long: return (ERROR_LABEL_TOO_LONG);
- case syserr_too_many_tcbs: return (ERROR_TOO_MANY_TCBS);
- case syserr_signal_refused: return (ERROR_SIGNAL_REFUSED);
- case syserr_discarded: return (ERROR_DISCARDED);
- case syserr_not_locked: return (ERROR_NOT_LOCKED);
- case syserr_bad_threadid_addr: return (ERROR_BAD_THREADID_ADDR);
- case syserr_bad_arguments: return (ERROR_BAD_ARGUMENTS);
- case syserr_bad_pathname: return (ERROR_BAD_PATHNAME);
- case syserr_signal_pending: return (ERROR_SIGNAL_PENDING);
- case syserr_uncertain_media: return (ERROR_UNCERTAIN_MEDIA);
- case syserr_max_thrds_reached: return (ERROR_MAX_THRDS_REACHED);
- case syserr_monitors_not_supported: return (ERROR_MONITORS_NOT_SUPPORTED);
- case syserr_unc_driver_not_installed: return (ERROR_UNC_DRIVER_NOT_INSTALLED);
- case syserr_lock_failed: return (ERROR_LOCK_FAILED);
- case syserr_swapio_failed: return (ERROR_SWAPIO_FAILED);
- case syserr_swapin_failed: return (ERROR_SWAPIN_FAILED);
- case syserr_busy: return (ERROR_BUSY);
- case syserr_cancel_violation: return (ERROR_CANCEL_VIOLATION);
- case syserr_atomic_lock_not_supported: return (ERROR_ATOMIC_LOCK_NOT_SUPPORTED);
- case syserr_read_locks_not_supported: return (ERROR_READ_LOCKS_NOT_SUPPORTED);
- case syserr_invalid_segment_number: return (ERROR_INVALID_SEGMENT_NUMBER);
- case syserr_invalid_callgate: return (ERROR_INVALID_CALLGATE);
- case syserr_invalid_ordinal: return (ERROR_INVALID_ORDINAL);
- case syserr_already_exists: return (ERROR_ALREADY_EXISTS);
- case syserr_no_child_process: return (ERROR_NO_CHILD_PROCESS);
- case syserr_child_alive_nowait: return (ERROR_CHILD_ALIVE_NOWAIT);
- case syserr_invalid_flag_number: return (ERROR_INVALID_FLAG_NUMBER);
- case syserr_sem_not_found: return (ERROR_SEM_NOT_FOUND);
- case syserr_invalid_starting_codeseg: return (ERROR_INVALID_STARTING_CODESEG);
- case syserr_invalid_stackseg: return (ERROR_INVALID_STACKSEG);
- case syserr_invalid_moduletype: return (ERROR_INVALID_MODULETYPE);
- case syserr_invalid_exe_signature: return (ERROR_INVALID_EXE_SIGNATURE);
- case syserr_exe_marked_invalid: return (ERROR_EXE_MARKED_INVALID);
- case syserr_bad_exe_format: return (ERROR_BAD_EXE_FORMAT);
-#ifdef ERROR_ITERATED_DATA_EXCEEDS_64k
- case syserr_iterated_data_exceeds_64k: return (ERROR_ITERATED_DATA_EXCEEDS_64k);
-#endif
- case syserr_invalid_minallocsize: return (ERROR_INVALID_MINALLOCSIZE);
- case syserr_dynlink_from_invalid_ring: return (ERROR_DYNLINK_FROM_INVALID_RING);
- case syserr_iopl_not_enabled: return (ERROR_IOPL_NOT_ENABLED);
- case syserr_invalid_segdpl: return (ERROR_INVALID_SEGDPL);
-#ifdef ERROR_AUTODATASEG_EXCEEDS_64k
- case syserr_autodataseg_exceeds_64k: return (ERROR_AUTODATASEG_EXCEEDS_64k);
-#endif
- case syserr_ring2seg_must_be_movable: return (ERROR_RING2SEG_MUST_BE_MOVABLE);
-#ifdef ERROR_RELOC_CHAIN_XEEDS_SEGLIM
- case syserr_reloc_chain_xeeds_seglim: return (ERROR_RELOC_CHAIN_XEEDS_SEGLIM);
-#endif
- case syserr_infloop_in_reloc_chain: return (ERROR_INFLOOP_IN_RELOC_CHAIN);
- case syserr_envvar_not_found: return (ERROR_ENVVAR_NOT_FOUND);
- case syserr_not_current_ctry: return (ERROR_NOT_CURRENT_CTRY);
- case syserr_no_signal_sent: return (ERROR_NO_SIGNAL_SENT);
- case syserr_filename_exced_range: return (ERROR_FILENAME_EXCED_RANGE);
- case syserr_ring2_stack_in_use: return (ERROR_RING2_STACK_IN_USE);
- case syserr_meta_expansion_too_long: return (ERROR_META_EXPANSION_TOO_LONG);
- case syserr_invalid_signal_number: return (ERROR_INVALID_SIGNAL_NUMBER);
- case syserr_thread_1_inactive: return (ERROR_THREAD_1_INACTIVE);
- case syserr_info_not_avail: return (ERROR_INFO_NOT_AVAIL);
- case syserr_locked: return (ERROR_LOCKED);
- case syserr_bad_dynalink: return (ERROR_BAD_DYNALINK);
- case syserr_too_many_modules: return (ERROR_TOO_MANY_MODULES);
- case syserr_nesting_not_allowed: return (ERROR_NESTING_NOT_ALLOWED);
- case syserr_cannot_shrink: return (ERROR_CANNOT_SHRINK);
- case syserr_zombie_process: return (ERROR_ZOMBIE_PROCESS);
- case syserr_stack_in_high_memory: return (ERROR_STACK_IN_HIGH_MEMORY);
- case syserr_invalid_exitroutine_ring: return (ERROR_INVALID_EXITROUTINE_RING);
- case syserr_getbuf_failed: return (ERROR_GETBUF_FAILED);
- case syserr_flushbuf_failed: return (ERROR_FLUSHBUF_FAILED);
- case syserr_transfer_too_long: return (ERROR_TRANSFER_TOO_LONG);
- case syserr_forcenoswap_failed: return (ERROR_FORCENOSWAP_FAILED);
- case syserr_smg_no_target_window: return (ERROR_SMG_NO_TARGET_WINDOW);
- case syserr_no_children: return (ERROR_NO_CHILDREN);
- case syserr_invalid_screen_group: return (ERROR_INVALID_SCREEN_GROUP);
- case syserr_bad_pipe: return (ERROR_BAD_PIPE);
- case syserr_pipe_busy: return (ERROR_PIPE_BUSY);
- case syserr_no_data: return (ERROR_NO_DATA);
- case syserr_pipe_not_connected: return (ERROR_PIPE_NOT_CONNECTED);
- case syserr_more_data: return (ERROR_MORE_DATA);
- case syserr_vc_disconnected: return (ERROR_VC_DISCONNECTED);
- case syserr_circularity_requested: return (ERROR_CIRCULARITY_REQUESTED);
- case syserr_directory_in_cds: return (ERROR_DIRECTORY_IN_CDS);
- case syserr_invalid_fsd_name: return (ERROR_INVALID_FSD_NAME);
- case syserr_invalid_path: return (ERROR_INVALID_PATH);
- case syserr_invalid_ea_name: return (ERROR_INVALID_EA_NAME);
- case syserr_ea_list_inconsistent: return (ERROR_EA_LIST_INCONSISTENT);
- case syserr_ea_list_too_long: return (ERROR_EA_LIST_TOO_LONG);
- case syserr_no_meta_match: return (ERROR_NO_META_MATCH);
- case syserr_findnotify_timeout: return (ERROR_FINDNOTIFY_TIMEOUT);
- case syserr_no_more_items: return (ERROR_NO_MORE_ITEMS);
- case syserr_search_struc_reused: return (ERROR_SEARCH_STRUC_REUSED);
- case syserr_char_not_found: return (ERROR_CHAR_NOT_FOUND);
- case syserr_too_much_stack: return (ERROR_TOO_MUCH_STACK);
- case syserr_invalid_attr: return (ERROR_INVALID_ATTR);
- case syserr_invalid_starting_ring: return (ERROR_INVALID_STARTING_RING);
- case syserr_invalid_dll_init_ring: return (ERROR_INVALID_DLL_INIT_RING);
- case syserr_cannot_copy: return (ERROR_CANNOT_COPY);
- case syserr_directory: return (ERROR_DIRECTORY);
- case syserr_oplocked_file: return (ERROR_OPLOCKED_FILE);
- case syserr_oplock_thread_exists: return (ERROR_OPLOCK_THREAD_EXISTS);
- case syserr_volume_changed: return (ERROR_VOLUME_CHANGED);
- case syserr_findnotify_handle_in_use: return (ERROR_FINDNOTIFY_HANDLE_IN_USE);
- case syserr_findnotify_handle_closed: return (ERROR_FINDNOTIFY_HANDLE_CLOSED);
- case syserr_notify_object_removed: return (ERROR_NOTIFY_OBJECT_REMOVED);
- case syserr_already_shutdown: return (ERROR_ALREADY_SHUTDOWN);
- case syserr_eas_didnt_fit: return (ERROR_EAS_DIDNT_FIT);
- case syserr_ea_file_corrupt: return (ERROR_EA_FILE_CORRUPT);
- case syserr_ea_table_full: return (ERROR_EA_TABLE_FULL);
- case syserr_invalid_ea_handle: return (ERROR_INVALID_EA_HANDLE);
- case syserr_no_cluster: return (ERROR_NO_CLUSTER);
- case syserr_create_ea_file: return (ERROR_CREATE_EA_FILE);
- case syserr_cannot_open_ea_file: return (ERROR_CANNOT_OPEN_EA_FILE);
- case syserr_eas_not_supported: return (ERROR_EAS_NOT_SUPPORTED);
- case syserr_need_eas_found: return (ERROR_NEED_EAS_FOUND);
- case syserr_duplicate_handle: return (ERROR_DUPLICATE_HANDLE);
- case syserr_duplicate_name: return (ERROR_DUPLICATE_NAME);
- case syserr_empty_muxwait: return (ERROR_EMPTY_MUXWAIT);
- case syserr_mutex_owned: return (ERROR_MUTEX_OWNED);
- case syserr_not_owner: return (ERROR_NOT_OWNER);
- case syserr_param_too_small: return (ERROR_PARAM_TOO_SMALL);
- case syserr_too_many_handles: return (ERROR_TOO_MANY_HANDLES);
- case syserr_too_many_opens: return (ERROR_TOO_MANY_OPENS);
- case syserr_wrong_type: return (ERROR_WRONG_TYPE);
- case syserr_unused_code: return (ERROR_UNUSED_CODE);
- case syserr_thread_not_terminated: return (ERROR_THREAD_NOT_TERMINATED);
- case syserr_init_routine_failed: return (ERROR_INIT_ROUTINE_FAILED);
- case syserr_module_in_use: return (ERROR_MODULE_IN_USE);
- case syserr_not_enough_watchpoints: return (ERROR_NOT_ENOUGH_WATCHPOINTS);
- case syserr_too_many_posts: return (ERROR_TOO_MANY_POSTS);
- case syserr_already_posted: return (ERROR_ALREADY_POSTED);
- case syserr_already_reset: return (ERROR_ALREADY_RESET);
- case syserr_sem_busy: return (ERROR_SEM_BUSY);
- case syserr_invalid_procid: return (ERROR_INVALID_PROCID);
- case syserr_invalid_pdelta: return (ERROR_INVALID_PDELTA);
- case syserr_not_descendant: return (ERROR_NOT_DESCENDANT);
- case syserr_not_session_manager: return (ERROR_NOT_SESSION_MANAGER);
- case syserr_invalid_pclass: return (ERROR_INVALID_PCLASS);
- case syserr_invalid_scope: return (ERROR_INVALID_SCOPE);
- case syserr_invalid_threadid: return (ERROR_INVALID_THREADID);
- case syserr_dossub_shrink: return (ERROR_DOSSUB_SHRINK);
- case syserr_dossub_nomem: return (ERROR_DOSSUB_NOMEM);
- case syserr_dossub_overlap: return (ERROR_DOSSUB_OVERLAP);
- case syserr_dossub_badsize: return (ERROR_DOSSUB_BADSIZE);
- case syserr_dossub_badflag: return (ERROR_DOSSUB_BADFLAG);
- case syserr_dossub_badselector: return (ERROR_DOSSUB_BADSELECTOR);
- case syserr_mr_msg_too_long: return (ERROR_MR_MSG_TOO_LONG);
- case syserr_mr_mid_not_found: return (ERROR_MR_MID_NOT_FOUND);
- case syserr_mr_un_acc_msgf: return (ERROR_MR_UN_ACC_MSGF);
- case syserr_mr_inv_msgf_format: return (ERROR_MR_INV_MSGF_FORMAT);
- case syserr_mr_inv_ivcount: return (ERROR_MR_INV_IVCOUNT);
- case syserr_mr_un_perform: return (ERROR_MR_UN_PERFORM);
- case syserr_ts_wakeup: return (ERROR_TS_WAKEUP);
- case syserr_ts_semhandle: return (ERROR_TS_SEMHANDLE);
- case syserr_ts_notimer: return (ERROR_TS_NOTIMER);
- case syserr_ts_handle: return (ERROR_TS_HANDLE);
- case syserr_ts_datetime: return (ERROR_TS_DATETIME);
- case syserr_sys_internal: return (ERROR_SYS_INTERNAL);
- case syserr_que_current_name: return (ERROR_QUE_CURRENT_NAME);
- case syserr_que_proc_not_owned: return (ERROR_QUE_PROC_NOT_OWNED);
- case syserr_que_proc_owned: return (ERROR_QUE_PROC_OWNED);
- case syserr_que_duplicate: return (ERROR_QUE_DUPLICATE);
- case syserr_que_element_not_exist: return (ERROR_QUE_ELEMENT_NOT_EXIST);
- case syserr_que_no_memory: return (ERROR_QUE_NO_MEMORY);
- case syserr_que_invalid_name: return (ERROR_QUE_INVALID_NAME);
- case syserr_que_invalid_priority: return (ERROR_QUE_INVALID_PRIORITY);
- case syserr_que_invalid_handle: return (ERROR_QUE_INVALID_HANDLE);
- case syserr_que_link_not_found: return (ERROR_QUE_LINK_NOT_FOUND);
- case syserr_que_memory_error: return (ERROR_QUE_MEMORY_ERROR);
- case syserr_que_prev_at_end: return (ERROR_QUE_PREV_AT_END);
- case syserr_que_proc_no_access: return (ERROR_QUE_PROC_NO_ACCESS);
- case syserr_que_empty: return (ERROR_QUE_EMPTY);
- case syserr_que_name_not_exist: return (ERROR_QUE_NAME_NOT_EXIST);
- case syserr_que_not_initialized: return (ERROR_QUE_NOT_INITIALIZED);
- case syserr_que_unable_to_access: return (ERROR_QUE_UNABLE_TO_ACCESS);
- case syserr_que_unable_to_add: return (ERROR_QUE_UNABLE_TO_ADD);
- case syserr_que_unable_to_init: return (ERROR_QUE_UNABLE_TO_INIT);
- case syserr_vio_invalid_mask: return (ERROR_VIO_INVALID_MASK);
- case syserr_vio_ptr: return (ERROR_VIO_PTR);
- case syserr_vio_aptr: return (ERROR_VIO_APTR);
- case syserr_vio_rptr: return (ERROR_VIO_RPTR);
- case syserr_vio_cptr: return (ERROR_VIO_CPTR);
- case syserr_vio_lptr: return (ERROR_VIO_LPTR);
- case syserr_vio_mode: return (ERROR_VIO_MODE);
- case syserr_vio_width: return (ERROR_VIO_WIDTH);
- case syserr_vio_attr: return (ERROR_VIO_ATTR);
- case syserr_vio_row: return (ERROR_VIO_ROW);
- case syserr_vio_col: return (ERROR_VIO_COL);
- case syserr_vio_toprow: return (ERROR_VIO_TOPROW);
- case syserr_vio_botrow: return (ERROR_VIO_BOTROW);
- case syserr_vio_rightcol: return (ERROR_VIO_RIGHTCOL);
- case syserr_vio_leftcol: return (ERROR_VIO_LEFTCOL);
- case syserr_scs_call: return (ERROR_SCS_CALL);
- case syserr_scs_value: return (ERROR_SCS_VALUE);
- case syserr_vio_wait_flag: return (ERROR_VIO_WAIT_FLAG);
- case syserr_vio_unlock: return (ERROR_VIO_UNLOCK);
- case syserr_sgs_not_session_mgr: return (ERROR_SGS_NOT_SESSION_MGR);
- case syserr_smg_invalid_session_id: return (ERROR_SMG_INVALID_SESSION_ID);
- case syserr_smg_no_sessions: return (ERROR_SMG_NO_SESSIONS);
- case syserr_smg_session_not_found: return (ERROR_SMG_SESSION_NOT_FOUND);
- case syserr_smg_set_title: return (ERROR_SMG_SET_TITLE);
- case syserr_kbd_parameter: return (ERROR_KBD_PARAMETER);
- case syserr_kbd_no_device: return (ERROR_KBD_NO_DEVICE);
- case syserr_kbd_invalid_iowait: return (ERROR_KBD_INVALID_IOWAIT);
- case syserr_kbd_invalid_length: return (ERROR_KBD_INVALID_LENGTH);
- case syserr_kbd_invalid_echo_mask: return (ERROR_KBD_INVALID_ECHO_MASK);
- case syserr_kbd_invalid_input_mask: return (ERROR_KBD_INVALID_INPUT_MASK);
- case syserr_mon_invalid_parms: return (ERROR_MON_INVALID_PARMS);
- case syserr_mon_invalid_devname: return (ERROR_MON_INVALID_DEVNAME);
- case syserr_mon_invalid_handle: return (ERROR_MON_INVALID_HANDLE);
- case syserr_mon_buffer_too_small: return (ERROR_MON_BUFFER_TOO_SMALL);
- case syserr_mon_buffer_empty: return (ERROR_MON_BUFFER_EMPTY);
- case syserr_mon_data_too_large: return (ERROR_MON_DATA_TOO_LARGE);
- case syserr_mouse_no_device: return (ERROR_MOUSE_NO_DEVICE);
- case syserr_mouse_inv_handle: return (ERROR_MOUSE_INV_HANDLE);
- case syserr_mouse_inv_parms: return (ERROR_MOUSE_INV_PARMS);
- case syserr_mouse_cant_reset: return (ERROR_MOUSE_CANT_RESET);
- case syserr_mouse_display_parms: return (ERROR_MOUSE_DISPLAY_PARMS);
- case syserr_mouse_inv_module: return (ERROR_MOUSE_INV_MODULE);
- case syserr_mouse_inv_entry_pt: return (ERROR_MOUSE_INV_ENTRY_PT);
- case syserr_mouse_inv_mask: return (ERROR_MOUSE_INV_MASK);
- case syserr_mouse_no_data: return (NO_ERROR_MOUSE_NO_DATA);
- case syserr_mouse_ptr_drawn: return (NO_ERROR_MOUSE_PTR_DRAWN);
- case syserr_invalid_frequency: return (ERROR_INVALID_FREQUENCY);
- case syserr_nls_no_country_file: return (ERROR_NLS_NO_COUNTRY_FILE);
- case syserr_nls_open_failed: return (ERROR_NLS_OPEN_FAILED);
-#ifdef ERROR_NO_COUNTRY_OR_CODEPAGE
- case syserr_no_country_or_codepage: return (ERROR_NO_COUNTRY_OR_CODEPAGE);
-#endif
- case syserr_nls_table_truncated: return (ERROR_NLS_TABLE_TRUNCATED);
- case syserr_nls_bad_type: return (ERROR_NLS_BAD_TYPE);
- case syserr_nls_type_not_found: return (ERROR_NLS_TYPE_NOT_FOUND);
- case syserr_vio_smg_only: return (ERROR_VIO_SMG_ONLY);
- case syserr_vio_invalid_asciiz: return (ERROR_VIO_INVALID_ASCIIZ);
- case syserr_vio_deregister: return (ERROR_VIO_DEREGISTER);
- case syserr_vio_no_popup: return (ERROR_VIO_NO_POPUP);
- case syserr_vio_existing_popup: return (ERROR_VIO_EXISTING_POPUP);
- case syserr_kbd_smg_only: return (ERROR_KBD_SMG_ONLY);
- case syserr_kbd_invalid_asciiz: return (ERROR_KBD_INVALID_ASCIIZ);
- case syserr_kbd_invalid_mask: return (ERROR_KBD_INVALID_MASK);
- case syserr_kbd_register: return (ERROR_KBD_REGISTER);
- case syserr_kbd_deregister: return (ERROR_KBD_DEREGISTER);
- case syserr_mouse_smg_only: return (ERROR_MOUSE_SMG_ONLY);
- case syserr_mouse_invalid_asciiz: return (ERROR_MOUSE_INVALID_ASCIIZ);
- case syserr_mouse_invalid_mask: return (ERROR_MOUSE_INVALID_MASK);
- case syserr_mouse_register: return (ERROR_MOUSE_REGISTER);
- case syserr_mouse_deregister: return (ERROR_MOUSE_DEREGISTER);
- case syserr_smg_bad_action: return (ERROR_SMG_BAD_ACTION);
- case syserr_smg_invalid_call: return (ERROR_SMG_INVALID_CALL);
- case syserr_scs_sg_notfound: return (ERROR_SCS_SG_NOTFOUND);
- case syserr_scs_not_shell: return (ERROR_SCS_NOT_SHELL);
- case syserr_vio_invalid_parms: return (ERROR_VIO_INVALID_PARMS);
- case syserr_vio_function_owned: return (ERROR_VIO_FUNCTION_OWNED);
- case syserr_vio_return: return (ERROR_VIO_RETURN);
- case syserr_scs_invalid_function: return (ERROR_SCS_INVALID_FUNCTION);
- case syserr_scs_not_session_mgr: return (ERROR_SCS_NOT_SESSION_MGR);
- case syserr_vio_register: return (ERROR_VIO_REGISTER);
- case syserr_vio_no_mode_thread: return (ERROR_VIO_NO_MODE_THREAD);
- case syserr_vio_no_save_restore_thd: return (ERROR_VIO_NO_SAVE_RESTORE_THD);
- case syserr_vio_in_bg: return (ERROR_VIO_IN_BG);
- case syserr_vio_illegal_during_popup: return (ERROR_VIO_ILLEGAL_DURING_POPUP);
- case syserr_smg_not_baseshell: return (ERROR_SMG_NOT_BASESHELL);
- case syserr_smg_bad_statusreq: return (ERROR_SMG_BAD_STATUSREQ);
- case syserr_que_invalid_wait: return (ERROR_QUE_INVALID_WAIT);
- case syserr_vio_lock: return (ERROR_VIO_LOCK);
- case syserr_mouse_invalid_iowait: return (ERROR_MOUSE_INVALID_IOWAIT);
- case syserr_vio_invalid_handle: return (ERROR_VIO_INVALID_HANDLE);
- case syserr_vio_illegal_during_lock: return (ERROR_VIO_ILLEGAL_DURING_LOCK);
- case syserr_vio_invalid_length: return (ERROR_VIO_INVALID_LENGTH);
- case syserr_kbd_invalid_handle: return (ERROR_KBD_INVALID_HANDLE);
- case syserr_kbd_no_more_handle: return (ERROR_KBD_NO_MORE_HANDLE);
- case syserr_kbd_cannot_create_kcb: return (ERROR_KBD_CANNOT_CREATE_KCB);
- case syserr_kbd_codepage_load_incompl: return (ERROR_KBD_CODEPAGE_LOAD_INCOMPL);
- case syserr_kbd_invalid_codepage_id: return (ERROR_KBD_INVALID_CODEPAGE_ID);
- case syserr_kbd_no_codepage_support: return (ERROR_KBD_NO_CODEPAGE_SUPPORT);
- case syserr_kbd_focus_required: return (ERROR_KBD_FOCUS_REQUIRED);
- case syserr_kbd_focus_already_active: return (ERROR_KBD_FOCUS_ALREADY_ACTIVE);
- case syserr_kbd_keyboard_busy: return (ERROR_KBD_KEYBOARD_BUSY);
- case syserr_kbd_invalid_codepage: return (ERROR_KBD_INVALID_CODEPAGE);
- case syserr_kbd_unable_to_focus: return (ERROR_KBD_UNABLE_TO_FOCUS);
- case syserr_smg_session_non_select: return (ERROR_SMG_SESSION_NON_SELECT);
- case syserr_smg_session_not_foregrnd: return (ERROR_SMG_SESSION_NOT_FOREGRND);
- case syserr_smg_session_not_parent: return (ERROR_SMG_SESSION_NOT_PARENT);
- case syserr_smg_invalid_start_mode: return (ERROR_SMG_INVALID_START_MODE);
- case syserr_smg_invalid_related_opt: return (ERROR_SMG_INVALID_RELATED_OPT);
- case syserr_smg_invalid_bond_option: return (ERROR_SMG_INVALID_BOND_OPTION);
- case syserr_smg_invalid_select_opt: return (ERROR_SMG_INVALID_SELECT_OPT);
- case syserr_smg_start_in_background: return (ERROR_SMG_START_IN_BACKGROUND);
- case syserr_smg_invalid_stop_option: return (ERROR_SMG_INVALID_STOP_OPTION);
- case syserr_smg_bad_reserve: return (ERROR_SMG_BAD_RESERVE);
- case syserr_smg_process_not_parent: return (ERROR_SMG_PROCESS_NOT_PARENT);
- case syserr_smg_invalid_data_length: return (ERROR_SMG_INVALID_DATA_LENGTH);
- case syserr_smg_not_bound: return (ERROR_SMG_NOT_BOUND);
- case syserr_smg_retry_sub_alloc: return (ERROR_SMG_RETRY_SUB_ALLOC);
- case syserr_kbd_detached: return (ERROR_KBD_DETACHED);
- case syserr_vio_detached: return (ERROR_VIO_DETACHED);
- case syserr_mou_detached: return (ERROR_MOU_DETACHED);
- case syserr_vio_font: return (ERROR_VIO_FONT);
- case syserr_vio_user_font: return (ERROR_VIO_USER_FONT);
- case syserr_vio_bad_cp: return (ERROR_VIO_BAD_CP);
- case syserr_vio_no_cp: return (ERROR_VIO_NO_CP);
- case syserr_vio_na_cp: return (ERROR_VIO_NA_CP);
- case syserr_invalid_code_page: return (ERROR_INVALID_CODE_PAGE);
- case syserr_cplist_too_small: return (ERROR_CPLIST_TOO_SMALL);
- case syserr_cp_not_moved: return (ERROR_CP_NOT_MOVED);
- case syserr_mode_switch_init: return (ERROR_MODE_SWITCH_INIT);
- case syserr_code_page_not_found: return (ERROR_CODE_PAGE_NOT_FOUND);
- case syserr_unexpected_slot_returned: return (ERROR_UNEXPECTED_SLOT_RETURNED);
- case syserr_smg_invalid_trace_option: return (ERROR_SMG_INVALID_TRACE_OPTION);
- case syserr_vio_internal_resource: return (ERROR_VIO_INTERNAL_RESOURCE);
- case syserr_vio_shell_init: return (ERROR_VIO_SHELL_INIT);
- case syserr_smg_no_hard_errors: return (ERROR_SMG_NO_HARD_ERRORS);
- case syserr_cp_switch_incomplete: return (ERROR_CP_SWITCH_INCOMPLETE);
- case syserr_vio_transparent_popup: return (ERROR_VIO_TRANSPARENT_POPUP);
- case syserr_critsec_overflow: return (ERROR_CRITSEC_OVERFLOW);
- case syserr_critsec_underflow: return (ERROR_CRITSEC_UNDERFLOW);
- case syserr_vio_bad_reserve: return (ERROR_VIO_BAD_RESERVE);
- case syserr_invalid_address: return (ERROR_INVALID_ADDRESS);
- case syserr_zero_selectors_requested: return (ERROR_ZERO_SELECTORS_REQUESTED);
- case syserr_not_enough_selectors_ava: return (ERROR_NOT_ENOUGH_SELECTORS_AVA);
- case syserr_invalid_selector: return (ERROR_INVALID_SELECTOR);
- case syserr_smg_invalid_program_type: return (ERROR_SMG_INVALID_PROGRAM_TYPE);
- case syserr_smg_invalid_pgm_control: return (ERROR_SMG_INVALID_PGM_CONTROL);
- case syserr_smg_invalid_inherit_opt: return (ERROR_SMG_INVALID_INHERIT_OPT);
- case syserr_vio_extended_sg: return (ERROR_VIO_EXTENDED_SG);
- case syserr_vio_not_pres_mgr_sg: return (ERROR_VIO_NOT_PRES_MGR_SG);
- case syserr_vio_shield_owned: return (ERROR_VIO_SHIELD_OWNED);
- case syserr_vio_no_more_handles: return (ERROR_VIO_NO_MORE_HANDLES);
- case syserr_vio_see_error_log: return (ERROR_VIO_SEE_ERROR_LOG);
- case syserr_vio_associated_dc: return (ERROR_VIO_ASSOCIATED_DC);
- case syserr_kbd_no_console: return (ERROR_KBD_NO_CONSOLE);
- case syserr_mouse_no_console: return (ERROR_MOUSE_NO_CONSOLE);
- case syserr_mouse_invalid_handle: return (ERROR_MOUSE_INVALID_HANDLE);
- case syserr_smg_invalid_debug_parms: return (ERROR_SMG_INVALID_DEBUG_PARMS);
- case syserr_kbd_extended_sg: return (ERROR_KBD_EXTENDED_SG);
- case syserr_mou_extended_sg: return (ERROR_MOU_EXTENDED_SG);
- case syserr_smg_invalid_icon_file: return (ERROR_SMG_INVALID_ICON_FILE);
- case syserr_trc_pid_non_existent: return (ERROR_TRC_PID_NON_EXISTENT);
- case syserr_trc_count_active: return (ERROR_TRC_COUNT_ACTIVE);
- case syserr_trc_suspended_by_count: return (ERROR_TRC_SUSPENDED_BY_COUNT);
- case syserr_trc_count_inactive: return (ERROR_TRC_COUNT_INACTIVE);
- case syserr_trc_count_reached: return (ERROR_TRC_COUNT_REACHED);
- case syserr_no_mc_trace: return (ERROR_NO_MC_TRACE);
- case syserr_mc_trace: return (ERROR_MC_TRACE);
- case syserr_trc_count_zero: return (ERROR_TRC_COUNT_ZERO);
- case syserr_smg_too_many_dds: return (ERROR_SMG_TOO_MANY_DDS);
- case syserr_smg_invalid_notification: return (ERROR_SMG_INVALID_NOTIFICATION);
- case syserr_lf_invalid_function: return (ERROR_LF_INVALID_FUNCTION);
- case syserr_lf_not_avail: return (ERROR_LF_NOT_AVAIL);
- case syserr_lf_suspended: return (ERROR_LF_SUSPENDED);
- case syserr_lf_buf_too_small: return (ERROR_LF_BUF_TOO_SMALL);
- case syserr_lf_buffer_full: return (ERROR_LF_BUFFER_FULL);
- case syserr_lf_invalid_record: return (ERROR_LF_INVALID_RECORD);
- case syserr_lf_invalid_service: return (ERROR_LF_INVALID_SERVICE);
- case syserr_lf_general_failure: return (ERROR_LF_GENERAL_FAILURE);
- case syserr_lf_invalid_id: return (ERROR_LF_INVALID_ID);
- case syserr_lf_invalid_handle: return (ERROR_LF_INVALID_HANDLE);
- case syserr_lf_no_id_avail: return (ERROR_LF_NO_ID_AVAIL);
- case syserr_lf_template_area_full: return (ERROR_LF_TEMPLATE_AREA_FULL);
- case syserr_lf_id_in_use: return (ERROR_LF_ID_IN_USE);
- case syserr_mou_not_initialized: return (ERROR_MOU_NOT_INITIALIZED);
- case syserr_mouinitreal_done: return (ERROR_MOUINITREAL_DONE);
- case syserr_dossub_corrupted: return (ERROR_DOSSUB_CORRUPTED);
- case syserr_mouse_caller_not_subsys: return (ERROR_MOUSE_CALLER_NOT_SUBSYS);
- case syserr_arithmetic_overflow: return (ERROR_ARITHMETIC_OVERFLOW);
- case syserr_tmr_no_device: return (ERROR_TMR_NO_DEVICE);
- case syserr_tmr_invalid_time: return (ERROR_TMR_INVALID_TIME);
- case syserr_pvw_invalid_entity: return (ERROR_PVW_INVALID_ENTITY);
- case syserr_pvw_invalid_entity_type: return (ERROR_PVW_INVALID_ENTITY_TYPE);
- case syserr_pvw_invalid_spec: return (ERROR_PVW_INVALID_SPEC);
- case syserr_pvw_invalid_range_type: return (ERROR_PVW_INVALID_RANGE_TYPE);
- case syserr_pvw_invalid_counter_blk: return (ERROR_PVW_INVALID_COUNTER_BLK);
- case syserr_pvw_invalid_text_blk: return (ERROR_PVW_INVALID_TEXT_BLK);
- case syserr_prf_not_initialized: return (ERROR_PRF_NOT_INITIALIZED);
- case syserr_prf_already_initialized: return (ERROR_PRF_ALREADY_INITIALIZED);
- case syserr_prf_not_started: return (ERROR_PRF_NOT_STARTED);
- case syserr_prf_already_started: return (ERROR_PRF_ALREADY_STARTED);
- case syserr_prf_timer_out_of_range: return (ERROR_PRF_TIMER_OUT_OF_RANGE);
- case syserr_prf_timer_reset: return (ERROR_PRF_TIMER_RESET);
- case syserr_vdd_lock_useage_denied: return (ERROR_VDD_LOCK_USEAGE_DENIED);
- case syserr_timeout: return (ERROR_TIMEOUT);
- case syserr_vdm_down: return (ERROR_VDM_DOWN);
- case syserr_vdm_limit: return (ERROR_VDM_LIMIT);
- case syserr_vdd_not_found: return (ERROR_VDD_NOT_FOUND);
- case syserr_invalid_caller: return (ERROR_INVALID_CALLER);
- case syserr_pid_mismatch: return (ERROR_PID_MISMATCH);
- case syserr_invalid_vdd_handle: return (ERROR_INVALID_VDD_HANDLE);
- case syserr_vlpt_no_spooler: return (ERROR_VLPT_NO_SPOOLER);
- case syserr_vcom_device_busy: return (ERROR_VCOM_DEVICE_BUSY);
- case syserr_vlpt_device_busy: return (ERROR_VLPT_DEVICE_BUSY);
- case syserr_nesting_too_deep: return (ERROR_NESTING_TOO_DEEP);
- case syserr_vdd_missing: return (ERROR_VDD_MISSING);
- case syserr_bidi_invalid_length: return (ERROR_BIDI_INVALID_LENGTH);
- case syserr_bidi_invalid_increment: return (ERROR_BIDI_INVALID_INCREMENT);
- case syserr_bidi_invalid_combination: return (ERROR_BIDI_INVALID_COMBINATION);
- case syserr_bidi_invalid_reserved: return (ERROR_BIDI_INVALID_RESERVED);
- case syserr_bidi_invalid_effect: return (ERROR_BIDI_INVALID_EFFECT);
- case syserr_bidi_invalid_csdrec: return (ERROR_BIDI_INVALID_CSDREC);
- case syserr_bidi_invalid_csdstate: return (ERROR_BIDI_INVALID_CSDSTATE);
- case syserr_bidi_invalid_level: return (ERROR_BIDI_INVALID_LEVEL);
- case syserr_bidi_invalid_type_support: return (ERROR_BIDI_INVALID_TYPE_SUPPORT);
- case syserr_bidi_invalid_orientation: return (ERROR_BIDI_INVALID_ORIENTATION);
- case syserr_bidi_invalid_num_shape: return (ERROR_BIDI_INVALID_NUM_SHAPE);
- case syserr_bidi_invalid_csd: return (ERROR_BIDI_INVALID_CSD);
- case syserr_bidi_no_support: return (ERROR_BIDI_NO_SUPPORT);
- case syserr_bidi_rw_incomplete: return (NO_ERROR_BIDI_RW_INCOMPLETE);
- case syserr_imp_invalid_parm: return (ERROR_IMP_INVALID_PARM);
- case syserr_imp_invalid_length: return (ERROR_IMP_INVALID_LENGTH);
-#ifdef MSG_HPFS_DISK_ERROR_WARN
- case syserr_hpfs_disk_error_warn: return (MSG_HPFS_DISK_ERROR_WARN);
-#endif
- case syserr_mon_bad_buffer: return (ERROR_MON_BAD_BUFFER);
- case syserr_module_corrupted: return (ERROR_MODULE_CORRUPTED);
- case syserr_sm_outof_swapfile: return (ERROR_SM_OUTOF_SWAPFILE);
- case syserr_lf_timeout: return (ERROR_LF_TIMEOUT);
- case syserr_lf_suspend_success: return (ERROR_LF_SUSPEND_SUCCESS);
- case syserr_lf_resume_success: return (ERROR_LF_RESUME_SUCCESS);
- case syserr_lf_redirect_success: return (ERROR_LF_REDIRECT_SUCCESS);
- case syserr_lf_redirect_failure: return (ERROR_LF_REDIRECT_FAILURE);
- case syserr_swapper_not_active: return (ERROR_SWAPPER_NOT_ACTIVE);
- case syserr_invalid_swapid: return (ERROR_INVALID_SWAPID);
- case syserr_ioerr_swap_file: return (ERROR_IOERR_SWAP_FILE);
- case syserr_swap_table_full: return (ERROR_SWAP_TABLE_FULL);
- case syserr_swap_file_full: return (ERROR_SWAP_FILE_FULL);
- case syserr_cant_init_swapper: return (ERROR_CANT_INIT_SWAPPER);
- case syserr_swapper_already_init: return (ERROR_SWAPPER_ALREADY_INIT);
- case syserr_pmm_insufficient_memory: return (ERROR_PMM_INSUFFICIENT_MEMORY);
- case syserr_pmm_invalid_flags: return (ERROR_PMM_INVALID_FLAGS);
- case syserr_pmm_invalid_address: return (ERROR_PMM_INVALID_ADDRESS);
- case syserr_pmm_lock_failed: return (ERROR_PMM_LOCK_FAILED);
- case syserr_pmm_unlock_failed: return (ERROR_PMM_UNLOCK_FAILED);
- case syserr_pmm_move_incomplete: return (ERROR_PMM_MOVE_INCOMPLETE);
- case syserr_ucom_drive_renamed: return (ERROR_UCOM_DRIVE_RENAMED);
- case syserr_ucom_filename_truncated: return (ERROR_UCOM_FILENAME_TRUNCATED);
- case syserr_ucom_buffer_length: return (ERROR_UCOM_BUFFER_LENGTH);
- case syserr_mon_chain_handle: return (ERROR_MON_CHAIN_HANDLE);
- case syserr_mon_not_registered: return (ERROR_MON_NOT_REGISTERED);
- case syserr_smg_already_top: return (ERROR_SMG_ALREADY_TOP);
- case syserr_pmm_arena_modified: return (ERROR_PMM_ARENA_MODIFIED);
- case syserr_smg_printer_open: return (ERROR_SMG_PRINTER_OPEN);
- case syserr_pmm_set_flags_failed: return (ERROR_PMM_SET_FLAGS_FAILED);
- case syserr_invalid_dos_dd: return (ERROR_INVALID_DOS_DD);
- case syserr_blocked: return (ERROR_BLOCKED);
- case syserr_noblock: return (ERROR_NOBLOCK);
- case syserr_instance_shared: return (ERROR_INSTANCE_SHARED);
- case syserr_no_object: return (ERROR_NO_OBJECT);
- case syserr_partial_attach: return (ERROR_PARTIAL_ATTACH);
- case syserr_incache: return (ERROR_INCACHE);
- case syserr_swap_io_problems: return (ERROR_SWAP_IO_PROBLEMS);
- case syserr_crosses_object_boundary: return (ERROR_CROSSES_OBJECT_BOUNDARY);
- case syserr_longlock: return (ERROR_LONGLOCK);
- case syserr_shortlock: return (ERROR_SHORTLOCK);
- case syserr_uvirtlock: return (ERROR_UVIRTLOCK);
- case syserr_aliaslock: return (ERROR_ALIASLOCK);
- case syserr_alias: return (ERROR_ALIAS);
- case syserr_no_more_handles: return (ERROR_NO_MORE_HANDLES);
- case syserr_scan_terminated: return (ERROR_SCAN_TERMINATED);
- case syserr_terminator_not_found: return (ERROR_TERMINATOR_NOT_FOUND);
- case syserr_not_direct_child: return (ERROR_NOT_DIRECT_CHILD);
- case syserr_delay_free: return (ERROR_DELAY_FREE);
- case syserr_guardpage: return (ERROR_GUARDPAGE);
- case syserr_swaperror: return (ERROR_SWAPERROR);
- case syserr_ldrerror: return (ERROR_LDRERROR);
- case syserr_nomemory: return (ERROR_NOMEMORY);
- case syserr_noaccess: return (ERROR_NOACCESS);
- case syserr_no_dll_term: return (ERROR_NO_DLL_TERM);
- case syserr_cpsio_code_page_invalid: return (ERROR_CPSIO_CODE_PAGE_INVALID);
- case syserr_cpsio_no_spooler: return (ERROR_CPSIO_NO_SPOOLER);
- case syserr_cpsio_font_id_invalid: return (ERROR_CPSIO_FONT_ID_INVALID);
- case syserr_cpsio_internal_error: return (ERROR_CPSIO_INTERNAL_ERROR);
- case syserr_cpsio_invalid_ptr_name: return (ERROR_CPSIO_INVALID_PTR_NAME);
- case syserr_cpsio_not_active: return (ERROR_CPSIO_NOT_ACTIVE);
- case syserr_cpsio_pid_full: return (ERROR_CPSIO_PID_FULL);
- case syserr_cpsio_pid_not_found: return (ERROR_CPSIO_PID_NOT_FOUND);
- case syserr_cpsio_read_ctl_seq: return (ERROR_CPSIO_READ_CTL_SEQ);
- case syserr_cpsio_read_fnt_def: return (ERROR_CPSIO_READ_FNT_DEF);
- case syserr_cpsio_write_error: return (ERROR_CPSIO_WRITE_ERROR);
- case syserr_cpsio_write_full_error: return (ERROR_CPSIO_WRITE_FULL_ERROR);
- case syserr_cpsio_write_handle_bad: return (ERROR_CPSIO_WRITE_HANDLE_BAD);
- case syserr_cpsio_swit_load: return (ERROR_CPSIO_SWIT_LOAD);
- case syserr_cpsio_inv_command: return (ERROR_CPSIO_INV_COMMAND);
- case syserr_cpsio_no_font_swit: return (ERROR_CPSIO_NO_FONT_SWIT);
- case syserr_entry_is_callgate: return (ERROR_ENTRY_IS_CALLGATE);
-
-#ifndef DISABLE_SOCKET_SUPPORT
- case syserr_socket_perm: return (SOCEPERM);
- case syserr_socket_srch: return (SOCESRCH);
- case syserr_socket_intr: return (SOCEINTR);
- case syserr_socket_nxio: return (SOCENXIO);
- case syserr_socket_badf: return (SOCEBADF);
- case syserr_socket_acces: return (SOCEACCES);
- case syserr_socket_fault: return (SOCEFAULT);
- case syserr_socket_inval: return (SOCEINVAL);
- case syserr_socket_mfile: return (SOCEMFILE);
- case syserr_socket_pipe: return (SOCEPIPE);
- case syserr_socket_os2err: return (SOCEOS2ERR);
- case syserr_socket_wouldblock: return (SOCEWOULDBLOCK);
- case syserr_socket_inprogress: return (SOCEINPROGRESS);
- case syserr_socket_already: return (SOCEALREADY);
- case syserr_socket_notsock: return (SOCENOTSOCK);
- case syserr_socket_destaddrreq: return (SOCEDESTADDRREQ);
- case syserr_socket_msgsize: return (SOCEMSGSIZE);
- case syserr_socket_prototype: return (SOCEPROTOTYPE);
- case syserr_socket_noprotoopt: return (SOCENOPROTOOPT);
- case syserr_socket_protonosupport: return (SOCEPROTONOSUPPORT);
- case syserr_socket_socktnosupport: return (SOCESOCKTNOSUPPORT);
- case syserr_socket_opnotsupp: return (SOCEOPNOTSUPP);
- case syserr_socket_pfnosupport: return (SOCEPFNOSUPPORT);
- case syserr_socket_afnosupport: return (SOCEAFNOSUPPORT);
- case syserr_socket_addrinuse: return (SOCEADDRINUSE);
- case syserr_socket_addrnotavail: return (SOCEADDRNOTAVAIL);
- case syserr_socket_netdown: return (SOCENETDOWN);
- case syserr_socket_netunreach: return (SOCENETUNREACH);
- case syserr_socket_netreset: return (SOCENETRESET);
- case syserr_socket_connaborted: return (SOCECONNABORTED);
- case syserr_socket_connreset: return (SOCECONNRESET);
- case syserr_socket_nobufs: return (SOCENOBUFS);
- case syserr_socket_isconn: return (SOCEISCONN);
- case syserr_socket_notconn: return (SOCENOTCONN);
- case syserr_socket_shutdown: return (SOCESHUTDOWN);
- case syserr_socket_toomanyrefs: return (SOCETOOMANYREFS);
- case syserr_socket_timedout: return (SOCETIMEDOUT);
- case syserr_socket_connrefused: return (SOCECONNREFUSED);
- case syserr_socket_loop: return (SOCELOOP);
- case syserr_socket_nametoolong: return (SOCENAMETOOLONG);
- case syserr_socket_hostdown: return (SOCEHOSTDOWN);
- case syserr_socket_hostunreach: return (SOCEHOSTUNREACH);
- case syserr_socket_notempty: return (SOCENOTEMPTY);
-#endif /* not DISABLE_SOCKET_SUPPORT */
-
- default: return (NO_ERROR);
- }
-}
-\f
-#ifdef __GCC2__
-/* Grumble... stupid linking bug. */
-#define dos_error_message(rc) 0
-#else /* not __GCC2__ */
-
-static const char *
-dos_error_message (APIRET rc)
-{
- unsigned int blength_increment = 64;
- unsigned int blength = blength_increment;
- char * buffer = (OS2_malloc_noerror (blength));
- ULONG mlength;
-
- if (buffer == 0)
- return (0);
- while (1)
- {
- if ((dos_get_message
- (0, 0, buffer, blength, rc, "OSO001.MSG", (&mlength)))
- != NO_ERROR)
- {
- OS_free (buffer);
- return (0);
- }
- if (mlength < blength)
- {
- while ((mlength > 0) && (isspace (buffer [mlength - 1])))
- mlength -= 1;
- buffer = (OS2_realloc_noerror (buffer, (mlength + 1)));
- if (buffer != 0)
- (buffer[mlength]) = '\0';
- return (buffer);
- }
- blength += blength_increment;
- buffer = (OS2_realloc_noerror (buffer, (blength)));
- if (buffer == 0)
- return (0);
- }
-}
-
-#endif /* not __GCC2__ */
-
-const char *
-OS_error_code_to_message (unsigned int syserr)
-{
- static const char * last_message = 0;
- APIRET code = (syserr_to_error_code ((enum syserr_names) syserr));
- if (code == NO_ERROR)
- return (0);
- if (last_message != 0)
- OS_free ((void *) last_message);
- last_message = (dos_error_message (code));
- /* Many of OS/2's error messages are terminated with a period, but
- the runtime system is assuming that the messages have no period,
- and adding its own. */
- if (last_message != 0)
- {
- unsigned int length = (strlen (last_message));
- if ((length > 0) && ((last_message [length - 1]) == '.'))
- (((char *) last_message) [length - 1]) = '\0';
- }
- return (last_message);
-}
-\f
-/* Machine-generated table, do not edit: */
-static char * syserr_names_table [] =
-{
- "invalid-function",
- "file-not-found",
- "path-not-found",
- "too-many-open-files",
- "access-denied",
- "invalid-handle",
- "arena-trashed",
- "not-enough-memory",
- "invalid-block",
- "bad-environment",
- "bad-format",
- "invalid-access",
- "invalid-data",
- "invalid-drive",
- "current-directory",
- "not-same-device",
- "no-more-files",
- "write-protect",
- "bad-unit",
- "not-ready",
- "bad-command",
- "crc",
- "bad-length",
- "seek",
- "not-dos-disk",
- "sector-not-found",
- "out-of-paper",
- "write-fault",
- "read-fault",
- "gen-failure",
- "sharing-violation",
- "lock-violation",
- "wrong-disk",
- "fcb-unavailable",
- "sharing-buffer-exceeded",
- "code-page-mismatched",
- "handle-eof",
- "handle-disk-full",
- "not-supported",
- "rem-not-list",
- "dup-name",
- "bad-netpath",
- "network-busy",
- "dev-not-exist",
- "too-many-cmds",
- "adap-hdw-err",
- "bad-net-resp",
- "unexp-net-err",
- "bad-rem-adap",
- "printq-full",
- "no-spool-space",
- "print-cancelled",
- "netname-deleted",
- "network-access-denied",
- "bad-dev-type",
- "bad-net-name",
- "too-many-names",
- "too-many-sess",
- "sharing-paused",
- "req-not-accep",
- "redir-paused",
- "sbcs-att-write-prot",
- "sbcs-general-failure",
- "xga-out-memory",
- "file-exists",
- "dup-fcb",
- "cannot-make",
- "fail-i24",
- "out-of-structures",
- "already-assigned",
- "invalid-password",
- "invalid-parameter",
- "net-write-fault",
- "no-proc-slots",
- "not-frozen",
- "tstovfl",
- "tstdup",
- "no-items",
- "interrupt",
- "device-in-use",
- "too-many-semaphores",
- "excl-sem-already-owned",
- "sem-is-set",
- "too-many-sem-requests",
- "invalid-at-interrupt-time",
- "sem-owner-died",
- "sem-user-limit",
- "disk-change",
- "drive-locked",
- "broken-pipe",
- "open-failed",
- "buffer-overflow",
- "disk-full",
- "no-more-search-handles",
- "invalid-target-handle",
- "protection-violation",
- "viokbd-request",
- "invalid-category",
- "invalid-verify-switch",
- "bad-driver-level",
- "call-not-implemented",
- "sem-timeout",
- "insufficient-buffer",
- "invalid-name",
- "invalid-level",
- "no-volume-label",
- "mod-not-found",
- "proc-not-found",
- "wait-no-children",
- "child-not-complete",
- "direct-access-handle",
- "negative-seek",
- "seek-on-device",
- "is-join-target",
- "is-joined",
- "is-substed",
- "not-joined",
- "not-substed",
- "join-to-join",
- "subst-to-subst",
- "join-to-subst",
- "subst-to-join",
- "busy-drive",
- "same-drive",
- "dir-not-root",
- "dir-not-empty",
- "is-subst-path",
- "is-join-path",
- "path-busy",
- "is-subst-target",
- "system-trace",
- "invalid-event-count",
- "too-many-muxwaiters",
- "invalid-list-format",
- "label-too-long",
- "too-many-tcbs",
- "signal-refused",
- "discarded",
- "not-locked",
- "bad-threadid-addr",
- "bad-arguments",
- "bad-pathname",
- "signal-pending",
- "uncertain-media",
- "max-thrds-reached",
- "monitors-not-supported",
- "unc-driver-not-installed",
- "lock-failed",
- "swapio-failed",
- "swapin-failed",
- "busy",
- "cancel-violation",
- "atomic-lock-not-supported",
- "read-locks-not-supported",
- "invalid-segment-number",
- "invalid-callgate",
- "invalid-ordinal",
- "already-exists",
- "no-child-process",
- "child-alive-nowait",
- "invalid-flag-number",
- "sem-not-found",
- "invalid-starting-codeseg",
- "invalid-stackseg",
- "invalid-moduletype",
- "invalid-exe-signature",
- "exe-marked-invalid",
- "bad-exe-format",
- "iterated-data-exceeds-64k",
- "invalid-minallocsize",
- "dynlink-from-invalid-ring",
- "iopl-not-enabled",
- "invalid-segdpl",
- "autodataseg-exceeds-64k",
- "ring2seg-must-be-movable",
- "reloc-chain-xeeds-seglim",
- "infloop-in-reloc-chain",
- "envvar-not-found",
- "not-current-ctry",
- "no-signal-sent",
- "filename-exced-range",
- "ring2-stack-in-use",
- "meta-expansion-too-long",
- "invalid-signal-number",
- "thread-1-inactive",
- "info-not-avail",
- "locked",
- "bad-dynalink",
- "too-many-modules",
- "nesting-not-allowed",
- "cannot-shrink",
- "zombie-process",
- "stack-in-high-memory",
- "invalid-exitroutine-ring",
- "getbuf-failed",
- "flushbuf-failed",
- "transfer-too-long",
- "forcenoswap-failed",
- "smg-no-target-window",
- "no-children",
- "invalid-screen-group",
- "bad-pipe",
- "pipe-busy",
- "no-data",
- "pipe-not-connected",
- "more-data",
- "vc-disconnected",
- "circularity-requested",
- "directory-in-cds",
- "invalid-fsd-name",
- "invalid-path",
- "invalid-ea-name",
- "ea-list-inconsistent",
- "ea-list-too-long",
- "no-meta-match",
- "findnotify-timeout",
- "no-more-items",
- "search-struc-reused",
- "char-not-found",
- "too-much-stack",
- "invalid-attr",
- "invalid-starting-ring",
- "invalid-dll-init-ring",
- "cannot-copy",
- "directory",
- "oplocked-file",
- "oplock-thread-exists",
- "volume-changed",
- "findnotify-handle-in-use",
- "findnotify-handle-closed",
- "notify-object-removed",
- "already-shutdown",
- "eas-didnt-fit",
- "ea-file-corrupt",
- "ea-table-full",
- "invalid-ea-handle",
- "no-cluster",
- "create-ea-file",
- "cannot-open-ea-file",
- "eas-not-supported",
- "need-eas-found",
- "duplicate-handle",
- "duplicate-name",
- "empty-muxwait",
- "mutex-owned",
- "not-owner",
- "param-too-small",
- "too-many-handles",
- "too-many-opens",
- "wrong-type",
- "unused-code",
- "thread-not-terminated",
- "init-routine-failed",
- "module-in-use",
- "not-enough-watchpoints",
- "too-many-posts",
- "already-posted",
- "already-reset",
- "sem-busy",
- "invalid-procid",
- "invalid-pdelta",
- "not-descendant",
- "not-session-manager",
- "invalid-pclass",
- "invalid-scope",
- "invalid-threadid",
- "dossub-shrink",
- "dossub-nomem",
- "dossub-overlap",
- "dossub-badsize",
- "dossub-badflag",
- "dossub-badselector",
- "mr-msg-too-long",
- "mr-mid-not-found",
- "mr-un-acc-msgf",
- "mr-inv-msgf-format",
- "mr-inv-ivcount",
- "mr-un-perform",
- "ts-wakeup",
- "ts-semhandle",
- "ts-notimer",
- "ts-handle",
- "ts-datetime",
- "sys-internal",
- "que-current-name",
- "que-proc-not-owned",
- "que-proc-owned",
- "que-duplicate",
- "que-element-not-exist",
- "que-no-memory",
- "que-invalid-name",
- "que-invalid-priority",
- "que-invalid-handle",
- "que-link-not-found",
- "que-memory-error",
- "que-prev-at-end",
- "que-proc-no-access",
- "que-empty",
- "que-name-not-exist",
- "que-not-initialized",
- "que-unable-to-access",
- "que-unable-to-add",
- "que-unable-to-init",
- "vio-invalid-mask",
- "vio-ptr",
- "vio-aptr",
- "vio-rptr",
- "vio-cptr",
- "vio-lptr",
- "vio-mode",
- "vio-width",
- "vio-attr",
- "vio-row",
- "vio-col",
- "vio-toprow",
- "vio-botrow",
- "vio-rightcol",
- "vio-leftcol",
- "scs-call",
- "scs-value",
- "vio-wait-flag",
- "vio-unlock",
- "sgs-not-session-mgr",
- "smg-invalid-session-id",
- "smg-no-sessions",
- "smg-session-not-found",
- "smg-set-title",
- "kbd-parameter",
- "kbd-no-device",
- "kbd-invalid-iowait",
- "kbd-invalid-length",
- "kbd-invalid-echo-mask",
- "kbd-invalid-input-mask",
- "mon-invalid-parms",
- "mon-invalid-devname",
- "mon-invalid-handle",
- "mon-buffer-too-small",
- "mon-buffer-empty",
- "mon-data-too-large",
- "mouse-no-device",
- "mouse-inv-handle",
- "mouse-inv-parms",
- "mouse-cant-reset",
- "mouse-display-parms",
- "mouse-inv-module",
- "mouse-inv-entry-pt",
- "mouse-inv-mask",
- "mouse-no-data",
- "mouse-ptr-drawn",
- "invalid-frequency",
- "nls-no-country-file",
- "nls-open-failed",
- "no-country-or-codepage",
- "nls-table-truncated",
- "nls-bad-type",
- "nls-type-not-found",
- "vio-smg-only",
- "vio-invalid-asciiz",
- "vio-deregister",
- "vio-no-popup",
- "vio-existing-popup",
- "kbd-smg-only",
- "kbd-invalid-asciiz",
- "kbd-invalid-mask",
- "kbd-register",
- "kbd-deregister",
- "mouse-smg-only",
- "mouse-invalid-asciiz",
- "mouse-invalid-mask",
- "mouse-register",
- "mouse-deregister",
- "smg-bad-action",
- "smg-invalid-call",
- "scs-sg-notfound",
- "scs-not-shell",
- "vio-invalid-parms",
- "vio-function-owned",
- "vio-return",
- "scs-invalid-function",
- "scs-not-session-mgr",
- "vio-register",
- "vio-no-mode-thread",
- "vio-no-save-restore-thd",
- "vio-in-bg",
- "vio-illegal-during-popup",
- "smg-not-baseshell",
- "smg-bad-statusreq",
- "que-invalid-wait",
- "vio-lock",
- "mouse-invalid-iowait",
- "vio-invalid-handle",
- "vio-illegal-during-lock",
- "vio-invalid-length",
- "kbd-invalid-handle",
- "kbd-no-more-handle",
- "kbd-cannot-create-kcb",
- "kbd-codepage-load-incompl",
- "kbd-invalid-codepage-id",
- "kbd-no-codepage-support",
- "kbd-focus-required",
- "kbd-focus-already-active",
- "kbd-keyboard-busy",
- "kbd-invalid-codepage",
- "kbd-unable-to-focus",
- "smg-session-non-select",
- "smg-session-not-foregrnd",
- "smg-session-not-parent",
- "smg-invalid-start-mode",
- "smg-invalid-related-opt",
- "smg-invalid-bond-option",
- "smg-invalid-select-opt",
- "smg-start-in-background",
- "smg-invalid-stop-option",
- "smg-bad-reserve",
- "smg-process-not-parent",
- "smg-invalid-data-length",
- "smg-not-bound",
- "smg-retry-sub-alloc",
- "kbd-detached",
- "vio-detached",
- "mou-detached",
- "vio-font",
- "vio-user-font",
- "vio-bad-cp",
- "vio-no-cp",
- "vio-na-cp",
- "invalid-code-page",
- "cplist-too-small",
- "cp-not-moved",
- "mode-switch-init",
- "code-page-not-found",
- "unexpected-slot-returned",
- "smg-invalid-trace-option",
- "vio-internal-resource",
- "vio-shell-init",
- "smg-no-hard-errors",
- "cp-switch-incomplete",
- "vio-transparent-popup",
- "critsec-overflow",
- "critsec-underflow",
- "vio-bad-reserve",
- "invalid-address",
- "zero-selectors-requested",
- "not-enough-selectors-ava",
- "invalid-selector",
- "smg-invalid-program-type",
- "smg-invalid-pgm-control",
- "smg-invalid-inherit-opt",
- "vio-extended-sg",
- "vio-not-pres-mgr-sg",
- "vio-shield-owned",
- "vio-no-more-handles",
- "vio-see-error-log",
- "vio-associated-dc",
- "kbd-no-console",
- "mouse-no-console",
- "mouse-invalid-handle",
- "smg-invalid-debug-parms",
- "kbd-extended-sg",
- "mou-extended-sg",
- "smg-invalid-icon-file",
- "trc-pid-non-existent",
- "trc-count-active",
- "trc-suspended-by-count",
- "trc-count-inactive",
- "trc-count-reached",
- "no-mc-trace",
- "mc-trace",
- "trc-count-zero",
- "smg-too-many-dds",
- "smg-invalid-notification",
- "lf-invalid-function",
- "lf-not-avail",
- "lf-suspended",
- "lf-buf-too-small",
- "lf-buffer-full",
- "lf-invalid-record",
- "lf-invalid-service",
- "lf-general-failure",
- "lf-invalid-id",
- "lf-invalid-handle",
- "lf-no-id-avail",
- "lf-template-area-full",
- "lf-id-in-use",
- "mou-not-initialized",
- "mouinitreal-done",
- "dossub-corrupted",
- "mouse-caller-not-subsys",
- "arithmetic-overflow",
- "tmr-no-device",
- "tmr-invalid-time",
- "pvw-invalid-entity",
- "pvw-invalid-entity-type",
- "pvw-invalid-spec",
- "pvw-invalid-range-type",
- "pvw-invalid-counter-blk",
- "pvw-invalid-text-blk",
- "prf-not-initialized",
- "prf-already-initialized",
- "prf-not-started",
- "prf-already-started",
- "prf-timer-out-of-range",
- "prf-timer-reset",
- "vdd-lock-useage-denied",
- "timeout",
- "vdm-down",
- "vdm-limit",
- "vdd-not-found",
- "invalid-caller",
- "pid-mismatch",
- "invalid-vdd-handle",
- "vlpt-no-spooler",
- "vcom-device-busy",
- "vlpt-device-busy",
- "nesting-too-deep",
- "vdd-missing",
- "bidi-invalid-length",
- "bidi-invalid-increment",
- "bidi-invalid-combination",
- "bidi-invalid-reserved",
- "bidi-invalid-effect",
- "bidi-invalid-csdrec",
- "bidi-invalid-csdstate",
- "bidi-invalid-level",
- "bidi-invalid-type-support",
- "bidi-invalid-orientation",
- "bidi-invalid-num-shape",
- "bidi-invalid-csd",
- "bidi-no-support",
- "bidi-rw-incomplete",
- "imp-invalid-parm",
- "imp-invalid-length",
- "hpfs-disk-error-warn",
- "mon-bad-buffer",
- "module-corrupted",
- "sm-outof-swapfile",
- "lf-timeout",
- "lf-suspend-success",
- "lf-resume-success",
- "lf-redirect-success",
- "lf-redirect-failure",
- "swapper-not-active",
- "invalid-swapid",
- "ioerr-swap-file",
- "swap-table-full",
- "swap-file-full",
- "cant-init-swapper",
- "swapper-already-init",
- "pmm-insufficient-memory",
- "pmm-invalid-flags",
- "pmm-invalid-address",
- "pmm-lock-failed",
- "pmm-unlock-failed",
- "pmm-move-incomplete",
- "ucom-drive-renamed",
- "ucom-filename-truncated",
- "ucom-buffer-length",
- "mon-chain-handle",
- "mon-not-registered",
- "smg-already-top",
- "pmm-arena-modified",
- "smg-printer-open",
- "pmm-set-flags-failed",
- "invalid-dos-dd",
- "blocked",
- "noblock",
- "instance-shared",
- "no-object",
- "partial-attach",
- "incache",
- "swap-io-problems",
- "crosses-object-boundary",
- "longlock",
- "shortlock",
- "uvirtlock",
- "aliaslock",
- "alias",
- "no-more-handles",
- "scan-terminated",
- "terminator-not-found",
- "not-direct-child",
- "delay-free",
- "guardpage",
- "swaperror",
- "ldrerror",
- "nomemory",
- "noaccess",
- "no-dll-term",
- "cpsio-code-page-invalid",
- "cpsio-no-spooler",
- "cpsio-font-id-invalid",
- "cpsio-internal-error",
- "cpsio-invalid-ptr-name",
- "cpsio-not-active",
- "cpsio-pid-full",
- "cpsio-pid-not-found",
- "cpsio-read-ctl-seq",
- "cpsio-read-fnt-def",
- "cpsio-write-error",
- "cpsio-write-full-error",
- "cpsio-write-handle-bad",
- "cpsio-swit-load",
- "cpsio-inv-command",
- "cpsio-no-font-swit",
- "entry-is-callgate",
-
- /* socket errors: */
- "soceperm",
- "socesrch",
- "soceintr",
- "socenxio",
- "socebadf",
- "soceacces",
- "socefault",
- "soceinval",
- "socemfile",
- "socepipe",
- "soceos2err",
- "socewouldblock",
- "soceinprogress",
- "socealready",
- "socenotsock",
- "socedestaddrreq",
- "socemsgsize",
- "soceprototype",
- "socenoprotoopt",
- "soceprotonosupport",
- "socesocktnosupport",
- "soceopnotsupp",
- "socepfnosupport",
- "soceafnosupport",
- "soceaddrinuse",
- "soceaddrnotavail",
- "socenetdown",
- "socenetunreach",
- "socenetreset",
- "soceconnaborted",
- "soceconnreset",
- "socenobufs",
- "soceisconn",
- "socenotconn",
- "soceshutdown",
- "socetoomanyrefs",
- "socetimedout",
- "soceconnrefused",
- "soceloop",
- "socenametoolong",
- "socehostdown",
- "socehostunreach",
- "socenotempty",
-
- "unknown"
-};
-
-void
-OS_syserr_names (unsigned long * length, const char *** names)
-{
- (*length) = ((sizeof (syserr_names_table)) / (sizeof (char *)));
- (*names) = syserr_names_table;
-}
-
-void
-OS_syscall_names (unsigned long * length, const char *** names)
-{
- (*length) = ((sizeof (syscall_names_table)) / (sizeof (char *)));
- (*names) = syscall_names_table;
-}
-\f
-void
-OS_expect_sequential_access (void *start, void *end)
-{
- (void) start; /* ignore */
- (void) end; /* ignore */
-}
-
-void
-OS_expect_normal_access (void *start, void *end)
-{
- (void) start; /* ignore */
- (void) end; /* ignore */
-}
-
-void
-OS_free_pages (void *start, void *end)
-{
- (void) start; /* ignore */
- (void) end; /* ignore */
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#include "os2.h"
-#include "ostty.h"
-#ifdef USE_PMIO
-#include <pmio.h>
-#endif
-\f
-static Tchannel input_channel;
-static Tchannel output_channel;
-
-void
-OS2_initialize_tty (void)
-{
- extern Tchannel OS_open_fd (int fd);
- input_channel = (OS2_make_channel (0, CHANNEL_READ));
- (CHANNEL_INTERNAL (input_channel)) = 1;
- output_channel = (OS2_make_channel (1, CHANNEL_WRITE));
- (CHANNEL_INTERNAL (output_channel)) = 1;
-}
-
-Tchannel
-OS_tty_input_channel (void)
-{
- return (input_channel);
-}
-
-Tchannel
-OS_tty_output_channel (void)
-{
- return (output_channel);
-}
-
-unsigned int
-OS_tty_x_size (void)
-{
-#ifdef USE_PMIO
- return (get_screen_width ());
-#else
- return (80);
-#endif
-}
-
-unsigned int
-OS_tty_y_size (void)
-{
-#ifdef USE_PMIO
- return (get_screen_height ());
-#else
- return (24);
-#endif
-}
-
-const char *
-OS_tty_command_beep (void)
-{
- return ("\a");
-}
-
-const char *
-OS_tty_command_clear (void)
-{
- return ("\f");
-}
+++ /dev/null
-@echo off
-rem Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993,
-rem 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-rem 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013,
-rem 2014, 2015, 2016 Massachusetts Institute of Technology
-rem
-rem This file is part of MIT/GNU Scheme.
-rem
-rem MIT/GNU Scheme is free software; you can redistribute it and/or
-rem modify it under the terms of the GNU General Public License as
-rem published by the Free Software Foundation; either version 2 of the
-rem License, or (at your option) any later version.
-rem
-rem MIT/GNU Scheme is distributed in the hope that it will be useful,
-rem but WITHOUT ANY WARRANTY; without even the implied warranty of
-rem MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-rem General Public License for more details.
-rem
-rem You should have received a copy of the GNU General Public License
-rem along with MIT/GNU Scheme; if not, write to the Free Software
-rem Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
-rem 02110-1301, USA.
-rem
-rem Microcode configuration script for OS/2
-rem
-copy cmpintmd\i386.h cmpintmd.h
-copy cmpauxmd\i386.m4 cmpauxmd.m4
-copy os2utl\makefile .
-copy os2utl\config.h .
-copy cmpauxmd\asmcvt.c .
-echo ***** Read and edit the makefile! *****
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#ifndef SCM_CONFIG_H
-#define SCM_CONFIG_H
-
-#ifndef __OS2__
-# define __OS2__
-#endif
-
-#include <sys/types.h>
-#include <time.h>
-
-#ifndef __GNUC__
- typedef unsigned short mode_t;
- typedef short nlink_t;
- typedef long pid_t;
- typedef short uid_t;
- typedef short gid_t;
-#endif
-
-typedef unsigned char cc_t;
-#if (! ((defined (__IBMC__)) && (__IBMC__ >= 360)))
- typedef long ssize_t;
-#endif
-
-/* The number of bytes in a unsigned long. */
-#define SIZEOF_UNSIGNED_LONG 4
-
-/* Define if your processor stores words with the most significant
- byte first (like Motorola and SPARC, unlike Intel and VAX). */
-/* #undef WORDS_BIGENDIAN */
-
-/* Define if you have the floor function. */
-#define HAVE_FLOOR 1
-
-/* Define if you have the fmod function. */
-#define HAVE_FMOD 1
-
-/* Define if you have the frexp function. */
-#define HAVE_FREXP 1
-
-/* Define if you have the modf function. */
-#define HAVE_MODF 1
-
-/* Define if you have the ANSI C header files. */
-#define STDC_HEADERS 1
-
-/* Define if you have the <unistd.h> header file. */
-/* #undef HAVE_UNISTD_H */
-
-/* Define if you have the <fcntl.h> header file. */
-#define HAVE_FCNTL_H 1
-
-/* Define if you have the <blowfish.h> header file. */
-#define HAVE_BLOWFISH_H 1
-
-/* Define if you have the <md5.h> header file. */
-#define HAVE_MD5_H 1
-
-/* Define to the address where bug reports for this package should be sent. */
-#define PACKAGE_BUGREPORT "bug-mit-scheme@gnu.org"
-
-/* Define to the full name of this package. */
-#define PACKAGE_NAME "MIT/GNU Scheme microcode"
-
-/* Define to the version of this package. */
-#define PACKAGE_VERSION "15.1"
-
-/* Define to the full name and version of this package. */
-#define PACKAGE_STRING PACKAGE_NAME PACKAGE_VERSION
-
-/* Define to the one symbol short name of this package. */
-#define PACKAGE_TARNAME "mit-scheme"
-
-/* Include the shared configuration header. */
-#include "confshared.h"
-
-#endif /* SCM_CONFIG_H */
+++ /dev/null
-### -*- Fundamental -*-
-###
-### Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993,
-### 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-### 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013,
-### 2014, 2015, 2016 Massachusetts Institute of Technology
-###
-### This file is part of MIT/GNU Scheme.
-###
-### MIT/GNU Scheme is free software; you can redistribute it and/or
-### modify it under the terms of the GNU General Public License as
-### published by the Free Software Foundation; either version 2 of the
-### License, or (at your option) any later version.
-###
-### MIT/GNU Scheme is distributed in the hope that it will be useful,
-### but WITHOUT ANY WARRANTY; without even the implied warranty of
-### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-### General Public License for more details.
-###
-### You should have received a copy of the GNU General Public License
-### along with MIT/GNU Scheme; if not, write to the Free Software
-### Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
-### 02110-1301, USA.
-###
-
-#### Makefile for Scheme under OS/2
-
-all: scheme.exe bchschem.exe
-
-# Uncomment exactly one of the following two lines:
-#debug_mode = debug
-debug_mode = optimize
-
-# Uncomment exactly one of the following include statements to
-# customize this makefile for your compiler. All of the
-# configurations require both GNU make and GNU m4.
-
-# IBM C Set++/2 or IBM Visual Age C++:
-include os2utl\makefile.vac
-
-# Watcom C/C++:
-#include os2utl\makefile.wcc
-
-# EMX/GCC:
-#include os2utl\makefile.emx
-
-# GCC/2 (this has not been tried in a long time):
-#include os2utl\makefile.gcc
+++ /dev/null
-### -*- Fundamental -*-
-###
-### Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993,
-### 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-### 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013,
-### 2014, 2015, 2016 Massachusetts Institute of Technology
-###
-### This file is part of MIT/GNU Scheme.
-###
-### MIT/GNU Scheme is free software; you can redistribute it and/or
-### modify it under the terms of the GNU General Public License as
-### published by the Free Software Foundation; either version 2 of the
-### License, or (at your option) any later version.
-###
-### MIT/GNU Scheme is distributed in the hope that it will be useful,
-### but WITHOUT ANY WARRANTY; without even the implied warranty of
-### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-### General Public License for more details.
-###
-### You should have received a copy of the GNU General Public License
-### along with MIT/GNU Scheme; if not, write to the Free Software
-### Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
-### 02110-1301, USA.
-###
-
-#### Makefile for Scheme under OS/2 -- Common Part
-\f
-SCHEME_LIB = so32dll.lib tcp32dll.lib gdbm.lib md5.lib blowfish.lib
-
-CORE_SOURCES = \
-artutl.c \
-avltree.c \
-bignum.c \
-bigprm.c \
-bitstr.c \
-boot.c \
-char.c \
-cmpauxmd.m4 \
-cmpint.c \
-comutl.c \
-daemon.c \
-debug.c \
-dfloat.c \
-error.c \
-extern.c \
-fasload.c \
-fixnum.c \
-flonum.c \
-generic.c \
-hooks.c \
-hunk.c \
-intern.c \
-interp.c \
-intprm.c \
-list.c \
-lookprm.c \
-lookup.c \
-missing.c \
-obstack.c \
-option.c \
-osscheme.c \
-ostty.c \
-outf.c \
-prim.c \
-primutl.c \
-prmcon.c \
-ptrvec.c \
-purutl.c \
-regex.c \
-rgxprim.c \
-step.c \
-storage.c \
-string.c \
-syntax.c \
-sysprim.c \
-term.c \
-transact.c \
-utils.c \
-vector.c \
-wind.c
-
-CORE_OBJECTS = \
-artutl.$(OBJ) \
-avltree.$(OBJ) \
-bignum.$(OBJ) \
-bigprm.$(OBJ) \
-bitstr.$(OBJ) \
-boot.$(OBJ) \
-char.$(OBJ) \
-cmpauxmd.$(OBJ) \
-cmpint.$(OBJ) \
-comutl.$(OBJ) \
-daemon.$(OBJ) \
-debug.$(OBJ) \
-dfloat.$(OBJ) \
-error.$(OBJ) \
-extern.$(OBJ) \
-fasload.$(OBJ) \
-fixnum.$(OBJ) \
-flonum.$(OBJ) \
-generic.$(OBJ) \
-hooks.$(OBJ) \
-hunk.$(OBJ) \
-intern.$(OBJ) \
-interp.$(OBJ) \
-intprm.$(OBJ) \
-list.$(OBJ) \
-lookprm.$(OBJ) \
-lookup.$(OBJ) \
-missing.$(OBJ) \
-obstack.$(OBJ) \
-option.$(OBJ) \
-osscheme.$(OBJ) \
-ostty.$(OBJ) \
-outf.$(OBJ) \
-prim.$(OBJ) \
-primutl.$(OBJ) \
-prmcon.$(OBJ) \
-ptrvec.$(OBJ) \
-purutl.$(OBJ) \
-regex.$(OBJ) \
-rgxprim.$(OBJ) \
-step.$(OBJ) \
-storage.$(OBJ) \
-string.$(OBJ) \
-syntax.$(OBJ) \
-sysprim.$(OBJ) \
-term.$(OBJ) \
-transact.$(OBJ) \
-utils.$(OBJ) \
-vector.$(OBJ) \
-wind.$(OBJ)
-
-STD_GC_SOURCES = \
-fasdump.c \
-gcloop.c \
-memmag.c \
-purify.c \
-wabbit.c
-
-STD_GC_OBJECTS = \
-fasdump.$(OBJ) \
-gcloop.$(OBJ) \
-memmag.$(OBJ) \
-purify.$(OBJ) \
-wabbit.$(OBJ)
-
-BCH_GC_SOURCES = \
-bchdmp.c \
-bchgcl.c \
-bchmmg.c \
-bchpur.c \
-bchutl.c
-
-BCH_GC_OBJECTS = \
-bchdmp.$(OBJ) \
-bchgcl.$(OBJ) \
-bchmmg.$(OBJ) \
-bchpur.$(OBJ) \
-bchutl.$(OBJ)
-
-OS_PRIM_SOURCES = \
-prbfish.c \
-prgdbm.c \
-prmd5.c \
-prosenv.c \
-prosfile.c \
-prosfs.c \
-prosio.c \
-prosproc.c \
-pruxsock.c \
-prosterm.c \
-prostty.c \
-pros2fs.c \
-pros2io.c \
-pros2pm.c
-
-OS_PRIM_OBJECTS = \
-prbfish.$(OBJ) \
-prgdbm.$(OBJ) \
-prmd5.$(OBJ) \
-prosenv.$(OBJ) \
-prosfile.$(OBJ) \
-prosfs.$(OBJ) \
-prosio.$(OBJ) \
-prosproc.$(OBJ) \
-pruxsock.$(OBJ) \
-prosterm.$(OBJ) \
-prostty.$(OBJ) \
-pros2fs.$(OBJ) \
-pros2io.$(OBJ) \
-pros2pm.$(OBJ)
-
-OS2_SOURCES = \
-os2.c \
-os2conio.c \
-os2cthrd.c \
-os2ctty.c \
-os2env.c \
-os2file.c \
-os2fs.c \
-os2io.c \
-os2msg.c \
-os2pipe.c \
-os2pm.c \
-os2pmcon.c \
-os2proc.c \
-os2sock.c \
-os2term.c \
-os2thrd.c \
-os2top.c \
-os2tty.c \
-os2xcpt.c
-
-OS2_OBJECTS = \
-os2.$(OBJ) \
-os2conio.$(OBJ) \
-os2cthrd.$(OBJ) \
-os2ctty.$(OBJ) \
-os2env.$(OBJ) \
-os2file.$(OBJ) \
-os2fs.$(OBJ) \
-os2io.$(OBJ) \
-os2msg.$(OBJ) \
-os2pipe.$(OBJ) \
-os2pm.$(OBJ) \
-os2pmcon.$(OBJ) \
-os2proc.$(OBJ) \
-os2sock.$(OBJ) \
-os2term.$(OBJ) \
-os2thrd.$(OBJ) \
-os2top.$(OBJ) \
-os2tty.$(OBJ) \
-os2xcpt.$(OBJ)
-
-SHARED_SOURCES = $(CORE_SOURCES) $(OS_PRIM_SOURCES) $(OS2_SOURCES)
-SHARED_OBJECTS = $(CORE_OBJECTS) $(OS_PRIM_OBJECTS) $(OS2_OBJECTS)
-
-SOURCES = $(SHARED_SOURCES) $(STD_GC_SOURCES)
-OBJECTS = $(SHARED_OBJECTS) $(STD_GC_OBJECTS) usrdef.$(OBJ)
-
-BCHSOURCES = $(SHARED_SOURCES) $(BCH_GC_SOURCES)
-BCHOBJECTS = $(SHARED_OBJECTS) $(BCH_GC_OBJECTS) bchdef.$(OBJ)
-
-usrdef.c: $(SOURCES) findprim.exe
- .\findprim $(SOURCES) > usrdef.c
-
-bchdef.c: $(BCHSOURCES) findprim.exe
- .\findprim $(BCHSOURCES) > bchdef.c
-
-scheme.res: os2pmcon.rc os2pmcon.h
- rc -r -DSCHEME os2pmcon.rc scheme.res
-
-bchschem.res: os2pmcon.rc os2pmcon.h
- rc -r -DBCHSCHEM os2pmcon.rc bchschem.res
-
-findprim.exe: findprim.$(OBJ)
-asmcvt.exe: asmcvt.$(OBJ)
-bintopsb.exe: bintopsb.$(OBJ) missing.$(OBJ)
-psbtobin.exe: psbtobin.$(OBJ) missing.$(OBJ)
-breakup.exe: breakup.$(OBJ)
-wsize.exe: wsize.$(OBJ)
-ppband.exe: ppband.$(OBJ)
-
-os2pm-dc.h os2pm-ed.h os2pm-id.h os2pm-mi.h os2pm-mt.h os2pm-rp.h: os2pm.scm
- scheme -large < os2utl/mkos2pm.scm
-
-clean:
- -del *.$(OBJ)
- -del *.exe
- -del *.res
- -del *.err
- -del *.sym
- -del cmpauxmd.$(ASM)
- -del usrdef.c
- -del bchdef.c
-
-#
-# Dependencies. (This was a lot of work!)
-#
-# This first section defines the dependencies of the include files.
-#
-AVLTREE_H = avltree.h $(CONFIG_H)
-BCHDRN_H = bchdrn.h $(CONFIG_H)
-BCHGCC_H = bchgcc.h $(CONFIG_H) $(GCCODE_H)
-BIGNMINT_H = bignmint.h $(PRIMS_H)
-BIGNUM_H = bignum.h ansidecl.h
-BITSTR_H = bitstr.h
-BKPT_H = bkpt.h
-CMPGC_H = cmpgc.h $(CMPINTMD_H)
-CMPINTMD_H = cmpintmd.h $(CMPTYPE_H)
-CMPINT_H = cmpint.h
-CMPTYPE_H = cmptype.h
-COMLIN_H = comlin.h ansidecl.h
-CONFIG_H = config.h confshared.h ansidecl.h
-CONST_H = const.h
-CRITSEC_H = critsec.h
-DEFAULT_H = default.h
-DSTACK_H = dstack.h ansidecl.h
-DUMP_C = dump.c
-EDWIN_H = edwin.h
-ERRORS_H = errors.h
-EXTERN_H = extern.h
-FASL_H = fasl.h
-FIXOBJ_H = fixobj.h
-FLOAT_H =
-FUTURES_H = futures.h
-GCCODE_H = gccode.h $(CMPGC_H)
-GCTYPE_C = gctype.c $(CONFIG_H)
-GC_H = gc.h
-HISTORY_H = history.h
-INTERP_H = interp.h
-INTEXT_H = intext.h ansidecl.h $(DSTACK_H)
-INTRPT_H = intrpt.h
-LIMITS_H =
-LOAD_C = load.c $(FASL_H)
-LOCKS_H = locks.h
-LOOKUP_H = lookup.h
-MEMMAG_H = memmag.h
-MUL_C = mul.c $(CONFIG_H)
-OBJECT_H = object.h
-OBSTACK_H = obstack.h $(CONFIG_H)
-OPTION_H = option.h ansidecl.h
-OS2API_H = os2api.h
-OS2CTHRD_H = os2cthrd.h
-OS2CTTY_H = os2ctty.h
-OS2IO_H = os2io.h $(OSIO_H)
-OS2MSG_H = os2msg.h os2pm-mt.h
-OS2PM_H = os2pm.h os2pm-ed.h
-OS2PMCON_H = os2pmcon.h
-OS2PROC_H = os2proc.h $(OSPROC_H)
-OS2THRD_H = os2thrd.h
-OSCTTY_H = osctty.h $(OS_H)
-OSENV_H = osenv.h $(OS_H)
-OSFILE_H = osfile.h $(OS_H)
-OSFS_H = osfs.h $(OS_H)
-OSIO_H = osio.h $(OS_H)
-OSSCHEME_H = osscheme.h $(OUTF_H) $(OS_H)
-OSSIG_H = ossig.h $(OS_H)
-OSTERM_H = osterm.h $(OS_H)
-OSTOP_H = ostop.h $(OS_H)
-OSTTY_H = ostty.h $(OS_H)
-OS_H = os.h $(CONFIG_H)
-OUTF_H = outf.h $(CONFIG_H)
-PRENAME_H = prename.h
-PRIMS_H = prims.h ansidecl.h
-PRIM_H = prim.h
-PRMCON_H = prmcon.h
-REGEX_H = regex.h
-RETURNS_H = returns.h
-SCODE_H = scode.h
-SDATA_H = sdata.h
-STACK_H = stack.h
-SYNTAX_H = syntax.h
-SYSCALL_H = syscall.h $(CONFIG_H) $(OS2API_H)
-TRAP_H = trap.h
-TYPES_H = types.h
-USRDEF_H = usrdef.h $(SCHEME_H) $(PRIMS_H)
-UXSOCK_H = uxsock.h $(OSIO_H)
-ZONES_H = zones.h
-
-PSBMAP_H = psbmap.h $(CONFIG_H) $(TYPES_H) $(OBJECT_H) $(BIGNUM_H) \
- $(BIGNMINT_H) $(SDATA_H) $(CONST_H) $(GCCODE_H) $(CMPTYPE_H) \
- $(COMLIN_H)
-
-OS2_H = os2.h $(CONFIG_H) $(DSTACK_H) $(OSSCHEME_H) $(SYSCALL_H) $(OS2API_H) \
- $(OS2MSG_H) $(OS2IO_H) $(OS2THRD_H) $(OS2CTTY_H) $(OS2CTHRD_H) \
- $(OS2PM_H)
-
-SCHEME_H = scheme.h $(CONFIG_H) $(DSTACK_H) $(OBSTACK_H) $(TYPES_H) \
- $(CONST_H) $(OBJECT_H) $(INTRPT_H) $(CRITSEC_H) $(GC_H) $(SCODE_H) \
- $(SDATA_H) $(FUTURES_H) $(ERRORS_H) $(RETURNS_H) $(FIXOBJ_H) \
- $(STACK_H) $(INTERP_H) $(OUTF_H) $(BKPT_H) $(DEFAULT_H) $(EXTERN_H) \
- $(BIGNUM_H) $(PRIM_H) $(FLOAT_H)
-
-#
-# This second section is the dependencies of the object files.
-#
-artutl.$(OBJ): artutl.c $(SCHEME_H) $(LIMITS_H)
-avltree.$(OBJ): avltree.c $(AVLTREE_H)
-bignum.$(OBJ): bignum.c $(SCHEME_H) $(BIGNMINT_H) $(LIMITS_H)
-bigprm.$(OBJ): bigprm.c $(SCHEME_H) $(PRIMS_H) $(ZONES_H)
-bitstr.$(OBJ): bitstr.c $(SCHEME_H) $(PRIMS_H) $(BITSTR_H)
-boot.$(OBJ): boot.c $(SCHEME_H) $(PRIMS_H) $(OPTION_H) $(OSTOP_H) $(OSTTY_H)
-char.$(OBJ): char.c $(SCHEME_H) $(PRIMS_H)
-cmpauxmd.$(OBJ): cmpauxmd.$(ASM)
-cmpauxmd.$(ASM): cmpauxmd.m4
-cmpint.$(OBJ): cmpint.c $(CONFIG_H) $(DSTACK_H) $(OUTF_H) $(TYPES_H) \
- $(CONST_H) $(OBJECT_H) $(INTRPT_H) $(GC_H) $(SDATA_H) $(ERRORS_H) \
- $(RETURNS_H) $(FIXOBJ_H) $(STACK_H) $(INTERP_H) $(DEFAULT_H) \
- $(EXTERN_H) $(TRAP_H) $(PRIMS_H) $(PRIM_H) $(CMPGC_H)
-comutl.$(OBJ): comutl.c $(SCHEME_H) $(PRIMS_H)
-daemon.$(OBJ): daemon.c $(SCHEME_H) $(PRIMS_H) $(OSIO_H)
-debug.$(OBJ): debug.c $(SCHEME_H) $(PRIMS_H) $(TRAP_H) $(LOOKUP_H)
-dfloat.$(OBJ): dfloat.c $(SCHEME_H) $(PRIMS_H)
-error.$(OBJ): error.c $(OUTF_H) $(DSTACK_H)
-extern.$(OBJ): extern.c $(SCHEME_H) $(PRIMS_H)
-fasload.$(OBJ): fasload.c $(SCHEME_H) $(PRIMS_H) $(OSSCHEME_H) $(OSFILE_H) \
- $(OSIO_H) $(GCCODE_H) $(TRAP_H) $(OPTION_H) $(PRMCON_H)
-fixnum.$(OBJ): fixnum.c $(SCHEME_H) $(PRIMS_H) $(MUL_C)
-flonum.$(OBJ): flonum.c $(SCHEME_H) $(PRIMS_H) $(ZONES_H)
-generic.$(OBJ): generic.c $(SCHEME_H) $(PRIMS_H)
-hooks.$(OBJ): hooks.c $(SCHEME_H) $(PRIMS_H) $(HISTORY_H)
-hunk.$(OBJ): hunk.c $(SCHEME_H) $(PRIMS_H)
-intern.$(OBJ): intern.c $(SCHEME_H) $(PRIMS_H) $(TRAP_H)
-interp.$(OBJ): interp.c $(SCHEME_H) $(LOCKS_H) $(TRAP_H) $(LOOKUP_H) \
- $(HISTORY_H) $(CMPINT_H) $(ZONES_H) $(PRMCON_H)
-intprm.$(OBJ): intprm.c $(SCHEME_H) $(PRIMS_H) $(ZONES_H)
-list.$(OBJ): list.c $(SCHEME_H) $(PRIMS_H)
-lookprm.$(OBJ): lookprm.c $(SCHEME_H) $(PRIMS_H) $(LOCKS_H) $(TRAP_H) \
- $(LOOKUP_H)
-lookup.$(OBJ): lookup.c $(SCHEME_H) $(LOCKS_H) $(TRAP_H) $(LOOKUP_H)
-obstack.$(OBJ): obstack.c $(OBSTACK_H)
-option.$(OBJ): option.c $(SCHEME_H) $(FASL_H) $(OSENV_H) $(OSFS_H)
-osscheme.$(OBJ): osscheme.c $(SCHEME_H) $(PRIMS_H) $(OSSCHEME_H)
-ostty.$(OBJ): ostty.c $(OSTTY_H) $(OSSCHEME_H)
-outf.$(OBJ): outf.c $(SCHEME_H)
-prim.$(OBJ): prim.c $(SCHEME_H) $(PRIMS_H)
-primutl.$(OBJ): primutl.c $(SCHEME_H) $(PRIMS_H) $(OS_H) $(USRDEF_H) \
- $(PRENAME_H) $(SYSCALL_H) $(AVLTREE_H) $(CMPGC_H)
-prmcon.$(OBJ): prmcon.c $(SCHEME_H) $(PRIMS_H) $(PRMCON_H)
-ptrvec.$(OBJ): ptrvec.c $(OUTF_H) $(DSTACK_H)
-purutl.$(OBJ): purutl.c $(SCHEME_H) $(PRIMS_H) $(GCCODE_H) $(ZONES_H) \
- $(CMPINT_H)
-regex.$(OBJ): regex.c $(SCHEME_H) $(SYNTAX_H) $(REGEX_H)
-rgxprim.$(OBJ): rgxprim.c $(SCHEME_H) $(PRIMS_H) $(EDWIN_H) $(SYNTAX_H) \
- $(REGEX_H)
-step.$(OBJ): step.c $(SCHEME_H) $(PRIMS_H)
-storage.$(OBJ): storage.c $(SCHEME_H) $(GCTYPE_H)
-string.$(OBJ): string.c $(SCHEME_H) $(PRIMS_H)
-syntax.$(OBJ): syntax.c $(SCHEME_H) $(PRIMS_H) $(EDWIN_H) $(SYNTAX_H)
-sysprim.$(OBJ): sysprim.c $(SCHEME_H) $(PRIMS_H) $(OSTTY_H) $(OSTOP_H)
-term.$(OBJ): term.c $(SCHEME_H) $(OSTOP_H) $(OSIO_H) $(OSFS_H) $(OSFILE_H) \
- $(EDWIN_H)
-tparam.$(OBJ): tparam.c ansidecl.h
-transact.$(OBJ): transact.c $(CONFIG_H) $(OUTF_H) $(DSTACK_H)
-utils.$(OBJ): utils.c $(SCHEME_H) $(PRIMS_H) $(HISTORY_H) \
- $(CMPINT_H) $(SYSCALL_H)
-vector.$(OBJ): vector.c $(SCHEME_H) $(PRIMS_H)
-wind.$(OBJ): wind.c $(OBSTACK_H) $(DSTACK_H) $(OUTF_H)
-
-prbfish.$(OBJ): prbfish.c $(SCHEME_H) $(PRIMS_H)
-prgdbm.$(OBJ): prgdbm.c $(SCHEME_H) $(PRIMS_H) $(OS_H)
-prmd5.$(OBJ): prmd5.c $(SCHEME_H) $(PRIMS_H)
-prpgsql.$(OBJ): prpgsql.c $(SCHEME_H) $(PRIMS_H) $(USRDEF_H) $(OS_H)
-prosenv.$(OBJ): prosenv.c $(SCHEME_H) $(PRIMS_H) $(OSENV_H) $(OSTOP_H) \
- $(LIMITS_H)
-prosfile.$(OBJ): prosfile.c $(SCHEME_H) $(PRIMS_H) $(OSFILE_H)
-prosfs.$(OBJ): prosfs.c $(SCHEME_H) $(PRIMS_H) $(OSFILE_H) $(OSFS_H) $(OSIO_H)
-prosio.$(OBJ): prosio.c $(SCHEME_H) $(PRIMS_H) $(OSIO_H)
-prosproc.$(OBJ): prosproc.c $(SCHEME_H) $(PRIMS_H) $(OSPROC_H) $(OSIO_H)
-prosterm.$(OBJ): prosterm.c $(SCHEME_H) $(PRIMS_H) $(OSTERM_H) $(OSIO_H)
-prostty.$(OBJ): prostty.c $(SCHEME_H) $(PRIMS_H) $(OSTTY_H) $(OSCTTY_H) \
- $(OSFILE_H) $(OSIO_H)
-pruxsock.$(OBJ): pruxsock.c $(SCHEME_H) $(PRIMS_H) $(UXSOCK_H)
-pros2fs.$(OBJ): pros2fs.c $(SCHEME_H) $(PRIMS_H) $(OS2_H) $(OSFS_H)
-pros2io.$(OBJ): pros2io.c $(SCHEME_H) $(PRIMS_H) $(OS2_H) $(OS2PROC_H)
-pros2pm.$(OBJ): pros2pm.c $(SCHEME_H) $(PRIMS_H) $(OS2_H)
-
-fasdump.$(OBJ): fasdump.c $(SCHEME_H) $(PRIMS_H) $(OSSCHEME_H) $(OSIO_H) \
- $(OSFILE_H) $(OSFS_H) $(GCCODE_H) $(TRAP_H) $(LOOKUP_H) $(FASL_H) \
- $(DUMP_C)
-gcloop.$(OBJ): gcloop.c $(SCHEME_H) $(GCCODE_H)
-memmag.$(OBJ): memmag.c $(SCHEME_H) $(PRIMS_H) $(MEMMAG_H) $(GCCODE_H)
-purify.$(OBJ): purify.c $(SCHEME_H) $(PRIMS_H) $(GCCODE_H) $(ZONES_H)
-wabbit.$(OBJ): wabbit.c $(SCHEME_H) $(GCCODE_H)
-
-bchdmp.$(OBJ): bchdmp.c $(SCHEME_H) $(PRIMS_H) $(OSFILE_H) $(OSFS_H) \
- $(TRAP_H) $(LOOKUP_H) $(FASL_H) $(OS2_H) $(BCHGCC_H) $(DUMP_C)
-bchgcl.$(OBJ): bchgcl.c $(SCHEME_H) $(BCHGCC_H)
-bchmmg.$(OBJ): bchmmg.c $(SCHEME_H) $(PRIMS_H) $(MEMMAG_H) $(OPTION_H) \
- $(OSENV_H) $(OSFS_H) $(OS2_H) $(BCHGCC_H) $(BCHDRN_H)
-bchpur.$(OBJ): bchpur.c $(SCHEME_H) $(PRIMS_H) $(BCHGCC_H) $(ZONES_H)
-bchutl.$(OBJ): bchutl.c $(CONFIG_H)
-
-os2.$(OBJ): os2.c $(OS2_H)
-os2conio.$(OBJ): os2conio.c $(OS2_H)
-os2cthrd.$(OBJ): os2cthrd.c $(OS2_H)
-os2ctty.$(OBJ): os2ctty.c $(OS2_H) $(OSCTTY_H) $(OSSIG_H)
-os2env.$(OBJ): os2env.c $(SCHEME_H) $(OS2_H) $(OSENV_H)
-os2file.$(OBJ): os2file.c $(OS2_H) $(OSFILE_H)
-os2fs.$(OBJ): os2fs.c $(OS2_H) $(OSFS_H)
-os2io.$(OBJ): os2io.c $(OS2_H)
-os2msg.$(OBJ): os2msg.c $(OS2_H)
-os2pipe.$(OBJ): os2pipe.c $(OS2_H)
-os2pm.$(OBJ): os2pm.c $(OS2_H) os2pm-id.h os2pm-mi.h os2pm-dc.h os2pm-rp.h
-os2pmcon.$(OBJ): os2pmcon.c $(OS2_H) $(OS2PMCON_H)
-os2proc.$(OBJ): os2proc.c $(OS2_H) $(OSPROC_H) $(OSENV_H)
-os2sock.$(OBJ): os2sock.c $(SCHEME_H) $(PRIMS_H) $(OSSCHEME_H) $(OS2_H) \
- $(UXSOCK_H)
-os2term.$(OBJ): os2term.c $(OS2_H) $(PRIMS_H)
-os2thrd.$(OBJ): os2thrd.c $(OS2_H) $(PRIMS_H) $(ERRORS_H)
-os2top.$(OBJ): os2top.c $(SCHEME_H) $(OS2_H) $(OSTOP_H) $(OPTION_H)
-os2tty.$(OBJ): os2tty.c $(OS2_H) $(OSTTY_H)
-os2xcpt.$(OBJ): os2xcpt.c $(SCHEME_H) $(GCCODE_H) $(OS2_H)
-
-missing.$(OBJ): missing.c $(CONFIG_H)
-
-findprim.$(OBJ): findprim.c $(CONFIG_H)
-
-bintopsb.$(OBJ): bintopsb.c $(PSBMAP_H) $(LIMITS_H) $(LOAD_C) $(BLTDEF_H) \
- $(TRAP_H)
-psbtobin.$(OBJ): psbtobin.c $(PSBMAP_H) $(FLOAT_H) $(LIMITS_H) $(FASL_H) \
- $(DUMP_C)
+++ /dev/null
-### -*- Fundamental -*-
-###
-### Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993,
-### 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-### 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013,
-### 2014, 2015, 2016 Massachusetts Institute of Technology
-###
-### This file is part of MIT/GNU Scheme.
-###
-### MIT/GNU Scheme is free software; you can redistribute it and/or
-### modify it under the terms of the GNU General Public License as
-### published by the Free Software Foundation; either version 2 of the
-### License, or (at your option) any later version.
-###
-### MIT/GNU Scheme is distributed in the hope that it will be useful,
-### but WITHOUT ANY WARRANTY; without even the implied warranty of
-### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-### General Public License for more details.
-###
-### You should have received a copy of the GNU General Public License
-### along with MIT/GNU Scheme; if not, write to the Free Software
-### Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
-### 02110-1301, USA.
-###
-
-#### Makefile for Scheme under OS/2 using EMX/GCC
-\f
-# This makefile is configured for use with GNU make, the EMX/GCC
-# development system (compiler, assembler, linker, etc.), the GNU m4
-# macro preprocessor, and the RC program included with the IBM OS/2
-# Toolkit.
-
-GCCFLAGS := -Zmt -O
-ifeq ($(debug_mode),debug)
-GCCFLAGS := $(GCCFLAGS) -g
-endif
-
-OBJ = o
-ASM = s
-CC = gcc
-CFLAGS = $(GCCFLAGS) -DMIT_SCHEME -D__OS2__
-LDFLAGS = $(GCCFLAGS)
-M4 = m4
-M4FLAGS = -DTYPE_CODE_LENGTH=6
-AS = as
-ASFLAGS =
-
-%.o : %.c
- $(CC) $(CFLAGS) -c $< -o $@
-
-%.s : %.m4
- $(M4) $(M4FLAGS) < $< > $@
-
-%.o : %.s
- $(AS) $(ASFLAGS) -o $@ $<
-
-%.exe :
- $(CC) $(LDFLAGS) -o $(basename $@) $^
- emxbind -b -q $(basename $@)
- del $(basename $@)
-
-include os2utl\makefile.cmn
-
-scheme.exe : $(OBJECTS) scheme.res
- $(CC) $(LDFLAGS) -o $(basename $@) $(OBJECTS) $(SCHEME_LIB)
- emxbind -b -p -q -r$(basename $@).res $(basename $@)
- del $(basename $@)
-
-bchschem.exe : $(BCHOBJECTS) bchschem.res
- $(CC) $(LDFLAGS) -o $(basename $@) $(BCHOBJECTS) $(SCHEME_LIB)
- emxbind -b -p -q -r$(basename $@).res $(basename $@)
- del $(basename $@)
+++ /dev/null
-### -*- Fundamental -*-
-###
-### Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993,
-### 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-### 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013,
-### 2014, 2015, 2016 Massachusetts Institute of Technology
-###
-### This file is part of MIT/GNU Scheme.
-###
-### MIT/GNU Scheme is free software; you can redistribute it and/or
-### modify it under the terms of the GNU General Public License as
-### published by the Free Software Foundation; either version 2 of the
-### License, or (at your option) any later version.
-###
-### MIT/GNU Scheme is distributed in the hope that it will be useful,
-### but WITHOUT ANY WARRANTY; without even the implied warranty of
-### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-### General Public License for more details.
-###
-### You should have received a copy of the GNU General Public License
-### along with MIT/GNU Scheme; if not, write to the Free Software
-### Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
-### 02110-1301, USA.
-###
-
-#### Makefile for Scheme under OS/2 using GCC/2
-\f
-# This makefile is configured for use with GNU make, the GCC/2
-# development system (compiler, assembler, linker, etc.), and the GNU
-# m4 macro preprocessor.
-
-GCCFLAGS := -O
-ifeq ($(debug_mode),debug)
-GCCFLAGS := $(GCCFLAGS) -g
-endif
-
-OBJ = obj
-ASM = asm
-CC = gcc -Uunix -U__unix__ -U__unix -D__GCC2__
-CFLAGS = $(GCCFLAGS) -DMIT_SCHEME
-LDFLAGS = $(GCCFLAGS)
-M4 = m4
-M4FLAGS = -DSUPPRESS_LEADING_UNDERSCORE
-AS = as
-ASFLAGS = -I
-
-%.o : %.c
- $(CC) $(CFLAGS) -c $< -o $@
-
-%.s : %.m4
- $(M4) $(M4FLAGS) < $< > $@
-
-%.o : %.s
- $(AS) $(ASFLAGS) -o $@ $<
-
-%.exe :
- $(CC) $(LDFLAGS) -o $@ $^
-
-include os2utl\makefile.cmn
-
-scheme.exe : $(OBJECTS) scheme.res
- $(CC) $(LDFLAGS) -o $@ $^ $(SCHEME_LIB)
- rc scheme.res $@
-
-bchschem.exe : $(BCHOBJECTS) bchschem.res
- $(CC) $(LDFLAGS) -o $@ $^ $(SCHEME_LIB)
- rc bchschem.res $@
+++ /dev/null
-### -*- Fundamental -*-
-###
-### Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993,
-### 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-### 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013,
-### 2014, 2015, 2016 Massachusetts Institute of Technology
-###
-### This file is part of MIT/GNU Scheme.
-###
-### MIT/GNU Scheme is free software; you can redistribute it and/or
-### modify it under the terms of the GNU General Public License as
-### published by the Free Software Foundation; either version 2 of the
-### License, or (at your option) any later version.
-###
-### MIT/GNU Scheme is distributed in the hope that it will be useful,
-### but WITHOUT ANY WARRANTY; without even the implied warranty of
-### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-### General Public License for more details.
-###
-### You should have received a copy of the GNU General Public License
-### along with MIT/GNU Scheme; if not, write to the Free Software
-### Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
-### 02110-1301, USA.
-###
-
-#### Makefile for Scheme under OS/2 using IBM Visual Age C++
-\f
-# This makefile is configured for use with GNU make, the IBM Visual
-# Age C++ compiler (or IBM C Set++/2), GNU m4, the GNU assembler
-# included with the EMX/GCC package, and the RC program included with
-# the IBM OS/2 Toolkit.
-
-ICCFLAGS := /Gm+ /Q+ /W2 /Wall+
-ifeq ($(debug_mode),debug)
-ICCFLAGS := $(ICCFLAGS) /Ti+
-else
-ifeq ($(debug_mode),optimize)
-ICCFLAGS := $(ICCFLAGS) /O+
-endif
-endif
-
-OBJ = obj
-ASM = asm
-CC = icc
-CFLAGS = $(ICCFLAGS) /DMIT_SCHEME
-LDFLAGS = $(ICCFLAGS) /B"/EXEPACK"
-M4 = m4
-M4FLAGS = -DSUPPRESS_LEADING_UNDERSCORE
-AS = as
-ASFLAGS = -Zomf
-
-%.obj : %.c
- $(CC) $(CFLAGS) /C $<
-
-%.asm : %.m4
- $(M4) $(M4FLAGS) < $< > $@
-
-%.obj : %.asm
- $(AS) $(ASFLAGS) -o $@ $<
-
-%.exe :
- $(CC) $(LDFLAGS) /Fe$@ $^
-
-include os2utl\makefile.cmn
-
-scheme.exe : $(OBJECTS) scheme.res
- $(CC) $(LDFLAGS) /B"/PMTYPE:PM" /Fe$@ $(OBJECTS) $(SCHEME_LIB)
- rc scheme.res $@
-
-bchschem.exe : $(BCHOBJECTS) bchschem.res
- $(CC) $(LDFLAGS) /B"/PMTYPE:PM" /Fe$@ $(BCHOBJECTS) $(SCHEME_LIB)
- rc bchschem.res $@
+++ /dev/null
-### -*- Fundamental -*-
-###
-### Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993,
-### 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-### 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013,
-### 2014, 2015, 2016 Massachusetts Institute of Technology
-###
-### This file is part of MIT/GNU Scheme.
-###
-### MIT/GNU Scheme is free software; you can redistribute it and/or
-### modify it under the terms of the GNU General Public License as
-### published by the Free Software Foundation; either version 2 of the
-### License, or (at your option) any later version.
-###
-### MIT/GNU Scheme is distributed in the hope that it will be useful,
-### but WITHOUT ANY WARRANTY; without even the implied warranty of
-### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-### General Public License for more details.
-###
-### You should have received a copy of the GNU General Public License
-### along with MIT/GNU Scheme; if not, write to the Free Software
-### Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
-### 02110-1301, USA.
-###
-
-#### Makefile for Scheme under OS/2 using Watcom C/C++
-\f
-# This makefile is configured for use with GNU make, the Watcom C
-# compiler, GNU m4, the Watcom assembler, and the RC program included
-# with the IBM OS/2 Toolkit.
-
-OBJ = obj
-ASM = asm
-CC = wcc386
-M4 = m4
-AS = wasm
-
-# Compiler options.
-# [DEBUG] marks options used for debugging.
-# [OPTIMIZE] marks options used for optimization.
-#
-# /4r 386 instructions, 486 timings, register-based args
-# /bm build multi-thread binary
-# /bt=os2 build OS/2 binary (default)
-# /d1+ generate debug info [OPTIMIZE]
-# /d2 generate debug info [DEBUG]
-# /fpi generate in-line 387 insns, emulate if none (default)
-# /fp3 generate in-line 387 insns (default)
-# /hw generate Watcom debug info (default)
-# /mf use flat memory model (default)
-# /od disable optimization (default with /d2)
-# /oe enable in-line user-code expansion [OPTIMIZE]
-# /ox enable various optimizations [OPTIMIZE]
-# /s remove stack overflow checks
-# /sg generate calls to grow stack
-# /w0 disable warning messages
-# /zc place literal strings in code segment
-# /ze enable language extensions (default)
-# /zp4 use 4-byte alignment
-# /zq operate quietly
-CFLAGS := /4r /bm /fpi /fp3 /s /sg /w0 /zc /zp4 /zq /dMIT_SCHEME
-
-ifeq ($(debug_mode),debug)
-CFLAGS := $(CFLAGS) /d2
-else
-ifeq ($(debug_mode),optimize)
-CFLAGS := $(CFLAGS) /d1+ /oe /ox
-endif
-endif
-
-# Linker options.
-#
-# debug all include debug info in executable
-# option caseexact use case-sensitive comparison for identifiers
-# option quiet operate quietly
-# option symfile put debug info in .sym file
-LDFLAGS := debug all option caseexact option quiet option symfile
-
-# M4 options.
-#
-# -DOS2 Select OS/2 assembly-language conventions:
-# * No leading underscore in C symbols.
-# * 6-bit type codes.
-# * OS/2 _System calling convention.
-# -DDASM Select Intel assembly language.
-# -DWCC386R Select Watcom 386 register-based conventions.
-M4FLAGS = -DDASM -DWCC386R
-
-# Assembler options.
-#
-# /d1 generate debug info
-# /fpi generate in-line 387 insns, emulate if none
-# /fp3 generate in-line 387 insns
-# /mf use flat memory model
-# /zq operate quietly
-ASFLAGS := /fpi /fp3 /mf /zq
-ifeq ($(debug_mode),debug)
-ASFLAGS := $(ASFLAGS) /d1
-endif
-\f
-%.obj : %.c
- $(CC) $(CFLAGS) $<
-
-%.obj : %.asm
- $(AS) $(ASFLAGS) /fo=$@ $<
-
-%.exe :
- wlink system os2v2 $(LDFLAGS) name $@ file { $^ }
-
-include os2utl\makefile.cmn
-
-cmpauxmd.asm : cmpauxmd.m4 asmcvt.exe
- .\asmcvt pre < $< | $(M4) $(M4FLAGS) | .\asmcvt post > $@
-
-scheme.exe : $(OBJECTS) scheme.res
- wlink system os2v2_pm name $@ $(LDFLAGS) \
- file { $(OBJECTS) } $(SCHEME_LIB)
- rc scheme.res $@
-
-bchschem.exe : $(BCHOBJECTS) bchschem.res
- wlink system os2v2_pm name $@ $(LDFLAGS) \
- file { $(BCHOBJECTS) } $(SCHEME_LIB)
- rc bchschem.res $@
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-(load "os2pm.scm")
\ No newline at end of file
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#include "scheme.h"
-#include "gccode.h"
-#include "os2.h"
-
-extern int OS2_disable_stack_guard (void *);
-extern int OS2_essential_thread_p (TID);
-extern void OS2_message_box (const char *, const char *, int);
-
-extern ULONG C_Stack_Pointer;
-extern ULONG C_Frame_Pointer;
-\f
-typedef enum
-{
- trap_state_trapped,
- trap_state_exit,
- trap_state_suspend,
- trap_state_recover,
- trap_state_exitting_soft,
- trap_state_exitting_hard
-} trap_state_t;
-
-#define STATE_UNKNOWN (LONG_TO_UNSIGNED_FIXNUM (0))
-#define STATE_PRIMITIVE (LONG_TO_UNSIGNED_FIXNUM (1))
-#define STATE_COMPILED_CODE (LONG_TO_UNSIGNED_FIXNUM (2))
-#define STATE_PROBABLY_COMPILED (LONG_TO_UNSIGNED_FIXNUM (3))
-
-typedef struct
-{
- SCHEME_OBJECT state;
- SCHEME_OBJECT pc_info_1;
- SCHEME_OBJECT pc_info_2;
- SCHEME_OBJECT extra_trap_info;
-} trap_recovery_info_t;
-
-typedef struct
-{
- ULONG number;
- const char * name;
- const char * description;
-} exception_entry_t;
-
-#define SCHEME_ALIGNMENT_MASK ((sizeof (long)) - 1)
-#define FREE_PARANOIA_MARGIN 0x100
-
-static ULONG find_program_end_address (void);
-extern ULONG APIENTRY OS2_exception_handler
- (PEXCEPTIONREPORTRECORD, PEXCEPTIONREGISTRATIONRECORD, PCONTEXTRECORD,
- PVOID);
-static void trap_immediate_termination (void);
-static void trap_normal_termination (void);
-static void trap_recover (PEXCEPTIONREPORTRECORD, PCONTEXTRECORD);
-static void continue_from_trap (PEXCEPTIONREPORTRECORD, PCONTEXTRECORD);
-static void do_abort_to_interpreter (void);
-static SCHEME_OBJECT * compiled_code_free (PCONTEXTRECORD);
-static SCHEME_OBJECT * interpreter_free (int force_gc);
-static SCHEME_OBJECT * find_block_address (char *, SCHEME_OBJECT *);
-static SCHEME_OBJECT * find_block_address_in_area (char *, SCHEME_OBJECT *);
-static void setup_trap_frame
- (PEXCEPTIONREPORTRECORD, PCONTEXTRECORD, trap_recovery_info_t *,
- SCHEME_OBJECT *);
-static exception_entry_t * find_exception_entry (ULONG);
-static const char * find_exception_name (ULONG);
-static void describe_exception (ULONG, int);
-static int isvowel (char);
-static void noise_start (void);
-static void noise (const char *, ...);
-static USHORT noise_end (const char *, ULONG);
-\f
-static trap_state_t trap_state;
-static trap_state_t user_trap_state;
-static trap_state_t saved_trap_state;
-static ULONG saved_exception_number;
-static ULONG program_end_address;
-
-void
-OS2_initialize_exception_handling (void)
-{
- trap_state = trap_state_recover;
- user_trap_state = trap_state_recover;
- program_end_address = (find_program_end_address ());
-}
-
-static ULONG
-find_program_end_address (void)
-{
- /* The normal configuration for a C program is for the program text
- to start at 0x10000 and go up contiguously from there. */
- ULONG start = 0x10000; /* First 16 pages reserved for OS. */
- ULONG step = 0x1000; /* 4k page size. */
- ULONG end = 0x20000000; /* 512M maximum process address space. */
- ULONG flag_mask
- = (PAG_FREE | PAG_READ | PAG_WRITE | PAG_EXECUTE | PAG_GUARD
- | PAG_DEFAULT | PAG_SHARED | PAG_COMMIT);
- ULONG program_flags /* Permissions for program text pages. */
- = (PAG_READ | PAG_EXECUTE | PAG_COMMIT);
- ULONG length = (end - start);
- ULONG flags;
- APIRET rc;
-
- rc = (DosQueryMem (((PVOID) start), (& length), (& flags)));
- if (! ((rc == NO_ERROR) && ((flags & flag_mask) == program_flags)))
- OS2_logic_error ("Error reading program text start address.");
- while (1)
- {
- start += length;
- length = (end - start);
- rc = (DosQueryMem (((PVOID) start), (& length), (& flags)));
- if (rc == NO_ERROR)
- {
- if ((flags & flag_mask) != program_flags)
- return (start);
- }
- else if (rc == ERROR_INVALID_ADDRESS)
- return (start);
- else
- OS2_logic_error ("Error from DosQueryMem.");
- }
-}
-
-void
-OS2_enter_interpreter (void (* enter_interpreter) (void))
-{
- /* This registration record is required to be allocated on the C
- stack, so we have to use this unusual mechanism to install the
- trap-handling code. */
- EXCEPTIONREGISTRATIONRECORD registration;
- (registration . ExceptionHandler) = OS2_exception_handler;
- DosSetExceptionHandler (& registration);
- (* enter_interpreter) ();
- outf_fatal ("Exception!\n");
- termination_trap ();
-}
-
-trap_state_t
-OS_set_trap_state (trap_state_t state)
-{
- trap_state_t old_trap_state = user_trap_state;
- user_trap_state = state;
- trap_state = state;
- return (old_trap_state);
-}
-\f
-ULONG APIENTRY
-OS2_exception_handler (PEXCEPTIONREPORTRECORD report,
- PEXCEPTIONREGISTRATIONRECORD registration,
- PCONTEXTRECORD context,
- PVOID dispatcher_context)
-{
- trap_state_t old_trap_state;
- int stack_overflowed_p;
- ULONG exception_number;
- int recovery_unlikely_p = 0;
-
- /* We must ignore EH_NONCONTINUABLE exceptions because in order to
- do the throw, the registers must be correctly configured for C,
- and we accomplish this by bashing the context and returning with
- XCPT_CONTINUE_EXECUTION from here. */
- if ((((report -> fHandlerFlags)
- & (EH_UNWINDING | EH_EXIT_UNWIND | EH_STACK_INVALID | EH_NESTED_CALL
- | EH_NONCONTINUABLE))
- != 0)
- || (! (((report -> ExceptionNum) == XCPT_ACCESS_VIOLATION)
- || ((report -> ExceptionNum) == XCPT_ARRAY_BOUNDS_EXCEEDED)
- || ((report -> ExceptionNum) == XCPT_DATATYPE_MISALIGNMENT)
- || ((report -> ExceptionNum) == XCPT_FLOAT_DENORMAL_OPERAND)
- || ((report -> ExceptionNum) == XCPT_FLOAT_DIVIDE_BY_ZERO)
- || ((report -> ExceptionNum) == XCPT_FLOAT_INEXACT_RESULT)
- || ((report -> ExceptionNum) == XCPT_FLOAT_INVALID_OPERATION)
- || ((report -> ExceptionNum) == XCPT_FLOAT_OVERFLOW)
- || ((report -> ExceptionNum) == XCPT_FLOAT_STACK_CHECK)
- || ((report -> ExceptionNum) == XCPT_FLOAT_UNDERFLOW)
- || ((report -> ExceptionNum) == XCPT_GUARD_PAGE_VIOLATION)
- || ((report -> ExceptionNum) == XCPT_ILLEGAL_INSTRUCTION)
- || ((report -> ExceptionNum) == XCPT_INTEGER_DIVIDE_BY_ZERO)
- || ((report -> ExceptionNum) == XCPT_INTEGER_OVERFLOW)
- || ((report -> ExceptionNum) == XCPT_INVALID_LOCK_SEQUENCE)
- || ((report -> ExceptionNum) == XCPT_PRIVILEGED_INSTRUCTION))))
- return (XCPT_CONTINUE_SEARCH);
- exception_number = (report -> ExceptionNum);
- stack_overflowed_p = (STACK_OVERFLOWED_P ());
-
- /* If this is a guard page violation, we're only interested if it
- occurred in one of the Scheme stack guard pages. Test this by
- examining the second parameter, which is the address of the
- access within the guard page. `OS2_disable_stack_guard' will
- perform this test, additionally disabling the guard page if it is
- one of ours. */
- if (exception_number == XCPT_GUARD_PAGE_VIOLATION)
- {
- if (!OS2_disable_stack_guard ((void *) ((report -> ExceptionInfo) [1])))
- return (XCPT_CONTINUE_SEARCH);
- /* OK, we've determined that this is one of our guard pages, and
- it has been disabled. If `stack_overflowed_p' is true, we
- can't recover cleanly and must terminate Scheme. Otherwise,
- we still have some maneuvering room -- so signal a Scheme
- stack-overflow interrupt and continue. When Scheme takes the
- interrupt, it will do a throw, and the throw will re-enable
- the stack guard. */
- if (!stack_overflowed_p)
- {
- REQUEST_INTERRUPT (INT_Stack_Overflow);
- return (XCPT_CONTINUE_EXECUTION);
- }
- }
-
- old_trap_state = trap_state;
- if (old_trap_state == trap_state_exitting_hard)
- _exit (1);
- if (old_trap_state == trap_state_exitting_soft)
- trap_immediate_termination ();
- trap_state = trap_state_trapped;
-
- noise_start ();
- if (WITHIN_CRITICAL_SECTION_P ())
- {
- noise ("Scheme has detected ");
- describe_exception (exception_number, 0);
- noise (" within critical section \"%s\". ", (CRITICAL_SECTION_NAME ()));
- }
- else if (stack_overflowed_p || (old_trap_state != trap_state_recover))
- {
- noise ("Scheme has detected ");
- describe_exception (exception_number, 0);
- noise (". ");
- }
- if (stack_overflowed_p)
- {
- noise ("The stack has overflowed overwriting adjacent memory. ");
- noise ("This was probably caused by a runaway recursion. ");
- }
-
- switch (old_trap_state)
- {
- case trap_state_recover:
- if ((WITHIN_CRITICAL_SECTION_P ()) || stack_overflowed_p)
- {
- noise ("Successful recovery is unlikely. ");
- recovery_unlikely_p = 1;
- break;
- }
- saved_trap_state = old_trap_state;
- saved_exception_number = exception_number;
- (void) noise_end ("Exception Info", (MB_OK | MB_ERROR));
- trap_recover (report, context);
- return (XCPT_CONTINUE_EXECUTION);
-
- case trap_state_trapped:
- if (saved_trap_state == trap_state_recover)
- {
- noise ("This occurred while attempting to recover from ");
- describe_exception (saved_exception_number, 1);
- noise (". Successful recovery is ");
- if (WITHIN_CRITICAL_SECTION_P ())
- noise ("extremely ");
- noise ("unlikely. ");
- recovery_unlikely_p = 1;
- break;
- }
- (void) noise_end ("Exception Info", (MB_OK | MB_ERROR));
- trap_immediate_termination ();
- break;
-
- case trap_state_exit:
- (void) noise_end ("Exception Info", (MB_OK | MB_ERROR));
- termination_trap ();
- break;
- }
-
- noise ("\n\n");
- saved_trap_state = old_trap_state;
- saved_exception_number = exception_number;
- {
- int first_query = 1;
- while (1)
- {
- noise ("Attempt recovery?");
- if ((noise_end
- ("Recovery Choice",
- (MB_YESNO
- | (first_query ? MB_ERROR : 0)
- | (recovery_unlikely_p ? MB_DEFBUTTON2 : MB_DEFBUTTON1))))
- == MBID_YES)
- {
- trap_recover (report, context);
- return (XCPT_CONTINUE_EXECUTION);
- }
- else
- {
- first_query = 0;
- noise ("Terminate Scheme normally? ");
- noise ("Selecting \"No\" terminates Scheme immediately ");
- noise ("(without cleanup). Selecting \"Cancel\" returns to ");
- noise ("Recovery Choice dialog.");
- switch (noise_end ("Termination Choices", (MB_YESNOCANCEL)))
- {
- case MBID_YES:
- trap_normal_termination ();
- break;
- case MBID_NO:
- trap_immediate_termination ();
- _exit (1);
- break;
- }
- }
- }
- }
- return (XCPT_CONTINUE_SEARCH);
-}
-
-static void
-trap_immediate_termination (void)
-{
- extern void OS_restore_external_state (void);
- trap_state = trap_state_exitting_hard;
- OS_restore_external_state ();
- exit (1);
-}
-
-static void
-trap_normal_termination (void)
-{
- trap_state = trap_state_exitting_soft;
- termination_trap ();
-}
-\f
-static void
-trap_recover (PEXCEPTIONREPORTRECORD report, PCONTEXTRECORD context)
-{
- if (WITHIN_CRITICAL_SECTION_P ())
- {
- CLEAR_CRITICAL_SECTION_HOOK ();
- EXIT_CRITICAL_SECTION ({});
- }
- continue_from_trap (report, context);
-}
-\f
-/* Heuristic recovery from processor traps/exceptions.
-
- continue_from_trap attempts to:
-
- 1) validate the trap information (pc and sp);
- 2) determine whether compiled code was executing, a primitive was
- executing, or execution was in the interpreter;
- 3) guess what C global state is still valid; and
- 4) set up a recovery frame for the interpreter so that debuggers
- can display more information. */
-
-static void
-continue_from_trap (PEXCEPTIONREPORTRECORD report, PCONTEXTRECORD context)
-{
- ULONG pc;
- enum
- {
- pc_in_hyperspace,
- pc_in_c,
- pc_in_primitive,
- pc_in_utility,
- pc_in_builtin,
- pc_in_heap
- } pc_location;
-
- SCHEME_OBJECT * block_address;
- trap_recovery_info_t trinfo;
- SCHEME_OBJECT * new_sp;
-
- /* Punt if the context doesn't contain the registers we need to see. */
- if (((context -> ContextFlags) & CONTEXT_CONTROL) == 0)
- {
- (trinfo . state) = STATE_UNKNOWN;
- (trinfo . pc_info_1) = SHARP_F;
- (trinfo . pc_info_2) = SHARP_F;
- (trinfo . extra_trap_info) = SHARP_F;
- Free = (interpreter_free (1));
- new_sp = 0;
- goto done;
- }
-
- /* Classify the PC location. */
- pc = (context -> ctx_RegEip);
- if (!PC_ALIGNED_P (pc))
- pc_location = pc_in_hyperspace;
- else if (pc <= program_end_address)
- {
- if ((pc_to_builtin_index (pc)) != (-1))
- pc_location = pc_in_builtin;
- else if ((pc_to_utility_index (pc)) != (-1))
- pc_location = pc_in_utility;
- else if (PRIMITIVE_P (GET_PRIMITIVE))
- pc_location = pc_in_primitive;
- else
- pc_location = pc_in_c;
- }
- else if ((((ULONG) heap_start) <= pc) && (pc < ((ULONG) heap_end)))
- {
- pc_location = pc_in_heap;
- block_address = (find_block_address (((void *) pc), heap_start));
- }
- else if ((((ULONG) constant_start) <= pc) && (pc < ((ULONG) constant_end)))
- {
- pc_location = pc_in_heap;
- block_address = (find_block_address (((void *) pc), constant_start));
- }
- else
- pc_location = pc_in_hyperspace;
-
- /* Find Scheme's stack pointer. */
- switch (pc_location)
- {
- case pc_in_builtin:
- case pc_in_heap:
- new_sp = ((SCHEME_OBJECT *) (context -> ctx_RegEsp));
- break;
- case pc_in_utility:
- case pc_in_primitive:
- case pc_in_c:
- new_sp = stack_pointer;
- break;
- default:
- new_sp = 0;
- break;
- }
- if (! ((ADDRESS_IN_STACK_P (new_sp))
- && ((((ULONG) new_sp) & SCHEME_ALIGNMENT_MASK) == 0)))
- new_sp = 0;
-
- /* Build the trinfo structure. */
- switch (pc_location)
- {
- case pc_in_heap:
- if (block_address != 0)
- {
- (trinfo . state) = STATE_COMPILED_CODE;
- (trinfo . pc_info_1) = (MAKE_CC_BLOCK (block_address));
- (trinfo . pc_info_2)
- = (LONG_TO_UNSIGNED_FIXNUM (pc - ((ULONG) block_address)));
- }
- else
- {
- (trinfo . state) = STATE_PROBABLY_COMPILED;
- (trinfo . pc_info_1) = (LONG_TO_UNSIGNED_FIXNUM (pc));
- (trinfo . pc_info_2) = SHARP_F;
- }
- Free = (compiled_code_free (context));
- break;
- case pc_in_builtin:
- (trinfo . state) = STATE_PROBABLY_COMPILED;
- (trinfo . pc_info_1)
- = (LONG_TO_UNSIGNED_FIXNUM (pc_to_builtin_index (pc)));
- (trinfo . pc_info_2) = SHARP_T;
- Free = (compiled_code_free (context));
- break;
- case pc_in_utility:
- (trinfo . state) = STATE_PROBABLY_COMPILED;
- (trinfo . pc_info_1)
- = (LONG_TO_UNSIGNED_FIXNUM (pc_to_utility_index (pc)));
- (trinfo . pc_info_2) = UNSPECIFIC;
- Free = ((new_sp == 0) ? heap_alloc_limit : (interpreter_free (0)));
- break;
- case pc_in_primitive:
- (trinfo . state) = STATE_PRIMITIVE;
- (trinfo . pc_info_1) = GET_PRIMITIVE;
- (trinfo . pc_info_2) = (ULONG_TO_FIXNUM (GET_LEXPR_ACTUALS));
- Free = ((new_sp == 0) ? heap_alloc_limit : (interpreter_free (0)));
- break;
- default:
- (trinfo . state) = STATE_UNKNOWN;
- (trinfo . pc_info_1) = SHARP_F;
- (trinfo . pc_info_2) = SHARP_F;
- Free = (interpreter_free (1));
- break;
- }
- {
- SCHEME_OBJECT v
- = (allocate_non_marked_vector
- (TC_NON_MARKED_VECTOR,
- ((((context -> ContextFlags) & CONTEXT_INTEGER) == 0) ? 4 : 10),
- 0));
- /* First two elements of vector must be PC and SP, in that order. */
- VECTOR_SET (v, 0, ((SCHEME_OBJECT) (context -> ctx_RegEip)));
- VECTOR_SET (v, 1, ((SCHEME_OBJECT) (context -> ctx_RegEsp)));
- VECTOR_SET (v, 2, ((SCHEME_OBJECT) (context -> ctx_RegEbp)));
- VECTOR_SET (v, 3, ((SCHEME_OBJECT) (context -> ctx_EFlags)));
- if (((context -> ContextFlags) & CONTEXT_INTEGER) != 0)
- {
- VECTOR_SET (v, 4, ((SCHEME_OBJECT) (context -> ctx_RegEdi)));
- VECTOR_SET (v, 5, ((SCHEME_OBJECT) (context -> ctx_RegEsi)));
- VECTOR_SET (v, 6, ((SCHEME_OBJECT) (context -> ctx_RegEax)));
- VECTOR_SET (v, 7, ((SCHEME_OBJECT) (context -> ctx_RegEbx)));
- VECTOR_SET (v, 8, ((SCHEME_OBJECT) (context -> ctx_RegEcx)));
- VECTOR_SET (v, 9, ((SCHEME_OBJECT) (context -> ctx_RegEdx)));
- }
- (trinfo . extra_trap_info) = v;
- }
- done:
- setup_trap_frame (report, context, (& trinfo), new_sp);
-
- /* If this was a hardware-generated floating-point exception, clear
- the corresponding bit in the processor status word. Otherwise
- the exception will be resignalled when we restart. */
- if (((context -> ContextFlags) & CONTEXT_FLOATING_POINT) != 0)
- switch (report -> ExceptionNum)
- {
- case XCPT_FLOAT_DENORMAL_OPERAND:
- ((context -> ctx_env) [1]) &=~ 0x02;
- break;
- case XCPT_FLOAT_DIVIDE_BY_ZERO:
- ((context -> ctx_env) [1]) &=~ 0x04;
- break;
- case XCPT_FLOAT_INEXACT_RESULT:
- ((context -> ctx_env) [1]) &=~ 0x20;
- break;
- case XCPT_FLOAT_INVALID_OPERATION:
- ((context -> ctx_env) [1]) &=~ 0x01;
- break;
- case XCPT_FLOAT_OVERFLOW:
- ((context -> ctx_env) [1]) &=~ 0x08;
- break;
- case XCPT_FLOAT_UNDERFLOW:
- ((context -> ctx_env) [1]) &=~ 0x10;
- break;
- }
- /* Now attempt to continue. This requires some trickery if the
- registers are configured for Scheme compiled code, because
- longjmp will fail unless the stack and frame pointers are set up
- for C. This is because of error checking that is built in to the
- OS/2 exception handling mechanism: it checks the stack pointer to
- make sure that the exception-handler registration records are on
- the stack. */
- if (! ((pc_location == pc_in_builtin) || (pc_location == pc_in_heap)))
- abort_to_interpreter (PRIM_APPLY);
- (context -> ctx_RegEsp) = C_Stack_Pointer;
- (context -> ctx_RegEbp) = C_Frame_Pointer;
- (context -> ctx_RegEip) = ((ULONG) do_abort_to_interpreter);
-}
-
-static void
-do_abort_to_interpreter (void)
-{
- abort_to_interpreter (PRIM_APPLY);
-}
-
-static SCHEME_OBJECT *
-compiled_code_free (PCONTEXTRECORD context)
-{
- if (((context -> ContextFlags) & CONTEXT_INTEGER) != 0)
- {
- ULONG edi = (context -> ctx_RegEdi);
- if (((edi & SCHEME_ALIGNMENT_MASK) == 0)
- && (((ULONG) heap_start) <= edi)
- && (edi < ((ULONG) heap_end)))
- return (((SCHEME_OBJECT *) edi) + FREE_PARANOIA_MARGIN);
- }
- return (interpreter_free (1));
-}
-
-static SCHEME_OBJECT *
-interpreter_free (int force_gc)
-{
- return
- ((((force_gc ? heap_alloc_limit : heap_start) <= Free)
- && (Free < heap_end)
- && ((((ULONG) Free) & SCHEME_ALIGNMENT_MASK) == 0))
- ? (((Free + FREE_PARANOIA_MARGIN) < heap_alloc_limit)
- ? (Free + FREE_PARANOIA_MARGIN)
- : (Free < heap_alloc_limit)
- ? heap_alloc_limit
- : Free)
- : heap_alloc_limit);
-}
-\f
-/* Find the compiled code block in area which contains `pc_value'.
- This attempts to be more efficient than `find_block_address_in_area'.
- If the pointer is in the heap, it can actually do twice as
- much work, but it is expected to pay off on the average. */
-
-#define MINIMUM_SCAN_RANGE 2048
-
-static SCHEME_OBJECT *
-find_block_address (char * pc_value, SCHEME_OBJECT * area_start)
-{
- SCHEME_OBJECT * nearest_word
- = ((SCHEME_OBJECT *)
- (((unsigned long) pc_value) &~ SCHEME_ALIGNMENT_MASK));
- long maximum_distance = (nearest_word - area_start);
- long distance = maximum_distance;
- while ((distance / 2) > MINIMUM_SCAN_RANGE)
- distance = (distance / 2);
- while ((distance * 2) < maximum_distance)
- {
- SCHEME_OBJECT * block
- = (find_block_address_in_area (pc_value, (nearest_word - distance)));
- if (block != 0)
- return (block);
- distance *= 2;
- }
- return (find_block_address_in_area (pc_value, area_start));
-}
-\f
-/* Find the compiled code block in area which contains `pc_value', by
- scanning sequentially the complete area. For the time being, skip
- over manifest closures and linkage sections. */
-
-static SCHEME_OBJECT *
-find_block_address_in_area (char * pc_value, SCHEME_OBJECT * area_start)
-{
- SCHEME_OBJECT * first_valid = area_start;
- SCHEME_OBJECT * area = area_start;
- while (((char *) area) < pc_value)
- {
- SCHEME_OBJECT object = (*area);
- switch (OBJECT_TYPE (object))
- {
- case TC_LINKAGE_SECTION:
- {
- unsigned long count = (linkage_section_count (object));
- area += 1;
- switch (linkage_section_type (object))
- {
- case LINKAGE_SECTION_TYPE_OPERATOR:
- case LINKAGE_SECTION_TYPE_GLOBAL_OPERATOR:
- area += (count * UUO_LINK_SIZE);
- break;
-
- case LINKAGE_SECTION_TYPE_REFERENCE:
- case LINKAGE_SECTION_TYPE_ASSIGNMENT:
- default:
- area += count;
- break;
- }
- }
- break;
-
- case TC_MANIFEST_CLOSURE:
- area = (compiled_closure_objects (area + 1));
- break;
-
- case TC_MANIFEST_NM_VECTOR:
- {
- unsigned long count = (OBJECT_DATUM (object));
- if (((char *) (area + (count + 1))) < pc_value)
- {
- area += (count + 1);
- first_valid = area;
- break;
- }
- {
- SCHEME_OBJECT * block = (area - 1);
- return
- (((area > first_valid)
- && ((OBJECT_TYPE (*block)) == TC_MANIFEST_VECTOR)
- && ((OBJECT_DATUM (*block)) >= (count + 1))
- && (plausible_cc_block_p (block)))
- ? block
- : 0);
- }
- }
-
- default:
- area += 1;
- break;
- }
- }
- return (0);
-}
-\f
-static void
-setup_trap_frame (PEXCEPTIONREPORTRECORD report,
- PCONTEXTRECORD context,
- trap_recovery_info_t * trinfo,
- SCHEME_OBJECT * new_sp)
-{
- long saved_mask;
- SCHEME_OBJECT handler;
- SCHEME_OBJECT trap_name;
-
- /* Disable interrupts while building stack frame. */
- saved_mask = GET_INT_MASK;
- SET_INTERRUPT_MASK (0);
-
- /* Get the trap handler -- lose if there isn't one. */
- handler
- = ((VECTOR_P (fixed_objects))
- ? (VECTOR_REF (fixed_objects, TRAP_HANDLER))
- : SHARP_F);
- if (!INTERPRETER_APPLICABLE_P (handler))
- {
- noise_start ();
- noise ("There is no trap handler for recovery!\n");
- noise ("This occurred during ");
- describe_exception ((report -> ExceptionNum), 0);
- noise (".\n");
- noise ("pc = %#08x; sp = %#08x.\n",
- (context -> ctx_RegEip), (context -> ctx_RegEsp));
- (void) noise_end ("Exception Info", (MB_OK | MB_ERROR));
- termination_trap ();
- }
-
- /* Set the GC interrupt bit if necessary. */
- if (!FREE_OK_P (Free))
- REQUEST_GC (0);
-
- /* Make sure the stack is correctly initialized. */
- if (new_sp != 0)
- stack_pointer = new_sp;
- else
- {
- INITIALIZE_STACK ();
- Will_Push (CONTINUATION_SIZE);
- SET_RC (RC_END_OF_COMPUTATION);
- SET_EXP (SHARP_F);
- SAVE_CONT ();
- Pushed ();
- }
- {
- const char * name = (find_exception_name (report -> ExceptionNum));
- trap_name = ((name == 0) ? SHARP_F : (char_pointer_to_string (name)));
- }
- /* Push the hardware-trap stack frame. The continuation parser will
- find this and use it to present meaningful debugging information
- to the user. */
- Will_Push (7 + CONTINUATION_SIZE);
- STACK_PUSH (trinfo -> extra_trap_info);
- STACK_PUSH (trinfo -> pc_info_2);
- STACK_PUSH (trinfo -> pc_info_1);
- STACK_PUSH (trinfo -> state);
- STACK_PUSH (BOOLEAN_TO_OBJECT (new_sp != 0));
- STACK_PUSH (long_to_integer (report -> ExceptionNum));
- STACK_PUSH (trap_name);
- SET_RC (RC_HARDWARE_TRAP);
- SET_EXP (UNSPECIFIC);
- SAVE_CONT ();
- Pushed ();
-
- /* Make sure the history register is properly initialized. */
- if ((new_sp != 0) && ((trinfo -> state) == STATE_COMPILED_CODE))
- stop_history ();
- history_register = (make_dummy_history ());
-
- /* Push the call frame for the trap handler. */
- Will_Push (STACK_ENV_EXTRA_SLOTS + 2);
- STACK_PUSH (trap_name);
- STACK_PUSH (handler);
- PUSH_APPLY_FRAME_HEADER (1);
- Pushed ();
-
- /* Restore the interrupt mask and call the handler. */
- SET_INTERRUPT_MASK (saved_mask);
-}
-\f
-#define EXCEPTION_ENTRY(name, description) { name, #name, description }
-static exception_entry_t exception_names [] =
-{
- EXCEPTION_ENTRY (XCPT_ACCESS_VIOLATION, "access violation"),
- EXCEPTION_ENTRY (XCPT_ARRAY_BOUNDS_EXCEEDED, "array bounds exceeded"),
- EXCEPTION_ENTRY (XCPT_ASYNC_PROCESS_TERMINATE, "async process terminate"),
-#ifdef XCPT_B1NPX_ERRATA_02
- EXCEPTION_ENTRY (XCPT_B1NPX_ERRATA_02, "B1NPX errata"),
-#endif
- EXCEPTION_ENTRY (XCPT_BAD_STACK, "bad stack"),
- EXCEPTION_ENTRY (XCPT_BREAKPOINT, "breakpoint"),
- EXCEPTION_ENTRY (XCPT_DATATYPE_MISALIGNMENT, "data type misalignment"),
- EXCEPTION_ENTRY (XCPT_FLOAT_DENORMAL_OPERAND,
- "floating point denormal operand"),
- EXCEPTION_ENTRY (XCPT_FLOAT_DIVIDE_BY_ZERO, "floating point divide by zero"),
- EXCEPTION_ENTRY (XCPT_FLOAT_INEXACT_RESULT, "floating point inexact result"),
- EXCEPTION_ENTRY (XCPT_FLOAT_INVALID_OPERATION,
- "floating point invalid operation"),
- EXCEPTION_ENTRY (XCPT_FLOAT_OVERFLOW, "floating point overflow"),
- EXCEPTION_ENTRY (XCPT_FLOAT_STACK_CHECK, "floating point stack check"),
- EXCEPTION_ENTRY (XCPT_FLOAT_UNDERFLOW, "floating point underflow"),
- EXCEPTION_ENTRY (XCPT_GUARD_PAGE_VIOLATION, "guard page violation"),
- EXCEPTION_ENTRY (XCPT_ILLEGAL_INSTRUCTION, "illegal instruction"),
- EXCEPTION_ENTRY (XCPT_INTEGER_DIVIDE_BY_ZERO, "integer divide by zero"),
- EXCEPTION_ENTRY (XCPT_INTEGER_OVERFLOW, "integer overflow"),
- EXCEPTION_ENTRY (XCPT_INVALID_DISPOSITION, "invalid disposition"),
- EXCEPTION_ENTRY (XCPT_INVALID_LOCK_SEQUENCE, "invalid lock sequence"),
- EXCEPTION_ENTRY (XCPT_INVALID_UNWIND_TARGET, "invalid unwind target"),
- EXCEPTION_ENTRY (XCPT_IN_PAGE_ERROR, "in-page error"),
- EXCEPTION_ENTRY (XCPT_NONCONTINUABLE_EXCEPTION, "noncontinuable exception"),
- EXCEPTION_ENTRY (XCPT_PRIVILEGED_INSTRUCTION, "privileged instruction"),
- EXCEPTION_ENTRY (XCPT_PROCESS_TERMINATE, "process terminate"),
- EXCEPTION_ENTRY (XCPT_SIGNAL, "signal"),
- EXCEPTION_ENTRY (XCPT_SINGLE_STEP, "single step"),
- EXCEPTION_ENTRY (XCPT_UNABLE_TO_GROW_STACK, "unable to grow stack"),
- EXCEPTION_ENTRY (XCPT_UNWIND, "unwind")
-};
-
-static exception_entry_t *
-find_exception_entry (ULONG exception_number)
-{
- unsigned int i = 0;
- unsigned int end
- = ((sizeof (exception_names)) / (sizeof (exception_entry_t)));
- while (i < end)
- {
- if (exception_number == ((exception_names [i]) . number))
- return (& (exception_names [i]));
- i += 1;
- }
- return (0);
-}
-
-static const char *
-find_exception_name (ULONG exception_number)
-{
- exception_entry_t * entry = (find_exception_entry (exception_number));
- return ((entry == 0) ? 0 : (entry -> name));
-}
-
-static void
-describe_exception (ULONG exception_number, int earlierp)
-{
- exception_entry_t * entry = (find_exception_entry (exception_number));
- const char * prefix = (earlierp ? "earlier " : "");
- if (entry == 0)
- noise ("an %sunknown exception [code = %d]", prefix, exception_number);
- else
- noise ("a%s %s%s exception",
- ((earlierp || (isvowel ((entry -> description) [0]))) ? "n" : ""),
- prefix,
- (entry -> description));
-}
-
-static int
-isvowel (char c)
-{
- return
- ((c == 'a') || (c == 'e') || (c == 'i') || (c == 'o') || (c == 'u')
- || (c == 'A') || (c == 'E') || (c == 'I') || (c == 'O') || (c == 'U'));
-}
-\f
-static char * noise_accumulator;
-static char * noise_accumulator_position;
-
-static void
-noise_start (void)
-{
- noise_accumulator = 0;
- noise_accumulator_position = 0;
-}
-
-static void
-noise (const char * format, ...)
-{
- unsigned int index = (noise_accumulator_position - noise_accumulator);
- noise_accumulator
- = ((noise_accumulator == 0)
- ? (OS_malloc (256))
- : (OS_realloc (noise_accumulator, (index + 256))));
- noise_accumulator_position = (noise_accumulator + index);
- {
- va_list arg_pointer;
- va_start (arg_pointer, format);
- noise_accumulator_position
- += (vsprintf (noise_accumulator_position, format, arg_pointer));
- va_end (arg_pointer);
- }
-}
-
-static USHORT
-noise_end (const char * title, ULONG style)
-{
- if (noise_accumulator == 0)
- return (MBID_YES);
- {
- USHORT rc
- = (WinMessageBox (HWND_DESKTOP,
- NULLHANDLE, /* client window handle */
- noise_accumulator,
- ((char *) title),
- 0,
- style));
- OS_free (noise_accumulator);
- noise_accumulator = 0;
- noise_accumulator_position = 0;
- return (rc);
- }
-}
-\f
-ULONG APIENTRY
-OS2_subthread_exception_handler (PEXCEPTIONREPORTRECORD report,
- PEXCEPTIONREGISTRATIONRECORD registration,
- PCONTEXTRECORD context,
- PVOID dispatcher_context)
-{
- ULONG exception_number;
- PTIB ptib;
- PPIB ppib;
- TID tid;
- char * format
- = "Scheme has detected exception number %#08x within thread %d.%s%s\
- This indicates a bug in the Scheme implementation.\
- Please report this information to a Scheme wizard.\n\n";
- char backtrace [1024];
-
- if (((report -> fHandlerFlags)
- & (EH_UNWINDING | EH_EXIT_UNWIND | EH_STACK_INVALID | EH_NESTED_CALL))
- != 0)
- return (XCPT_CONTINUE_SEARCH);
- exception_number = (report -> ExceptionNum);
- if (! ((exception_number == XCPT_ACCESS_VIOLATION)
- || (exception_number == XCPT_ARRAY_BOUNDS_EXCEEDED)
- || (exception_number == XCPT_DATATYPE_MISALIGNMENT)
- || (exception_number == XCPT_FLOAT_DENORMAL_OPERAND)
- || (exception_number == XCPT_FLOAT_DIVIDE_BY_ZERO)
- || (exception_number == XCPT_FLOAT_INEXACT_RESULT)
- || (exception_number == XCPT_FLOAT_INVALID_OPERATION)
- || (exception_number == XCPT_FLOAT_OVERFLOW)
- || (exception_number == XCPT_FLOAT_STACK_CHECK)
- || (exception_number == XCPT_FLOAT_UNDERFLOW)
- || (exception_number == XCPT_ILLEGAL_INSTRUCTION)
- || (exception_number == XCPT_INTEGER_DIVIDE_BY_ZERO)
- || (exception_number == XCPT_INTEGER_OVERFLOW)
- || (exception_number == XCPT_INVALID_LOCK_SEQUENCE)
- || (exception_number == XCPT_PRIVILEGED_INSTRUCTION)))
- return (XCPT_CONTINUE_SEARCH);
- (void) dos_get_info_blocks ((&ptib), (&ppib));
- if (((context -> ContextFlags) & CONTEXT_CONTROL) == 0)
- (backtrace[0]) = '\0';
- else
- {
- ULONG * ebp = ((ULONG *) (context -> ctx_RegEbp));
- unsigned int count = 0;
- sprintf (backtrace, " (Backtrace:");
- sprintf ((backtrace + (strlen (backtrace))), " %#08x",
- (context -> ctx_RegEip));
- while ((((char *) ebp) > ((char *) (ptib -> tib_pstack)))
- && (((char *) ebp) < ((char *) (ptib -> tib_pstacklimit)))
- && (count < 10))
- {
- sprintf ((backtrace + (strlen (backtrace))), " %#08x", (ebp[1]));
- ebp = ((ULONG *) (ebp[0]));
- }
- sprintf ((backtrace + (strlen (backtrace))), ")");
- }
- tid = (ptib -> tib_ptib2 -> tib2_ultid);
- if (OS2_essential_thread_p (tid))
- {
- outf_fatal (format, exception_number, tid, backtrace, "");
- termination_init_error ();
- }
- else
- {
- char buffer [1024];
- sprintf (buffer, format, exception_number, tid, backtrace,
- " The thread will be killed.");
- OS2_message_box ("Scheme Error", buffer, 0);
- OS2_endthread ();
- }
-}
file_type_unix_block_device,
file_type_unix_fifo,
file_type_unix_stream_socket,
- file_type_os2_named_pipe,
+ file_type_unused_1,
file_type_win32_named_pipe,
file_type_unknown = 0xFFFF
};
channel_type_directory,
channel_type_unix_character_device,
channel_type_unix_block_device,
- channel_type_os2_console,
- channel_type_os2_unnamed_pipe,
- channel_type_os2_named_pipe,
+ channel_type_unused_1,
+ channel_type_unused_2,
+ channel_type_unused_3,
channel_type_win32_anonymous_pipe,
channel_type_win32_named_pipe
};
return (PRIMITIVE_P (GET_PRIMITIVE));
}
-#ifdef __OS2__
-
-void
-request_attention_interrupt (void)
-{
- REQUEST_INTERRUPT (INT_Global_1);
-}
-
-int
-test_and_clear_attention_interrupt (void)
-{
- unsigned long code;
- GRAB_INTERRUPT_REGISTERS ();
- code = GET_INT_CODE;
- CLEAR_INTERRUPT_NOLOCK (INT_Global_1);
- RELEASE_INTERRUPT_REGISTERS ();
- return ((code & INT_Global_1) != 0);
-}
-
-#endif /* __OS2__ */
-
void
request_console_resize_interrupt (void)
{
extern void error_floating_point_exception (void) NORETURN;
extern void error_process_terminated (void) NORETURN;
-#ifdef __OS2__
- extern void request_attention_interrupt (void);
- extern int test_and_clear_attention_interrupt (void);
-#endif
-
extern void request_console_resize_interrupt (void);
extern void request_character_interrupt (void);
extern void request_timer_interrupt (void);
# include "ntscreen.h"
extern HANDLE master_tty_window;
#endif
-
-#ifdef __OS2__
- extern char * OS2_thread_fatal_error_buffer (void);
- extern void OS2_message_box (const char *, const char *, int);
- extern void OS2_console_write (const char *, size_t);
-#endif
\f
void
outf (outf_channel chan, const char * format, ...)
#endif /* __WIN32__ */
\f
-#ifdef __OS2__
-
-#define OUTF_VARIANTS_DEFINED 1
-
-void
-voutf_console (const char * format, va_list args)
-{
- char buffer [4096];
- vsprintf (buffer, format, args);
- OS2_console_write (buffer, (strlen (buffer)));
-}
-
-void
-outf_flush_console (void)
-{
-}
-
-void
-voutf_error (const char * format, va_list args)
-{
- voutf_console (format, args);
-}
-
-void
-outf_flush_error (void)
-{
-}
-
-void
-voutf_fatal (const char * format, va_list args)
-{
- char * buffer = (OS2_thread_fatal_error_buffer ());
- unsigned int end = (strlen (buffer));
- vsprintf ((& (buffer [end])), format, args);
-}
-
-void
-outf_flush_fatal (void)
-{
- char * buffer = (OS2_thread_fatal_error_buffer ());
- OS2_message_box ("MIT/GNU Scheme terminating", buffer, 1);
- (buffer[0]) = '\0';
-}
-
-#endif /* __OS2__ */
-\f
#ifndef OUTF_VARIANTS_DEFINED
void
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#include "scheme.h"
-#include "prims.h"
-#include "os2.h"
-#include "osfs.h"
-
-extern FILESTATUS3 * OS2_read_file_status (const char *);
-extern void OS2_write_file_status (const char *, FILESTATUS3 *);
-extern char * OS2_drive_type (char);
-extern long OS2_timezone (void);
-extern long OS2_daylight_savings_p (void);
-extern void OS_file_copy (const char *, const char *);
-
-static SCHEME_OBJECT time_to_integer (FDATE *, FTIME *);
-static void integer_to_time (SCHEME_OBJECT, FDATE *, FTIME *);
-\f
-DEFINE_PRIMITIVE ("FILE-ATTRIBUTES", Prim_file_attributes, 1, 1,
- "Return attributes of FILE, as an integer.")
-{
- PRIMITIVE_HEADER (1);
- {
- FILESTATUS3 * info = (OS2_read_file_status (STRING_ARG (1)));
- PRIMITIVE_RETURN
- ((info == 0)
- ? SHARP_F
- : (LONG_TO_UNSIGNED_FIXNUM (info -> attrFile)));
- }
-}
-
-DEFINE_PRIMITIVE ("SET-FILE-ATTRIBUTES!", Prim_set_file_attributes, 2, 2,
- "Set the attributes of FILE to ATTRIBUTES.")
-{
- PRIMITIVE_HEADER (2);
- {
- FILESTATUS3 * info = (OS2_read_file_status (STRING_ARG (1)));
- if (info == 0)
- error_bad_range_arg (1);
- (info -> attrFile) = (arg_index_integer (2, 0x10000));
- OS2_write_file_status ((STRING_ARG (1)), info);
- PRIMITIVE_RETURN (UNSPECIFIC);
- }
-}
-
-DEFINE_PRIMITIVE ("FILE-LENGTH", Prim_file_length, 1, 1,
- "Return attributes of FILE, as an integer.")
-{
- PRIMITIVE_HEADER (1);
- {
- FILESTATUS3 * info = (OS2_read_file_status (STRING_ARG (1)));
- PRIMITIVE_RETURN
- ((info == 0)
- ? SHARP_F
- : (ulong_to_integer (info -> cbFile)));
- }
-}
-
-DEFINE_PRIMITIVE ("GET-ENVIRONMENT-VARIABLE", Prim_get_environment_variable, 1, 1,
- "Look up the value of a variable in the user's shell environment.\n\
-The argument, a variable name, must be a string.\n\
-The result is either a string (the variable's value),\n\
- or #F indicating that the variable does not exist.")
-{
- PRIMITIVE_HEADER (1);
- {
- PSZ result;
- XTD_API_CALL
- (dos_scan_env, ((STRING_ARG (1)), (& result)),
- {
- if (rc == ERROR_ENVVAR_NOT_FOUND)
- PRIMITIVE_RETURN (SHARP_F);
- });
- PRIMITIVE_RETURN (char_pointer_to_string (result));
- }
-}
-
-DEFINE_PRIMITIVE ("FILE-EQ?", Prim_file_eq_p, 2, 2,
- "True iff the two file arguments are the same file.")
-{
- PRIMITIVE_HEADER (2);
- CHECK_ARG (1, STRING_P);
- CHECK_ARG (2, STRING_P);
- {
- unsigned long length = (STRING_LENGTH (ARG_REF (1)));
- const char * s1 = (STRING_POINTER (ARG_REF (1)));
- const char * s2 = (STRING_POINTER (ARG_REF (2)));
- const char * e1 = (s1 + length);
- if ((STRING_LENGTH (ARG_REF (2))) != length)
- PRIMITIVE_RETURN (SHARP_F);
- while (s1 < e1)
- if ((char_upcase (*s1++)) != (char_upcase (*s2++)))
- PRIMITIVE_RETURN (SHARP_F);
- PRIMITIVE_RETURN (SHARP_T);
- }
-}
-\f
-DEFINE_PRIMITIVE ("FILE-MOD-TIME", Prim_file_mod_time, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- {
- FILESTATUS3 * info = (OS2_read_file_status (STRING_ARG (1)));
- PRIMITIVE_RETURN
- ((info == 0)
- ? SHARP_F
- : (time_to_integer ((& (info -> fdateLastWrite)),
- (& (info -> ftimeLastWrite)))));
- }
-}
-
-DEFINE_PRIMITIVE ("FILE-ACCESS-TIME", Prim_file_acc_time, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- {
- FILESTATUS3 * info = (OS2_read_file_status (STRING_ARG (1)));
- PRIMITIVE_RETURN
- ((info == 0)
- ? SHARP_F
- : (time_to_integer ((& (info -> fdateLastAccess)),
- (& (info -> ftimeLastAccess)))));
- }
-}
-
-static SCHEME_OBJECT
-time_to_integer (FDATE * date, FTIME * time)
-{
- unsigned long accum;
- accum = (date -> year);
- accum = ((accum << 4) | (date -> month));
- accum = ((accum << 5) | (date -> day));
- accum = ((accum << 5) | (time -> hours));
- accum = ((accum << 6) | (time -> minutes));
- accum = ((accum << 5) | (time -> twosecs));
- return (ulong_to_integer (accum));
-}
-
-DEFINE_PRIMITIVE ("SET-FILE-TIMES!", Prim_set_file_times, 3, 3,
- "Change the access and modification times of FILE.\n\
-The second and third arguments are the respective times.\n\
-The file must exist and you must be the owner (or superuser).")
-{
- PRIMITIVE_HEADER (3);
- {
- FILESTATUS3 * info = (OS2_read_file_status (STRING_ARG (1)));
- SCHEME_OBJECT atime = (ARG_REF (2));
- SCHEME_OBJECT mtime = (ARG_REF (3));
- if (info == 0)
- error_bad_range_arg (1);
- if (atime != SHARP_F)
- {
- if (!INTEGER_P (atime))
- error_wrong_type_arg (2);
- if (integer_negative_p (atime))
- error_bad_range_arg (2);
- integer_to_time (atime,
- (& (info -> fdateLastAccess)),
- (& (info -> ftimeLastAccess)));
- }
- if (mtime != SHARP_F)
- {
- if (!INTEGER_P (mtime))
- error_wrong_type_arg (3);
- if (integer_negative_p (mtime))
- error_bad_range_arg (3);
- integer_to_time (mtime,
- (& (info -> fdateLastWrite)),
- (& (info -> ftimeLastWrite)));
- }
- OS2_write_file_status ((STRING_ARG (1)), info);
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-static void
-integer_to_time (SCHEME_OBJECT encoding, FDATE * date, FTIME * time)
-{
- unsigned long accum = (integer_to_ulong (encoding));
- (time -> twosecs) = (accum & 0x1f);
- accum >>= 5;
- (time -> minutes) = (accum & 0x3f);
- accum >>= 6;
- (time -> hours) = (accum & 0x1f);
- accum >>= 5;
- (date -> day) = (accum & 0x1f);
- accum >>= 5;
- (date -> month) = (accum & 0x0f);
- accum >>= 4;
- (date -> year) = accum;
-}
-\f
-DEFINE_PRIMITIVE ("FILE-INFO", Prim_file_info, 1, 1,
- "Given a file name, return information about the file.\n\
-If the file exists and its information is accessible,\n\
- the result is a vector of 6 items.\n\
-Otherwise the result is #F.")
-{
- FILESTATUS3 * info;
- SCHEME_OBJECT result;
- PRIMITIVE_HEADER (1);
-
- info = (OS2_read_file_status (STRING_ARG (1)));
- if (info == 0)
- PRIMITIVE_RETURN (SHARP_F);
- result = (allocate_marked_vector (TC_VECTOR, 8, true));
- VECTOR_SET (result, 0,
- ((((info -> attrFile) & FILE_DIRECTORY) != 0)
- ? SHARP_T
- : SHARP_F));
- VECTOR_SET (result, 1,
- (time_to_integer ((& (info -> fdateLastAccess)),
- (& (info -> ftimeLastAccess)))));
- VECTOR_SET (result, 2,
- (time_to_integer ((& (info -> fdateLastWrite)),
- (& (info -> ftimeLastWrite)))));
- VECTOR_SET (result, 3,
- (time_to_integer ((& (info -> fdateCreation)),
- (& (info -> ftimeCreation)))));
- VECTOR_SET (result, 4, (ulong_to_integer (info -> cbFile)));
- {
- unsigned int attr = (info -> attrFile);
- SCHEME_OBJECT modes = (allocate_string (5));
- char * s = (STRING_POINTER (modes));
- (s[0]) = (((attr & FILE_DIRECTORY) != 0) ? 'd' : '-');
- (s[1]) = (((attr & FILE_READONLY) != 0) ? 'r' : '-');
- (s[2]) = (((attr & FILE_HIDDEN) != 0) ? 'h' : '-');
- (s[3]) = (((attr & FILE_SYSTEM) != 0) ? 's' : '-');
- (s[4]) = (((attr & FILE_ARCHIVED) != 0) ? 'a' : '-');
- VECTOR_SET (result, 5, modes);
- VECTOR_SET (result, 6, (ulong_to_integer (attr)));
- }
- VECTOR_SET (result, 7, (ulong_to_integer (info -> cbFileAlloc)));
- PRIMITIVE_RETURN (result);
-}
-\f
-DEFINE_PRIMITIVE ("DRIVE-TYPE", Prim_drive_type, 1, 1, 0)
-{
- SCHEME_OBJECT arg;
- char * type;
- PRIMITIVE_HEADER (1);
-
- CHECK_ARG (1, STRING_P);
- arg = (ARG_REF (1));
- if (! (((STRING_LENGTH (arg)) == 1) && (isalpha (STRING_REF (arg, 0)))))
- error_bad_range_arg (1);
- type = (OS2_drive_type (STRING_REF (arg, 0)));
- PRIMITIVE_RETURN (char_pointer_to_string ((type == 0) ? "unknown" : type));
-}
-
-DEFINE_PRIMITIVE ("CURRENT-PID", Prim_current_pid, 0, 0,
- "Return Scheme's PID.")
-{
- PRIMITIVE_HEADER (0);
- PRIMITIVE_RETURN (ulong_to_integer (OS2_scheme_pid));
-}
-
-DEFINE_PRIMITIVE ("DOS-QUERY-MEMORY", Prim_dos_query_memory, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- {
- ULONG start = (arg_ulong_integer (1));
- ULONG length = (arg_ulong_integer (2));
- ULONG flags;
- XTD_API_CALL
- (dos_query_mem, (((PVOID) start), (&length), (&flags)),
- {
- if (rc == ERROR_INVALID_ADDRESS)
- PRIMITIVE_RETURN (SHARP_F);
- });
- PRIMITIVE_RETURN (cons ((ulong_to_integer (length)),
- (ulong_to_integer (flags))));
- }
-}
-
-DEFINE_PRIMITIVE ("OS2-TIME-ZONE", Prim_OS2_timezone, 0, 0, 0)
-{
- PRIMITIVE_HEADER (0);
- PRIMITIVE_RETURN (long_to_integer (OS2_timezone ()));
-}
-
-DEFINE_PRIMITIVE ("OS2-DAYLIGHT-SAVINGS-TIME?", Prim_OS2_dst_p, 0, 0, 0)
-{
- PRIMITIVE_HEADER (0);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (OS2_daylight_savings_p ()));
-}
-
-DEFINE_PRIMITIVE ("OS2-COPY-FILE", Prim_OS2_copy_file, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- OS_file_copy ((STRING_ARG (1)), (STRING_ARG (2)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("OS2-SET-REL-MAX-FH", Prim_OS2_set_rel_max_fh, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- {
- LONG req_max_fh = (arg_integer (1));
- ULONG current_max_fh;
- STD_API_CALL (dos_set_rel_max_fh, ((&req_max_fh), (¤t_max_fh)));
- PRIMITIVE_RETURN (ulong_to_integer (current_max_fh));
- }
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#include "scheme.h"
-#include "prims.h"
-#include "os2.h"
-#include "os2proc.h"
-
-extern qid_t OS2_channel_thread_descriptor (Tchannel);
-\f
-DEFINE_PRIMITIVE ("OS2-SELECT-REGISTRY-LUB", Prim_OS2_select_registry_lub, 0, 0, 0)
-{
- PRIMITIVE_HEADER (0);
- PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (QID_MAX + 1));
-}
-
-DEFINE_PRIMITIVE ("CHANNEL-DESCRIPTOR", Prim_channel_descriptor, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- {
- Tchannel channel = (arg_channel (1));
- PRIMITIVE_RETURN
- (LONG_TO_UNSIGNED_FIXNUM
- ((CHANNEL_ABSTRACT_P (channel))
- ? (OS2_channel_thread_descriptor (channel))
- : QID_NONE));
- }
-}
-
-static qid_t
-arg_qid (int arg_number)
-{
- unsigned int qid = (arg_index_integer (arg_number, (QID_MAX + 1)));
- if (!OS2_qid_openp (qid))
- error_bad_range_arg (arg_number);
- return (qid);
-}
-
-DEFINE_PRIMITIVE ("OS2-SELECT-DESCRIPTOR", Prim_OS2_select_descriptor, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- switch (OS2_message_availablep ((arg_qid (1)), (BOOLEAN_ARG (2))))
- {
- case mat_available:
- PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (0));
- case mat_not_available:
- PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (1));
- case mat_interrupt:
- if (OS_process_any_status_change ())
- PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (3));
- else
- PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (2));
- default:
- error_external_return ();
- PRIMITIVE_RETURN (UNSPECIFIC);
- }
-}
-\f
-DEFINE_PRIMITIVE ("OS2-SELECT-REGISTRY-TEST", Prim_OS2_select_registry_test, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- CHECK_ARG (1, STRING_P);
- if ((STRING_LENGTH (ARG_REF (1))) != (QID_MAX + 1))
- error_bad_range_arg (1);
- CHECK_ARG (2, STRING_P);
- if ((STRING_LENGTH (ARG_REF (1))) != (QID_MAX + 1))
- error_bad_range_arg (2);
- {
- char * registry = (STRING_POINTER (ARG_REF (1)));
- char * results = (STRING_POINTER (ARG_REF (2)));
- int blockp = (BOOLEAN_ARG (3));
- int inputp = 0;
- int interruptp = 0;
- qid_t qid;
-
- while (1)
- {
- for (qid = 0; (qid <= QID_MAX); qid += 1)
- {
- (results [qid]) = 0;
- if ((registry [qid]) != 0)
- switch (OS2_message_availablep (qid, 0))
- {
- case mat_available:
- inputp = 1;
- (results [qid]) = 1;
- break;
- case mat_interrupt:
- interruptp = 1;
- break;
- }
- }
- if ((!blockp) || inputp || interruptp)
- break;
- if ((OS2_scheme_tqueue_block ()) == mat_interrupt)
- interruptp = 1;
- }
- if (inputp)
- PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (0));
- else if (!interruptp)
- PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (1));
- else if (!OS_process_any_status_change ())
- PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (2));
- else
- PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (3));
- }
-}
-\f
-#define PROCESS_CHANNEL_ARG(arg, type, channel) \
-{ \
- if ((ARG_REF (arg)) == SHARP_F) \
- (type) = process_channel_type_none; \
- else if ((ARG_REF (arg)) == (LONG_TO_FIXNUM (-1))) \
- (type) = process_channel_type_inherit; \
- else \
- { \
- (type) = process_channel_type_explicit; \
- (channel) = (arg_channel (arg)); \
- } \
-}
-
-DEFINE_PRIMITIVE ("OS2-MAKE-SUBPROCESS", Prim_OS2_make_subprocess, 7, 7,
- "(FILENAME CMD-LINE ENV WORK-DIR STDIN STDOUT STDERR)\n\
-Create a subprocess.\n\
-FILENAME is the program to run.\n\
-CMD-LINE a string containing the program's invocation.\n\
-ENV is a string to pass as the program's environment;\n\
- #F means inherit Scheme's environment.\n\
-WORK-DIR is a string to pass as the program's working directory;\n\
- #F means inherit Scheme's working directory.\n\
-STDIN is the input channel for the subprocess.\n\
-STDOUT is the output channel for the subprocess.\n\
-STDERR is the error channel for the subprocess.\n\
- Each channel arg can take these values:\n\
- #F means none;\n\
- -1 means use the corresponding channel from Scheme;\n\
- otherwise the argument must be a channel.")
-{
- PRIMITIVE_HEADER (7);
- {
- const char * filename = (STRING_ARG (1));
- const char * command_line = (STRING_ARG (2));
- const char * env = (((ARG_REF (3)) == SHARP_F) ? 0 : (STRING_ARG (3)));
- const char * working_directory
- = (((ARG_REF (4)) == SHARP_F) ? 0 : (STRING_ARG (4)));
- enum process_channel_type channel_in_type;
- Tchannel channel_in;
- enum process_channel_type channel_out_type;
- Tchannel channel_out;
- enum process_channel_type channel_err_type;
- Tchannel channel_err;
-
- PROCESS_CHANNEL_ARG (5, channel_in_type, channel_in);
- PROCESS_CHANNEL_ARG (6, channel_out_type, channel_out);
- PROCESS_CHANNEL_ARG (7, channel_err_type, channel_err);
- PRIMITIVE_RETURN
- (long_to_integer
- (OS2_make_subprocess
- (filename, command_line, env, working_directory,
- channel_in_type, channel_in,
- channel_out_type, channel_out,
- channel_err_type, channel_err)));
- }
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#include "scheme.h"
-#include "prims.h"
-#define INCL_WIN
-#define INCL_GPI
-#include "os2.h"
-
-static PPOINTL coordinate_vector_point_args
- (unsigned int, unsigned int, unsigned long *);
-\f
-static qid_t pm_qid;
-
-static qid_t
-qid_argument (unsigned int arg_number)
-{
- unsigned int qid = (arg_index_integer (arg_number, (QID_MAX + 1)));
- if (! ((OS2_qid_openp (qid)) && ((OS2_qid_twin (qid)) != QID_NONE)))
- error_bad_range_arg (arg_number);
- return (qid);
-}
-
-static psid_t
-psid_argument (unsigned int arg_number)
-{
- unsigned long result = (arg_ulong_integer (arg_number));
- if (!OS2_psid_validp (result))
- error_bad_range_arg (arg_number);
- return (result);
-}
-
-static psid_t
-memory_psid_argument (unsigned int arg_number)
-{
- psid_t psid = (psid_argument (arg_number));
- if (!OS2_memory_ps_p (psid))
- error_bad_range_arg (arg_number);
- return (psid);
-}
-
-static wid_t
-wid_argument (unsigned int arg_number)
-{
- unsigned long result = (arg_ulong_integer (arg_number));
- if (!OS2_wid_validp (result))
- error_bad_range_arg (arg_number);
- return (result);
-}
-
-static bid_t
-bid_argument (unsigned int arg_number)
-{
- unsigned long result = (arg_ulong_integer (arg_number));
- if (!OS2_bid_validp (result))
- error_bad_range_arg (arg_number);
- return (result);
-}
-
-static short
-short_arg (unsigned int arg_number)
-{
- long result = (arg_integer (arg_number));
- if (! ((-32768 <= result) && (result < 32768)))
- error_bad_range_arg (arg_number);
- return (result);
-}
-
-#define SSHORT_ARG short_arg
-#define USHORT_ARG(n) arg_index_integer ((n), 0x10000)
-
-static unsigned short
-dimension_arg (unsigned int arg_number)
-{
- unsigned short result = (USHORT_ARG (arg_number));
- if (result == 0)
- error_bad_range_arg (arg_number);
- return (result);
-}
-
-#define COORDINATE_ARG SSHORT_ARG
-#define DIMENSION_ARG dimension_arg
-#define HWND_ARG(n) ((HWND) (arg_ulong_integer (n)))
-
-void
-OS2_initialize_window_primitives (void)
-{
- pm_qid = (OS2_create_pm_qid (OS2_scheme_tqueue));
-}
-
-DEFINE_PRIMITIVE ("OS2WIN-ALARM", Prim_OS2_window_alarm, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- PRIMITIVE_RETURN
- (BOOLEAN_TO_OBJECT (WinAlarm (HWND_DESKTOP, (arg_ulong_integer (1)))));
-}
-
-DEFINE_PRIMITIVE ("OS2WIN-BEEP", Prim_OS2_window_beep, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- DosBeep ((arg_ulong_integer (1)), (arg_ulong_integer (2)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("OS2PM-SYNCHRONIZE", Prim_OS2_pm_synchronize, 0, 0, 0)
-{
- PRIMITIVE_HEADER (0);
- OS2_pm_synchronize (pm_qid);
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("OS2WIN-OPEN", Prim_OS2_window_open, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- PRIMITIVE_RETURN
- (ulong_to_integer (OS2_window_open (pm_qid,
- (OS2_qid_twin (qid_argument (1))),
- (FCF_TITLEBAR | FCF_SYSMENU
- | FCF_SHELLPOSITION | FCF_SIZEBORDER
- | FCF_MINMAX | FCF_TASKLIST
- | FCF_NOBYTEALIGN),
- NULLHANDLE,
- 1,
- 0,
- (STRING_ARG (2)))));
-}
-
-DEFINE_PRIMITIVE ("OS2WIN-CLOSE", Prim_OS2_window_close, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- OS2_window_close (wid_argument (1));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("OS2WIN-SHOW", Prim_OS2_window_show, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- OS2_window_show ((wid_argument (1)), (BOOLEAN_ARG (2)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("OS2WIN-MOVE-CURSOR", Prim_OS2_window_move_cursor, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- OS2_window_move_cursor ((wid_argument (1)),
- (COORDINATE_ARG (2)),
- (COORDINATE_ARG (3)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("OS2WIN-SHAPE-CURSOR", Prim_OS2_window_shape_cursor, 4, 4, 0)
-{
- PRIMITIVE_HEADER (4);
- OS2_window_shape_cursor ((wid_argument (1)),
- (DIMENSION_ARG (2)),
- (DIMENSION_ARG (3)),
- (USHORT_ARG (4)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("OS2WIN-SHOW-CURSOR", Prim_OS2_window_show_cursor, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- OS2_window_show_cursor ((wid_argument (1)), (BOOLEAN_ARG (2)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("OS2WIN-SCROLL", Prim_OS2_window_scroll, 7, 7, 0)
-{
- PRIMITIVE_HEADER (7);
- OS2_window_scroll ((wid_argument (1)),
- (COORDINATE_ARG (2)),
- (COORDINATE_ARG (3)),
- (COORDINATE_ARG (4)),
- (COORDINATE_ARG (5)),
- (SSHORT_ARG (6)),
- (SSHORT_ARG (7)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("OS2WIN-INVALIDATE", Prim_OS2_window_invalidate, 5, 5, 0)
-{
- PRIMITIVE_HEADER (5);
- OS2_window_invalidate ((wid_argument (1)),
- (COORDINATE_ARG (2)),
- (COORDINATE_ARG (3)),
- (COORDINATE_ARG (4)),
- (COORDINATE_ARG (5)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("OS2WIN-SET-GRID", Prim_OS2_window_set_grid, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- OS2_window_set_grid ((wid_argument (1)),
- (DIMENSION_ARG (2)),
- (DIMENSION_ARG (3)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("OS2WIN-ACTIVATE", Prim_OS2_window_activate, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- OS2_window_activate (wid_argument (1));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("OS2WIN-GET-POS", Prim_OS2_window_get_pos, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- {
- SCHEME_OBJECT p = (cons (SHARP_F, SHARP_F));
- short x;
- short y;
- OS2_window_pos ((wid_argument (1)), (& x), (& y));
- SET_PAIR_CAR (p, (LONG_TO_FIXNUM (x)));
- SET_PAIR_CDR (p, (LONG_TO_FIXNUM (y)));
- PRIMITIVE_RETURN (p);
- }
-}
-
-DEFINE_PRIMITIVE ("OS2WIN-SET-POS", Prim_OS2_window_set_pos, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- OS2_window_set_pos ((wid_argument (1)), (SSHORT_ARG (2)), (SSHORT_ARG (3)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("OS2WIN-GET-SIZE", Prim_OS2_window_get_size, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- {
- SCHEME_OBJECT p = (cons (SHARP_F, SHARP_F));
- unsigned short width;
- unsigned short height;
- OS2_window_size ((wid_argument (1)), (& width), (& height));
- SET_PAIR_CAR (p, (LONG_TO_UNSIGNED_FIXNUM (width)));
- SET_PAIR_CDR (p, (LONG_TO_UNSIGNED_FIXNUM (height)));
- PRIMITIVE_RETURN (p);
- }
-}
-
-DEFINE_PRIMITIVE ("OS2WIN-GET-FRAME-SIZE", Prim_OS2_window_get_frame_size, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- {
- SCHEME_OBJECT p = (cons (SHARP_F, SHARP_F));
- unsigned short width;
- unsigned short height;
- OS2_window_frame_size ((wid_argument (1)), (& width), (& height));
- SET_PAIR_CAR (p, (LONG_TO_UNSIGNED_FIXNUM (width)));
- SET_PAIR_CDR (p, (LONG_TO_UNSIGNED_FIXNUM (height)));
- PRIMITIVE_RETURN (p);
- }
-}
-
-DEFINE_PRIMITIVE ("OS2WIN-SET-SIZE", Prim_OS2_window_set_size, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- OS2_window_set_size ((wid_argument (1)), (USHORT_ARG (2)), (USHORT_ARG (3)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("OS2WIN-FOCUS?", Prim_OS2_window_focusp, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (OS2_window_focusp (wid_argument (1))));
-}
-
-DEFINE_PRIMITIVE ("OS2WIN-SET-STATE", Prim_OS2_window_set_state, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- OS2_window_set_state
- ((wid_argument (1)),
- ((window_state_t) (arg_index_integer (2, ((long) state_supremum)))));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("OS2WIN-SET-TITLE", Prim_OS2_window_set_title, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- OS2_window_set_title ((wid_argument (1)), (STRING_ARG (2)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("OS2WIN-TRACK-MOUSE", Prim_OS2_window_track_mouse, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- OS2_window_mousetrack ((wid_argument (1)), (BOOLEAN_ARG (2)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("OS2WIN-FRAME-HANDLE", Prim_OS2_window_frame_handle, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- PRIMITIVE_RETURN
- (ulong_to_integer (OS2_window_frame_handle (wid_argument (1))));
-}
-
-DEFINE_PRIMITIVE ("OS2WIN-CLIENT-HANDLE", Prim_OS2_window_client_handle, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- PRIMITIVE_RETURN
- (ulong_to_integer (OS2_window_client_handle (wid_argument (1))));
-}
-
-DEFINE_PRIMITIVE ("OS2WIN-UPDATE-FRAME", Prim_OS2_window_update_frame, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- OS2_window_update_frame ((wid_argument (1)), (USHORT_ARG (2)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("OS2-WINDOW-HANDLE-FROM-ID", Prim_OS2_window_handle_from_id, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- PRIMITIVE_RETURN
- (ulong_to_integer (OS2_window_handle_from_id (pm_qid,
- (arg_ulong_integer (1)),
- (arg_ulong_integer (2)))));
-}
-
-DEFINE_PRIMITIVE ("OS2WIN-QUERY-SYS-VALUE", Prim_OS2_window_query_sys_value, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- PRIMITIVE_RETURN
- (ulong_to_integer (OS2_window_query_sys_value (pm_qid,
- (HWND_ARG (1)),
- (arg_integer (2)))));
-}
-
-DEFINE_PRIMITIVE ("OS2-MAP-WINDOW-POINT", Prim_OS2_map_window_point, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- {
- SCHEME_OBJECT scheme_point;
- POINTL point;
- BOOL rc;
-
- CHECK_ARG (3, PAIR_P);
- scheme_point = (ARG_REF (3));
- if ((!INTEGER_P (PAIR_CAR (scheme_point)))
- || (!INTEGER_P (PAIR_CDR (scheme_point))))
- error_wrong_type_arg (3);
- if ((!integer_to_long_p (PAIR_CAR (scheme_point)))
- || (!integer_to_long_p (PAIR_CDR (scheme_point))))
- error_bad_range_arg (3);
- (point . x) = (integer_to_long (PAIR_CAR (scheme_point)));
- (point . y) = (integer_to_long (PAIR_CDR (scheme_point)));
- rc = (WinMapWindowPoints ((HWND_ARG (1)), (HWND_ARG (2)), (&point), 1));
- if (rc)
- {
- SET_PAIR_CAR (scheme_point, (long_to_integer (point . x)));
- SET_PAIR_CDR (scheme_point, (long_to_integer (point . y)));
- }
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (rc));
- }
-}
-
-DEFINE_PRIMITIVE ("OS2WIN-SET-CAPTURE", PRIM_OS2_WINDOW_SET_CAPTURE, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- PRIMITIVE_RETURN
- (BOOLEAN_TO_OBJECT
- (OS2_window_set_capture ((wid_argument (1)), (BOOLEAN_ARG (2)))));
-}
-\f
-DEFINE_PRIMITIVE ("OS2WIN-PS", Prim_OS2_window_ps, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- PRIMITIVE_RETURN
- (ulong_to_integer (OS2_window_client_ps (wid_argument (1))));
-}
-
-DEFINE_PRIMITIVE ("OS2PS-CREATE-MEMORY-PS", Prim_OS2_create_memory_ps, 0, 0, 0)
-{
- PRIMITIVE_HEADER (0);
- PRIMITIVE_RETURN (ulong_to_integer (OS2_create_memory_ps (pm_qid)));
-}
-
-DEFINE_PRIMITIVE ("OS2PS-DESTROY-MEMORY-PS", Prim_OS2_destroy_memory_ps, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- OS2_destroy_memory_ps (memory_psid_argument (1));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("OS2PS-CREATE-BITMAP", Prim_OS2_create_bitmap, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- PRIMITIVE_RETURN
- (ulong_to_integer (OS2_create_bitmap ((psid_argument (1)),
- (USHORT_ARG (2)),
- (USHORT_ARG (3)))));
-}
-
-DEFINE_PRIMITIVE ("OS2PS-DESTROY-BITMAP", Prim_OS2_destroy_bitmap, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- OS2_destroy_bitmap (bid_argument (1));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("OS2PS-GET-BITMAP", Prim_OS2_ps_get_bitmap, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- {
- bid_t bid = (OS2_ps_get_bitmap ((memory_psid_argument (1))));
- PRIMITIVE_RETURN ((bid == BID_NONE) ? SHARP_F : (ulong_to_integer (bid)));
- }
-}
-
-DEFINE_PRIMITIVE ("OS2PS-SET-BITMAP", Prim_OS2_ps_set_bitmap, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- {
- bid_t bid
- = (OS2_ps_set_bitmap
- ((memory_psid_argument (1)),
- (((ARG_REF (2)) == SHARP_F) ? BID_NONE : (bid_argument (2)))));
- PRIMITIVE_RETURN ((bid == BID_NONE) ? SHARP_F : (ulong_to_integer (bid)));
- }
-}
-
-DEFINE_PRIMITIVE ("OS2PS-BITBLT", Prim_OS2_ps_bitblt, 6, 6, 0)
-{
- PRIMITIVE_HEADER (6);
- {
- void * position = dstack_position;
- psid_t target = (psid_argument (1));
- psid_t source = (psid_argument (2));
- unsigned long npoints;
- PPOINTL points = (coordinate_vector_point_args (3, 4, (& npoints)));
- LONG rop = (arg_index_integer (5, 0x100));
- ULONG options = (arg_ulong_integer (6));
- if (! ((npoints == 3) || (npoints == 4)))
- error_bad_range_arg (3);
- OS2_ps_bitblt (target, source, npoints, points, rop, options);
- dstack_set_position (position);
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("OS2PS-WRITE", Prim_OS2_ps_write, 6, 6, 0)
-{
- PRIMITIVE_HEADER (6);
- CHECK_ARG (4, STRING_P);
- {
- SCHEME_OBJECT string = (ARG_REF (4));
- unsigned long start = (arg_ulong_integer (5));
- unsigned long end = (arg_ulong_integer (6));
- if (end > (STRING_LENGTH (string)))
- error_bad_range_arg (6);
- if (start > end)
- error_bad_range_arg (5);
- OS2_ps_draw_text ((psid_argument (1)),
- (COORDINATE_ARG (2)),
- (COORDINATE_ARG (3)),
- (STRING_LOC (string, start)),
- (end - start));
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("OS2PS-TEXT-WIDTH", Prim_OS2_ps_text_width, 4, 4, 0)
-{
- PRIMITIVE_HEADER (4);
- CHECK_ARG (2, STRING_P);
- {
- SCHEME_OBJECT string = (ARG_REF (2));
- unsigned long start = (arg_ulong_integer (3));
- unsigned long end = (arg_ulong_integer (4));
- if (end > (STRING_LENGTH (string)))
- error_bad_range_arg (4);
- if (start > end)
- error_bad_range_arg (3);
- PRIMITIVE_RETURN
- (ulong_to_integer
- (OS2_ps_text_width ((psid_argument (1)),
- (STRING_LOC (string, start)),
- (end - start))));
- }
-}
-
-static SCHEME_OBJECT
-convert_font_metrics (font_metrics_t * m)
-{
- if (m == 0)
- return (SHARP_F);
- else
- {
- SCHEME_OBJECT v = (allocate_marked_vector (TC_VECTOR, 3, 1));
- VECTOR_SET (v, 0, (ulong_to_integer (FONT_METRICS_WIDTH (m))));
- VECTOR_SET (v, 1, (ulong_to_integer (FONT_METRICS_HEIGHT (m))));
- VECTOR_SET (v, 2, (ulong_to_integer (FONT_METRICS_DESCENDER (m))));
- OS_free (m);
- return (v);
- }
-}
-
-DEFINE_PRIMITIVE ("OS2PS-GET-FONT-METRICS", Prim_OS2_ps_get_font_metrics, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- PRIMITIVE_RETURN
- (convert_font_metrics (OS2_ps_get_font_metrics (psid_argument (1))));
-}
-
-DEFINE_PRIMITIVE ("OS2PS-SET-FONT", Prim_OS2_ps_set_font, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- PRIMITIVE_RETURN
- (convert_font_metrics (OS2_ps_set_font ((psid_argument (1)),
- (USHORT_ARG (2)),
- (STRING_ARG (3)))));
-}
-
-DEFINE_PRIMITIVE ("OS2PS-CLEAR", Prim_OS2_ps_clear, 5, 5, 0)
-{
- PRIMITIVE_HEADER (5);
- OS2_ps_clear ((psid_argument (1)),
- (COORDINATE_ARG (2)),
- (COORDINATE_ARG (3)),
- (COORDINATE_ARG (4)),
- (COORDINATE_ARG (5)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("OS2PS-SET-COLORS", Prim_OS2_ps_set_colors, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- OS2_ps_set_colors ((psid_argument (1)),
- (arg_index_integer (2, 0x1000000)),
- (arg_index_integer (3, 0x1000000)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("OS2PS-MOVE-GRAPHICS-CURSOR", Prim_OS2_ps_move_gcursor, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- OS2_ps_move_gcursor ((psid_argument (1)),
- (COORDINATE_ARG (2)),
- (COORDINATE_ARG (3)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("OS2PS-LINE", Prim_OS2_ps_line, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- OS2_ps_draw_line ((psid_argument (1)),
- (COORDINATE_ARG (2)),
- (COORDINATE_ARG (3)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("OS2PS-DRAW-POINT", Prim_OS2_ps_draw_point, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- OS2_ps_draw_point ((psid_argument (1)),
- (COORDINATE_ARG (2)),
- (COORDINATE_ARG (3)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("OS2PS-POLY-LINE", Prim_OS2_ps_poly_line, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- {
- void * position = dstack_position;
- unsigned long npoints;
- PPOINTL points = (coordinate_vector_point_args (2, 3, (& npoints)));
- OS2_ps_poly_line ((psid_argument (1)),
- npoints,
- points);
- dstack_set_position (position);
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("OS2PS-POLY-LINE-DISJOINT", Prim_OS2_ps_poly_line_disjoint, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- {
- void * position = dstack_position;
- unsigned long npoints;
- PPOINTL points = (coordinate_vector_point_args (2, 3, (& npoints)));
- OS2_ps_poly_line_disjoint ((psid_argument (1)),
- npoints,
- points);
- dstack_set_position (position);
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-static PPOINTL
-coordinate_vector_point_args (unsigned int x_no, unsigned int y_no,
- unsigned long * npoints)
-{
- SCHEME_OBJECT x_vector = (ARG_REF (x_no));
- SCHEME_OBJECT y_vector = (ARG_REF (y_no));
- if (!VECTOR_P (x_vector))
- error_wrong_type_arg (x_no);
- if (!VECTOR_P (y_vector))
- error_wrong_type_arg (y_no);
- {
- unsigned long length = (VECTOR_LENGTH (x_vector));
- if (length != (VECTOR_LENGTH (y_vector)))
- error_bad_range_arg (x_no);
- {
- SCHEME_OBJECT * scan_x = (VECTOR_LOC (x_vector, 0));
- SCHEME_OBJECT * end_x = (VECTOR_LOC (x_vector, length));
- SCHEME_OBJECT * scan_y = (VECTOR_LOC (y_vector, 0));
- PPOINTL points = (dstack_alloc (length * (sizeof (POINTL))));
- PPOINTL scan_points = points;
- while (scan_x < end_x)
- {
- SCHEME_OBJECT x = (*scan_x++);
- SCHEME_OBJECT y = (*scan_y++);
- if (!FIXNUM_P (x))
- error_bad_range_arg (x_no);
- if (!FIXNUM_P (y))
- error_bad_range_arg (y_no);
- (scan_points -> x) = (FIXNUM_TO_LONG (x));
- (scan_points -> y) = (FIXNUM_TO_LONG (y));
- scan_points += 1;
- }
- (* npoints) = length;
- return (points);
- }
- }
-}
-
-DEFINE_PRIMITIVE ("OS2PS-SET-LINE-TYPE", Prim_OS2_ps_set_line_type, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- OS2_ps_set_line_type ((psid_argument (1)), (arg_index_integer (2, 10)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("OS2PS-SET-MIX", Prim_OS2_ps_set_mix, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- OS2_ps_set_mix ((psid_argument (1)), (arg_index_integer (2, 18)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("OS2PS-QUERY-CAPABILITIES", Prim_OS2_ps_query_caps, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- {
- LONG count = (arg_nonnegative_integer (3));
- PLONG values = (OS_malloc (count * (sizeof (LONG))));
- OS2_ps_query_caps ((psid_argument (1)),
- (arg_nonnegative_integer (2)),
- count,
- values);
- {
- SCHEME_OBJECT v = (allocate_marked_vector (TC_VECTOR, count, 1));
- LONG index = 0;
- while (index < count)
- {
- VECTOR_SET (v, index, (long_to_integer (values [index])));
- index += 1;
- }
- OS_free (values);
- PRIMITIVE_RETURN (v);
- }
- }
-}
-
-DEFINE_PRIMITIVE ("OS2PS-QUERY-CAPABILITY", Prim_OS2_ps_query_cap, 2, 2, 0)
-{
- LONG values [1];
- PRIMITIVE_HEADER (2);
- OS2_ps_query_caps ((psid_argument (1)),
- (arg_nonnegative_integer (2)),
- 1,
- values);
- PRIMITIVE_RETURN (long_to_integer (values [0]));
-}
-
-DEFINE_PRIMITIVE ("OS2PS-RESET-CLIP-RECTANGLE", Prim_OS2_ps_reset_clip_rectangle, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- OS2_ps_reset_clip_rectangle (psid_argument (1));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("OS2PS-SET-CLIP-RECTANGLE", Prim_OS2_ps_set_clip_rectangle, 5, 5, 0)
-{
- PRIMITIVE_HEADER (5);
- OS2_ps_set_clip_rectangle ((psid_argument (1)),
- (COORDINATE_ARG (2)),
- (COORDINATE_ARG (3)),
- (COORDINATE_ARG (4)),
- (COORDINATE_ARG (5)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("OS2PS-GET-BITMAP-PARAMETERS", Prim_OS2_ps_get_bitmap_parameters, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- {
- SCHEME_OBJECT s = (allocate_string (sizeof (BITMAPINFOHEADER)));
- PBITMAPINFOHEADER params = ((PBITMAPINFOHEADER) (STRING_POINTER (s)));
- (params -> cbFix) = (sizeof (BITMAPINFOHEADER));
- OS2_get_bitmap_parameters ((bid_argument (1)), params);
- PRIMITIVE_RETURN (s);
- }
-}
-
-DEFINE_PRIMITIVE ("OS2PS-GET-BITMAP-BITS", Prim_OS2_ps_get_bitmap_bits, 5, 5, 0)
-{
- PRIMITIVE_HEADER (5);
- PRIMITIVE_RETURN
- (ulong_to_integer
- (OS2_ps_get_bitmap_bits ((memory_psid_argument (1)),
- (arg_ulong_integer (2)),
- (arg_ulong_integer (3)),
- (STRING_ARG (4)),
- ((void *) (STRING_ARG (5))))));
-}
-
-DEFINE_PRIMITIVE ("OS2PS-SET-BITMAP-BITS", Prim_OS2_ps_set_bitmap_bits, 5, 5, 0)
-{
- PRIMITIVE_HEADER (5);
- PRIMITIVE_RETURN
- (ulong_to_integer
- (OS2_ps_set_bitmap_bits ((memory_psid_argument (1)),
- (arg_ulong_integer (2)),
- (arg_ulong_integer (3)),
- (STRING_ARG (4)),
- ((void *) (STRING_ARG (5))))));
-}
-\f
-DEFINE_PRIMITIVE ("OS2-CLIPBOARD-WRITE-TEXT", Prim_OS2_clipboard_write_text, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- OS2_clipboard_write_text (pm_qid, (STRING_ARG (1)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("OS2-CLIPBOARD-READ-TEXT", Prim_OS2_clipboard_read_text, 0, 0, 0)
-{
- PRIMITIVE_HEADER (0);
- {
- const char * text = (OS2_clipboard_read_text (pm_qid));
- SCHEME_OBJECT result;
- if (text == 0)
- result = SHARP_F;
- else
- {
- result = (char_pointer_to_string (text));
- OS_free ((void *) text);
- }
- PRIMITIVE_RETURN (result);
- }
-}
-\f
-DEFINE_PRIMITIVE ("OS2MENU-CREATE", Prim_OS2_menu_create, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- PRIMITIVE_RETURN
- (ulong_to_integer (OS2_menu_create (pm_qid,
- (HWND_ARG (1)),
- (USHORT_ARG (2)),
- (USHORT_ARG (3)))));
-}
-
-DEFINE_PRIMITIVE ("OS2MENU-DESTROY", Prim_OS2_menu_destroy, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- OS2_menu_destroy (pm_qid, (HWND_ARG (1)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("OS2MENU-INSERT-ITEM", Prim_OS2_menu_insert_item, 7, 7, 0)
-{
- PRIMITIVE_HEADER (7);
- PRIMITIVE_RETURN
- (ulong_to_integer (OS2_menu_insert_item (pm_qid,
- (HWND_ARG (1)),
- (USHORT_ARG (2)),
- (USHORT_ARG (3)),
- (USHORT_ARG (4)),
- (USHORT_ARG (5)),
- (HWND_ARG (6)),
- (STRING_ARG (7)))));
-}
-
-DEFINE_PRIMITIVE ("OS2MENU-REMOVE-ITEM", Prim_OS2_menu_remove_item, 4, 4, 0)
-{
- PRIMITIVE_HEADER (4);
- PRIMITIVE_RETURN
- (ulong_to_integer (OS2_menu_remove_item (pm_qid,
- (HWND_ARG (1)),
- (USHORT_ARG (2)),
- (BOOLEAN_ARG (3)),
- (BOOLEAN_ARG (4)))));
-}
-
-DEFINE_PRIMITIVE ("OS2MENU-GET-ITEM", Prim_OS2_menu_get_item, 3, 3, 0)
-{
- PMENUITEM item;
- SCHEME_OBJECT result;
- PRIMITIVE_HEADER (3);
-
- item = (OS2_menu_get_item (pm_qid,
- (HWND_ARG (1)),
- (USHORT_ARG (2)),
- (BOOLEAN_ARG (3))));
- if (item == 0)
- PRIMITIVE_RETURN (SHARP_F);
- result = (allocate_marked_vector (TC_VECTOR, 6, 1));
- VECTOR_SET (result, 0, (long_to_integer (item -> iPosition)));
- VECTOR_SET (result, 1, (ulong_to_integer (item -> afStyle)));
- VECTOR_SET (result, 2, (ulong_to_integer (item -> afAttribute)));
- VECTOR_SET (result, 3, (ulong_to_integer (item -> id)));
- VECTOR_SET (result, 4, (ulong_to_integer (item -> hwndSubMenu)));
- VECTOR_SET (result, 5, (ulong_to_integer (item -> hItem)));
- OS_free (item);
- PRIMITIVE_RETURN (result);
-}
-
-DEFINE_PRIMITIVE ("OS2MENU-N-ITEMS", Prim_OS2_menu_n_items, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- PRIMITIVE_RETURN
- (ulong_to_integer (OS2_menu_n_items (pm_qid, (HWND_ARG (1)))));
-}
-
-DEFINE_PRIMITIVE ("OS2MENU-NTH-ITEM-ID", Prim_OS2_menu_nth_item_id, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- PRIMITIVE_RETURN
- (ulong_to_integer (OS2_menu_nth_item_id (pm_qid,
- (HWND_ARG (1)),
- (USHORT_ARG (2)))));
-}
-
-DEFINE_PRIMITIVE ("OS2MENU-GET-ITEM-ATTRIBUTES", Prim_OS2_menu_get_item_attributes, 4, 4, 0)
-{
- PRIMITIVE_HEADER (4);
- PRIMITIVE_RETURN
- (ulong_to_integer (OS2_menu_get_item_attributes (pm_qid,
- (HWND_ARG (1)),
- (USHORT_ARG (2)),
- (BOOLEAN_ARG (3)),
- (USHORT_ARG (4)))));
-}
-
-DEFINE_PRIMITIVE ("OS2MENU-SET-ITEM-ATTRIBUTES", Prim_OS2_menu_set_item_attributes, 5, 5, 0)
-{
- PRIMITIVE_HEADER (5);
- PRIMITIVE_RETURN
- (BOOLEAN_TO_OBJECT (OS2_menu_set_item_attributes (pm_qid,
- (HWND_ARG (1)),
- (USHORT_ARG (2)),
- (BOOLEAN_ARG (3)),
- (USHORT_ARG (4)),
- (USHORT_ARG (5)))));
-}
-
-DEFINE_PRIMITIVE ("OS2WIN-LOAD-MENU", Prim_OS2_window_load_menu, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- PRIMITIVE_RETURN
- (ulong_to_integer (OS2_window_load_menu ((wid_argument (1)),
- (arg_ulong_integer (2)),
- (arg_ulong_integer (3)))));
-}
-
-DEFINE_PRIMITIVE ("OS2WIN-POPUP-MENU", Prim_OS2_window_popup_menu, 7, 7, 0)
-{
- PRIMITIVE_HEADER (7);
- PRIMITIVE_RETURN
- (BOOLEAN_TO_OBJECT
- (OS2_window_popup_menu (pm_qid,
- (HWND_ARG (1)),
- (HWND_ARG (2)),
- (HWND_ARG (3)),
- (arg_integer (4)),
- (arg_integer (5)),
- (arg_integer (6)),
- (arg_ulong_integer (7)))));
-}
-
-DEFINE_PRIMITIVE ("OS2WIN-FONT-DIALOG", Prim_OS2_window_font_dialog, 2, 2, 0)
-{
- const char * spec;
- SCHEME_OBJECT result;
- PRIMITIVE_HEADER (2);
-
- spec = (OS2_window_font_dialog ((wid_argument (1)),
- (((ARG_REF (2)) == SHARP_F)
- ? 0
- : (STRING_ARG (2)))));
- if (spec == 0)
- PRIMITIVE_RETURN (SHARP_F);
- result = (char_pointer_to_string (spec));
- OS_free ((void *) spec);
- PRIMITIVE_RETURN (result);
-}
-\f
-DEFINE_PRIMITIVE ("OS2-QUERY-SYSTEM-POINTER", Prim_OS2_query_system_pointer, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- PRIMITIVE_RETURN
- (ulong_to_integer (OS2_query_system_pointer (pm_qid,
- (HWND_ARG (1)),
- (arg_integer (2)),
- (BOOLEAN_ARG (3)))));
-}
-
-DEFINE_PRIMITIVE ("OS2-SET-POINTER", Prim_OS2_set_pointer, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- PRIMITIVE_RETURN
- (BOOLEAN_TO_OBJECT (OS2_set_pointer (pm_qid,
- (HWND_ARG (1)),
- (arg_ulong_integer (2)))));
-}
-
-DEFINE_PRIMITIVE ("OS2WIN-LOAD-POINTER", Prim_OS2_window_load_pointer, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- PRIMITIVE_RETURN
- (ulong_to_integer (OS2_window_load_pointer (pm_qid,
- (HWND_ARG (1)),
- (arg_ulong_integer (2)),
- (arg_ulong_integer (3)))));
-}
-
-DEFINE_PRIMITIVE ("OS2WIN-DESTROY-POINTER", Prim_OS2_window_destroy_pointer, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- PRIMITIVE_RETURN
- (BOOLEAN_TO_OBJECT (OS2_window_destroy_pointer (pm_qid,
- (arg_ulong_integer (1)))));
-}
-
-DEFINE_PRIMITIVE ("OS2WIN-SET-ICON", Prim_OS2_window_set_icon, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- PRIMITIVE_RETURN
- (BOOLEAN_TO_OBJECT
- (OS2_window_set_icon ((wid_argument (1)), (arg_ulong_integer (2)))));
-}
-\f
-DEFINE_PRIMITIVE ("OS2WIN-OPEN-EVENT-QID", Prim_OS2_window_open_event_qid, 0, 0, 0)
-{
- qid_t local;
- qid_t remote;
- PRIMITIVE_HEADER (0);
- OS2_make_qid_pair ((&local), (&remote));
- OS2_open_qid (local, OS2_scheme_tqueue);
- PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (local));
-}
-
-DEFINE_PRIMITIVE ("OS2WIN-CLOSE-EVENT-QID", Prim_OS2_window_close_event_qid, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- OS2_close_qid_pair (qid_argument (1));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-#define ET_BUTTON 0
-#define ET_CLOSE 1
-#define ET_FOCUS 2
-#define ET_KEY 3
-#define ET_PAINT 4
-#define ET_RESIZE 5
-#define ET_VISIBILITY 6
-#define ET_COMMAND 7
-#define ET_HELP 8
-#define ET_MOUSEMOVE 9
-
-#define CVT_USHORT(n, v) \
- VECTOR_SET (result, n, (LONG_TO_UNSIGNED_FIXNUM (v)))
-#define CVT_SHORT(n, v) \
- VECTOR_SET (result, n, (LONG_TO_FIXNUM (v)))
-#define CVT_BOOLEAN(n, v) \
- VECTOR_SET (result, n, (BOOLEAN_TO_OBJECT (v)))
-
-static SCHEME_OBJECT make_button_event
- (wid_t, MPARAM, MPARAM, unsigned short, unsigned short);
-
-DEFINE_PRIMITIVE ("OS2WIN-GET-EVENT", Prim_OS2_window_get_event, 2, 2, 0)
-{
- qid_t qid;
- int blockp;
- PRIMITIVE_HEADER (2);
-
- qid = (qid_argument (1));
- blockp = (BOOLEAN_ARG (2));
- Primitive_GC_If_Needed (8);
- while (1)
- {
- msg_t * message = (OS2_receive_message (qid, blockp, 1));
- SCHEME_OBJECT result = SHARP_F;
- if (message == 0)
- PRIMITIVE_RETURN (result);
- switch (MSG_TYPE (message))
- {
- case mt_pm_event:
- {
- wid_t wid = (SM_PM_EVENT_WID (message));
- ULONG msg = (SM_PM_EVENT_MSG (message));
- MPARAM mp1 = (SM_PM_EVENT_MP1 (message));
- MPARAM mp2 = (SM_PM_EVENT_MP2 (message));
- OS2_destroy_message (message);
- switch (msg)
- {
- case WM_SETFOCUS:
- {
- result = (allocate_marked_vector (TC_VECTOR, 3, 0));
- CVT_USHORT (0, ET_FOCUS);
- CVT_USHORT (1, wid);
- CVT_BOOLEAN (2, (SHORT1FROMMP (mp2)));
- break;
- }
- case WM_SIZE:
- {
- result = (allocate_marked_vector (TC_VECTOR, 4, 0));
- CVT_USHORT (0, ET_RESIZE);
- CVT_USHORT (1, wid);
- CVT_USHORT (2, (SHORT1FROMMP (mp2)));
- CVT_USHORT (3, (SHORT2FROMMP (mp2)));
- break;
- }
- case WM_CLOSE:
- {
- result = (allocate_marked_vector (TC_VECTOR, 2, 0));
- CVT_USHORT (0, ET_CLOSE);
- CVT_USHORT (1, wid);
- break;
- }
- case WM_COMMAND:
- case WM_HELP:
- {
- result = (allocate_marked_vector (TC_VECTOR, 5, 0));
- CVT_USHORT (0,
- ((msg == WM_HELP) ? ET_HELP : ET_COMMAND));
- CVT_USHORT (1, wid);
- CVT_USHORT (2, (SHORT1FROMMP (mp1)));
- CVT_USHORT (3, (SHORT1FROMMP (mp2)));
- CVT_BOOLEAN (4, (SHORT2FROMMP (mp2)));
- break;
- }
- case WM_SHOW:
- {
- result = (allocate_marked_vector (TC_VECTOR, 3, 0));
- CVT_USHORT (0, ET_VISIBILITY);
- CVT_USHORT (1, wid);
- CVT_BOOLEAN (2, (SHORT1FROMMP (mp1)));
- break;
- }
- case WM_CHAR:
- {
- unsigned short code;
- unsigned short flags;
- unsigned char repeat;
- if (OS2_translate_wm_char (mp1, mp2,
- (&code), (&flags), (&repeat)))
- {
- result = (allocate_marked_vector (TC_VECTOR, 5, 0));
- CVT_USHORT (0, ET_KEY);
- CVT_USHORT (1, wid);
- CVT_USHORT (2, code);
- CVT_USHORT (3, flags);
- CVT_USHORT (4, repeat);
- }
- break;
- }
- case WM_BUTTON1DOWN:
- result = (make_button_event (wid, mp1, mp2, 0, 0));
- break;
- case WM_BUTTON1UP:
- result = (make_button_event (wid, mp1, mp2, 0, 1));
- break;
- case WM_BUTTON1CLICK:
- result = (make_button_event (wid, mp1, mp2, 0, 2));
- break;
- case WM_BUTTON1DBLCLK:
- result = (make_button_event (wid, mp1, mp2, 0, 3));
- break;
- case WM_BUTTON2DOWN:
- result = (make_button_event (wid, mp1, mp2, 1, 0));
- break;
- case WM_BUTTON2UP:
- result = (make_button_event (wid, mp1, mp2, 1, 1));
- break;
- case WM_BUTTON2CLICK:
- result = (make_button_event (wid, mp1, mp2, 1, 2));
- break;
- case WM_BUTTON2DBLCLK:
- result = (make_button_event (wid, mp1, mp2, 1, 3));
- break;
- case WM_BUTTON3DOWN:
- result = (make_button_event (wid, mp1, mp2, 2, 0));
- break;
- case WM_BUTTON3UP:
- result = (make_button_event (wid, mp1, mp2, 2, 1));
- break;
- case WM_BUTTON3CLICK:
- result = (make_button_event (wid, mp1, mp2, 2, 2));
- break;
- case WM_BUTTON3DBLCLK:
- result = (make_button_event (wid, mp1, mp2, 2, 3));
- break;
- case WM_MOUSEMOVE:
- result = (allocate_marked_vector (TC_VECTOR, 6, 0));
- CVT_USHORT (0, ET_MOUSEMOVE);
- CVT_USHORT (1, wid);
- CVT_SHORT (2, (SHORT1FROMMP (mp1)));
- CVT_SHORT (3, (SHORT2FROMMP (mp1)));
- CVT_USHORT (4, (SHORT1FROMMP (mp2)));
- CVT_USHORT (5, (SHORT2FROMMP (mp2)));
- break;
- default:
- break;
- }
- break;
- }
- case mt_paint_event:
- {
- result = (allocate_marked_vector (TC_VECTOR, 6, 0));
- CVT_USHORT (0, ET_PAINT);
- CVT_USHORT (1, (SM_PAINT_EVENT_WID (message)));
- CVT_USHORT (2, (SM_PAINT_EVENT_XL (message)));
- CVT_USHORT (3, (SM_PAINT_EVENT_XH (message)));
- CVT_USHORT (4, (SM_PAINT_EVENT_YL (message)));
- CVT_USHORT (5, (SM_PAINT_EVENT_YH (message)));
- OS2_destroy_message (message);
- break;
- }
- default:
- OS2_destroy_message (message);
- OS2_error_anonymous ();
- break;
- }
- if (result != SHARP_F)
- PRIMITIVE_RETURN (result);
- }
-}
-
-static SCHEME_OBJECT
-make_button_event (wid_t wid, MPARAM mp1, MPARAM mp2,
- unsigned short number, unsigned short type)
-{
- SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 7, 0));
- CVT_USHORT (0, ET_BUTTON);
- CVT_USHORT (1, wid);
- CVT_USHORT (2, number);
- CVT_USHORT (3, type);
- CVT_SHORT (4, (SHORT1FROMMP (mp1)));
- CVT_SHORT (5, (SHORT2FROMMP (mp1)));
- CVT_USHORT (6, ((SHORT2FROMMP (mp2)) & (KC_SHIFT | KC_CTRL | KC_ALT)));
- return (result);
-}
-
-DEFINE_PRIMITIVE ("OS2WIN-EVENT-READY?", Prim_OS2_window_event_ready, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- switch (OS2_message_availablep ((qid_argument (1)), (BOOLEAN_ARG (2))))
- {
- case mat_available:
- PRIMITIVE_RETURN (SHARP_T);
- case mat_not_available:
- PRIMITIVE_RETURN (SHARP_F);
- case mat_interrupt:
- PRIMITIVE_RETURN (FIXNUM_ZERO);
- }
-}
-
-DEFINE_PRIMITIVE ("OS2WIN-CONSOLE-WID", Prim_OS2_window_console_wid, 0, 0, 0)
-{
- extern wid_t OS2_console_wid (void);
- PRIMITIVE_HEADER (0);
- PRIMITIVE_RETURN (ulong_to_integer (OS2_console_wid ()));
-}
-
-DEFINE_PRIMITIVE ("OS2WIN-DESKTOP-WIDTH", Prim_OS2_window_desktop_width, 0, 0, 0)
-{
- SWP swp;
- PRIMITIVE_HEADER (0);
- WinQueryWindowPos (HWND_DESKTOP, (& swp));
- PRIMITIVE_RETURN (long_to_integer (swp . cx));
-}
-
-DEFINE_PRIMITIVE ("OS2WIN-DESKTOP-HEIGHT", Prim_OS2_window_desktop_height, 0, 0, 0)
-{
- SWP swp;
- PRIMITIVE_HEADER (0);
- WinQueryWindowPos (HWND_DESKTOP, (& swp));
- PRIMITIVE_RETURN (long_to_integer (swp . cy));
-}
"directory",
"unix-character-device",
"unix-block-device",
- "os/2-console",
- "os/2-unnamed-pipe",
- "os/2-named-pipe",
+ "unknown",
+ "unknown",
+ "unknown",
"win32-anonymous-pipe",
"win32-named-pipe"
};
Tchannel channel = (arg_channel (argument_number));
enum channel_type type = (OS_channel_type (channel));
if (! ((type == channel_type_terminal)
- || (type == channel_type_unix_pty_master)
- || (type == channel_type_os2_console)))
+ || (type == channel_type_unix_pty_master)))
error_bad_range_arg (argument_number);
return (channel);
}
# include "ux.h"
#endif
-/* Under OS/2, socket support is the default but can be disabled. */
-#ifdef __OS2__
-# ifndef DISABLE_SOCKET_SUPPORT
-# define HAVE_SOCKETS 1
-# define HAVE_UNIX_SOCKETS 1
-# endif
-#endif
-
/* Under Win32, socket support is the default but can be disabled. */
#ifdef __WIN32__
# ifndef DISABLE_SOCKET_SUPPORT
#include "config.h"
\f
-#ifdef __OS2__
-# define DEFINE_OS2_SYSCALLS
-# include "os2api.h"
-# undef DEFINE_OS2_SYSCALLS
+#ifdef __WIN32__
+# define DEFINE_WIN32_SYSCALLS
+# include "ntapi.h"
+# undef DEFINE_WIN32_SYSCALLS
#else
-# ifdef __WIN32__
-# define DEFINE_WIN32_SYSCALLS
-# include "ntapi.h"
-# undef DEFINE_WIN32_SYSCALLS
-# else
/* Unix case, inline for historical reasons. Must match "uxtop.c". */
syserr_too_many_open_files_in_system
};
-# endif /* not __WIN32__ */
-#endif /* not __OS2__ */
+#endif /* not __WIN32__ */
extern void error_in_system_call (enum syserr_names, enum syscall_names)
NORETURN;
# define USING_MESSAGE_BOX_FOR_FATAL_OUTPUT
#endif
-#ifdef __OS2__
-# define USING_MESSAGE_BOX_FOR_FATAL_OUTPUT
-#endif
-
static void edwin_auto_save (void);
static void delete_temp_files (void);
#include "history.h"
#include "syscall.h"
-#ifdef __OS2__
- extern void OS2_handle_attention_interrupt (void);
-#endif
-
SCHEME_OBJECT * history_register;
unsigned long prev_restore_history_offset;
unsigned long interrupt_mask;
SCHEME_OBJECT interrupt_handler;
-#ifdef __OS2__
- if ((1UL << interrupt_number) == INT_Global_1)
- {
- OS2_handle_attention_interrupt ();
- abort_to_interpreter (PRIM_POP_RETURN);
- }
-#endif
if (!VECTOR_P (fixed_objects))
{
outf_fatal ("\nInvalid fixed-objects vector");
(and (not (equal? directory directory*))
(let ((pathname*
(pathname-new-directory pathname directory*)))
- (if (eq? 'OS/2 microcode-id/operating-system)
- pathname*
- (and ((ucode-primitive file-eq? 2)
- (->namestring pathname)
- (->namestring pathname*))
- pathname*))))))
+ (and ((ucode-primitive file-eq? 2)
+ (->namestring pathname)
+ (->namestring pathname*))
+ pathname*)))))
pathname)))
\ No newline at end of file
("numpar" (runtime number-parser))
("option" (runtime options))
("ordvec" (runtime ordered-vector))
- ("os2ctype" (runtime os2-graphics))
- ("os2dir" (runtime directory))
- ("os2graph" (runtime os2-graphics))
- ("os2prm" (runtime os-primitives))
- ("os2winp" (runtime os2-window-primitives))
("output" (runtime output-port))
("packag" (package))
("parse" (runtime parser))
(define (channel-type=terminal? channel)
(let ((type (channel-type channel)))
(or (eq? 'TERMINAL type)
- (eq? 'UNIX-PTY-MASTER type)
- (eq? 'OS/2-CONSOLE type))))
+ (eq? 'UNIX-PTY-MASTER type))))
(define (channel-close channel)
(with-gc-finalizer-lock open-channels
(let ((name
(string-append "runtime-"
(cond ((eq? os-name 'NT) "w32")
- ((eq? os-name 'OS/2) "os2")
((eq? os-name 'UNIX) "unx")
(else "unk"))
".pkd")))
;; operating system are actually loaded and initialized.
(OPTIONAL (RUNTIME STARBASE-GRAPHICS))
(OPTIONAL (RUNTIME X-GRAPHICS))
- (OPTIONAL (RUNTIME OS2-GRAPHICS))
;; Emacs -- last because it installs hooks everywhere which must be initted.
(RUNTIME EMACS-INTERFACE)
;; More debugging
|#
-;;;; Directory Operations -- OS/2
+;;;; Directory Operations -- Win32
;;; package: (runtime directory)
(declare (usual-integrations))
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; OS/2 C Type Model
-;;; package: (runtime os2-graphics)
-
-(declare (usual-integrations))
-\f
-;;;; Generic Type Modelling
-
-(define-structure (c-type (conc-name c-type/) (constructor #f) (predicate #f))
- (size #f read-only #t)
- (alignment #f read-only #t))
-
-(define-structure (c-number-type (conc-name c-number-type/))
- (size #f read-only #t)
- (alignment #f read-only #t)
- (reader #f read-only #t)
- (writer #f read-only #t))
-
-(define-structure (c-pointer-type
- (conc-name c-pointer-type/)
- (constructor %make-c-pointer-type))
- (size #f read-only #t)
- (alignment #f read-only #t)
- (element-type #f read-only #t))
-
-(define-structure (c-array-type
- (conc-name c-array-type/)
- (constructor %make-c-array-type))
- (size #f read-only #t)
- (alignment #f read-only #t)
- (element-type #f read-only #t)
- (n-elements #f read-only #t)
- (element-spacing #f read-only #t))
-
-(define-structure (c-struct-type
- (conc-name c-struct-type/)
- (constructor %make-c-struct-type))
- (size #f read-only #t)
- (alignment #f read-only #t)
- (elements #f read-only #t))
-
-(define-structure (c-struct-element (conc-name c-struct-element/))
- (name #f read-only #t)
- (type #f read-only #t)
- (offset #f read-only #t))
-\f
-(define (define-c-type name type)
- (hash-table/put! c-type-names name (canonicalize-c-type type)))
-
-(define (lookup-c-type name)
- (let ((type (hash-table/get c-type-names name #f)))
- (if (not type)
- (error "Unknown C type name:" name))
- type))
-
-(define c-type-names)
-
-(define (canonicalize-c-type type)
- (cond ((or (c-number-type? type)
- (c-pointer-type? type)
- (c-array-type? type)
- (c-struct-type? type))
- type)
- ((string? type)
- (lookup-c-type type))
- ((and (pair? type)
- (eq? 'ARRAY (car type))
- (pair? (cdr type))
- (pair? (cddr type))
- (exact-nonnegative-integer? (caddr type))
- (null? (cdddr type)))
- (make-c-array-type (canonicalize-c-type (cadr type)) (caddr type)))
- ((and (pair? type)
- (eq? 'POINTER (car type))
- (pair? (cdr type))
- (null? (cddr type)))
- (make-c-pointer-type (canonicalize-c-type (cadr type))))
- ((and (pair? type)
- (eq? 'STRUCT (car type))
- (list? (cdr type))
- (for-all? (cdr type)
- (lambda (element)
- (and (pair? element)
- (pair? (cdr element))
- (string? (cadr element))
- (null? (cddr element))))))
- (make-c-struct-type (map (lambda (element)
- (cons (cadr element)
- (canonicalize-c-type (car element))))
- (cdr type))))
- (else
- (error "Malformed C type expression:" type))))
-\f
-(define (define-c-integer-type name signed? size)
- (define-c-type name
- (if signed?
- (make-c-number-type size size
- (signed-integer-reader size)
- (signed-integer-writer size))
- (make-c-number-type size size
- (unsigned-integer-reader size)
- (unsigned-integer-writer size)))))
-
-(define (unsigned-integer-reader n-bytes)
- (lambda (bytes start)
- (let ((end (+ start n-bytes)))
- (let loop ((index start) (accum 0) (factor 1))
- (if (< index end)
- (loop (+ index 1)
- (+ accum (* (vector-8b-ref bytes index) factor))
- (* factor 256))
- accum)))))
-
-(define (signed-integer-reader n-bytes)
- (let ((read-raw (unsigned-integer-reader n-bytes))
- (split (expt 2 (- (* n-bytes 8) 1))))
- (let ((radix (* split 2)))
- (lambda (bytes start)
- (let ((raw (read-raw bytes start)))
- (if (< raw split)
- raw
- (- raw radix)))))))
-
-(define (unsigned-integer-writer n-bytes)
- (lambda (bytes start value)
- (let ((end (+ start n-bytes)))
- (let loop ((index start) (value value))
- (if (< index end)
- (let ((q.r (integer-divide value 256)))
- (vector-8b-set! bytes index (integer-divide-remainder q.r))
- (loop (+ index 1) (integer-divide-quotient q.r))))))))
-
-(define (signed-integer-writer n-bytes)
- (let ((write-raw (unsigned-integer-writer n-bytes))
- (radix (expt 2 (* n-bytes 8))))
- (lambda (bytes start value)
- (write-raw bytes start (if (< value 0) (+ value radix) value)))))
-\f
-(define (make-c-pointer-type element-type)
- (%make-c-pointer-type (implementation/pointer-size element-type)
- (implementation/pointer-alignment element-type)
- element-type))
-
-(define (make-c-array-type element-type n-elements)
- (let ((element-spacing (implementation/array-element-spacing element-type)))
- (let ((size (* element-spacing n-elements)))
- (%make-c-array-type size
- (implementation/array-alignment element-type size)
- element-type
- n-elements
- element-spacing))))
-
-(define (make-c-struct-type element-alist)
- (let loop ((offset 0) (alist element-alist) (elements '()))
- (if (null? alist)
- (let ((elements (reverse elements)))
- (%make-c-struct-type offset
- (implementation/struct-alignment elements
- offset)
- elements))
- (let ((offset
- (implementation/struct-element-offset (cdar alist) offset)))
- (loop (+ offset (c-type/size (cdar alist)))
- (cdr alist)
- (cons (make-c-struct-element (caar alist) (cdar alist) offset)
- elements))))))
-\f
-(define (c-number-reader type offset . selectors)
- (call-with-values (lambda () (select-c-type type offset selectors))
- (lambda (type offset)
- (guarantee-number-type type)
- (let ((reader (c-number-type/reader type)))
- (lambda (bytes)
- (reader bytes offset))))))
-
-(define (c-number-writer type offset . selectors)
- (call-with-values (lambda () (select-c-type type offset selectors))
- (lambda (type offset)
- (guarantee-number-type type)
- (let ((writer (c-number-type/writer type)))
- (lambda (bytes value)
- (writer bytes offset value))))))
-
-(define (c-element-type type offset . selectors)
- (call-with-values (lambda () (select-c-type type offset selectors))
- (lambda (type offset)
- offset
- type)))
-
-(define (c-element-offset type offset . selectors)
- (call-with-values (lambda () (select-c-type type offset selectors))
- (lambda (type offset)
- type
- offset)))
-
-(define (c-array-reader type offset . selectors)
- (call-with-values (lambda () (select-c-type type offset selectors))
- (lambda (type offset)
- (let ((element-type (c-array-type/element-type type))
- (element-spacing (c-array-type/element-spacing type)))
- (guarantee-number-type element-type)
- (let ((reader (c-number-type/reader element-type)))
- (lambda (bytes index)
- (reader bytes (+ offset (* element-spacing index)))))))))
-
-(define (c-array-writer type offset . selectors)
- (call-with-values (lambda () (select-c-type type offset selectors))
- (lambda (type offset)
- (let ((element-type (c-array-type/element-type type))
- (element-spacing (c-array-type/element-spacing type)))
- (guarantee-number-type element-type)
- (let ((writer (c-number-type/writer element-type)))
- (lambda (bytes index value)
- (writer bytes (+ offset (* element-spacing index)) value)))))))
-
-(define (guarantee-number-type type)
- (if (not (c-number-type? type))
- (error "Selected type is not a number type:" type)))
-
-(define (select-c-type type offset selectors)
- (if (null? selectors)
- (values type offset)
- (call-with-values
- (lambda () (select-c-type-1 type offset (car selectors)))
- (lambda (type offset)
- (select-c-type type offset (cdr selectors))))))
-
-(define (select-c-type-1 type offset selector)
- (cond ((c-array-type? type)
- (if (not (exact-nonnegative-integer? selector))
- (error "Illegal selector for C array:" selector))
- (values (c-array-type/element-type type)
- (+ offset (* (c-array-type/element-spacing type) selector))))
- ((c-struct-type? type)
- (if (not (string? selector))
- (error "Illegal selector for C struct:" selector))
- (let loop ((elements (c-struct-type/elements type)))
- (if (null? elements)
- (error "No element with this name:" selector))
- (if (string=? selector (c-struct-element/name (car elements)))
- (values (c-struct-element/type (car elements))
- (+ offset (c-struct-element/offset (car elements))))
- (loop (cdr elements)))))
- (else
- (error "Can't select this type:" type))))
-\f
-;;;; OS/2 Type Specification
-
-(define (initialize-c-types!)
- (set! c-type-names (make-equal-hash-table))
-
- (define-c-integer-type "signed char" #t 1)
- (define-c-integer-type "signed short" #t 2)
- (define-c-integer-type "signed int" #t 4)
- (define-c-integer-type "signed long" #t 4)
-
- (define-c-integer-type "unsigned char" #f 1)
- (define-c-integer-type "unsigned short" #f 2)
- (define-c-integer-type "unsigned int" #f 4)
- (define-c-integer-type "unsigned long" #f 4)
-
- (define-c-type "char" "signed char")
- (define-c-type "short" "signed short")
- (define-c-type "int" "signed int")
- (define-c-type "long" "signed long"))
-
-(define (implementation/pointer-size element-type) element-type 4)
-(define (implementation/pointer-alignment element-type) element-type 4)
-
-(define (implementation/array-element-spacing element-type)
- (let ((size (c-type/size element-type))
- (alignment (c-type/alignment element-type)))
- (let ((delta (remainder size alignment)))
- (if (= 0 delta)
- size
- (+ size (- alignment delta))))))
-
-(define (implementation/array-alignment element-type array-size)
- (if (< array-size 4)
- (c-type/alignment element-type)
- 4))
-
-(define (implementation/struct-element-offset element-type prev-end)
- (let ((a (c-type/alignment element-type)))
- (let ((r (remainder prev-end a)))
- (if (= 0 r)
- prev-end
- (+ prev-end (- a r))))))
-
-(define (implementation/struct-alignment elements struct-size)
- (if (< struct-size 4)
- (apply max (map c-type/alignment (map c-struct-element/type elements)))
- 4))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Directory Operations -- OS/2
-;;; package: (runtime directory)
-
-(declare (usual-integrations))
-\f
-(define *expand-directory-prefixes?*)
-
-(define (initialize-package!)
- (set! *expand-directory-prefixes?* (make-unsettable-parameter #t))
- unspecific)
-
-(define (directory-read pattern #!optional sort?)
- (if (if (default-object? sort?) #t sort?)
- (sort (directory-read-nosort pattern) pathname<?)
- (directory-read-nosort pattern)))
-
-(define (directory-read-nosort pattern)
- (let ((pattern (merge-pathnames pattern)))
- (map (let ((directory-path (directory-pathname pattern)))
- (lambda (pathname)
- (merge-pathnames pathname directory-path)))
- (let ((fnames (generate-directory-pathnames pattern)))
- (parameterize* (list (cons *expand-directory-prefixes?* #f))
- (lambda ()
- (map ->pathname fnames)))))))
-
-(define (generate-directory-pathnames pathname)
- (let ((channel (directory-channel-open (->namestring pathname))))
- (let loop ((result '()))
- (let ((name (directory-channel-read channel)))
- (if name
- (loop (cons name result))
- (begin
- (directory-channel-close channel)
- result))))))
-
-(define (pathname<? x y)
- (string-ci<? (file-namestring x) (file-namestring y)))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; OS/2 PM Graphics Interface
-;;; package: (runtime os2-graphics)
-
-(declare (usual-integrations))
-(declare (integrate-external "graphics"))
-(declare (integrate-external "os2winp"))
-\f
-(define (initialize-package!)
- (set! os2-graphics-device-type
- (make-graphics-device-type
- 'OS/2
- `((activate-window ,os2-graphics/activate-window)
- (available? ,os2-graphics/available?)
- (capture-image ,os2-graphics/capture-image)
- (clear ,os2-graphics/clear)
- (close ,os2-graphics/close)
- (color? ,os2-graphics/color?)
- (coordinate-limits ,os2-graphics/coordinate-limits)
- (deactivate-window ,os2-graphics/deactivate-window)
- (define-color ,os2-graphics/define-color)
- (desktop-size ,os2-graphics/desktop-size)
- (device-coordinate-limits ,os2-graphics/device-coordinate-limits)
- (discard-events ,os2-graphics/discard-events)
- (drag-cursor ,os2-graphics/drag-cursor)
- (draw-line ,os2-graphics/draw-line)
- (draw-lines ,os2-graphics/draw-lines)
- (draw-point ,os2-graphics/draw-point)
- (draw-text ,os2-graphics/draw-text)
- (find-color ,os2-graphics/find-color)
- (flush ,os2-graphics/flush)
- (hide-window ,os2-graphics/hide-window)
- (image-depth ,os2-graphics/image-depth)
- (lower-window ,os2-graphics/lower-window)
- (maximize-window ,os2-graphics/maximize-window)
- (minimize-window ,os2-graphics/minimize-window)
- (move-cursor ,os2-graphics/move-cursor)
- (open ,os2-graphics/open)
- (open? ,os2-graphics/open-window?)
- (raise-window ,os2-graphics/raise-window)
- (read-button ,os2-graphics/read-button)
- (read-user-event ,os2-graphics/read-user-event)
- (reset-clip-rectangle ,os2-graphics/reset-clip-rectangle)
- (restore-window ,os2-graphics/restore-window)
- (select-user-events ,os2-graphics/select-user-events)
- (set-background-color ,os2-graphics/set-background-color)
- (set-clip-rectangle ,os2-graphics/set-clip-rectangle)
- (set-coordinate-limits ,os2-graphics/set-coordinate-limits)
- (set-drawing-mode ,os2-graphics/set-drawing-mode)
- (set-font ,os2-graphics/set-font)
- (set-foreground-color ,os2-graphics/set-foreground-color)
- (set-line-style ,os2-graphics/set-line-style)
- (set-window-name ,os2-graphics/set-window-title)
- (set-window-position ,os2-graphics/set-window-position)
- (set-window-size ,os2-graphics/set-window-size)
- (set-window-title ,os2-graphics/set-window-title)
- (window-position ,os2-graphics/window-position)
- (window-frame-size ,os2-graphics/window-frame-size)
- (window-size ,os2-graphics/window-size))))
- (1d-table/put!
- (graphics-type-properties os2-graphics-device-type)
- 'IMAGE-TYPE
- (make-image-type
- `((create ,os2-image/create)
- (destroy ,os2-image/destroy)
- (width ,os2-image/width)
- (height ,os2-image/height)
- (draw ,os2-image/draw)
- (draw-subimage ,os2-image/draw-subimage)
- (fill-from-byte-vector ,os2-image/fill-from-byte-vector))))
- (set! event-descriptor #f)
- (set! event-previewer-registration #f)
- (set! window-finalizer
- (make-gc-finalizer os2win-close window? window/wid set-window/wid!))
- (set! image-finalizer
- (make-gc-finalizer destroy-memory-ps image? image/ps set-image/ps!))
- (set! user-event-mask user-event-mask:default)
- (set! user-event-queue (make-queue))
- (initialize-color-table)
- (add-event-receiver! event:before-exit finalize-pm-state!))
-\f
-(define os2-graphics-device-type)
-(define event-descriptor)
-(define event-previewer-registration)
-(define window-finalizer)
-(define image-finalizer)
-(define user-event-mask)
-(define user-event-queue)
-(define graphics-window-icon)
-
-;; This event mask contains just button events.
-(define user-event-mask:default #x0001)
-
-(define (finalize-pm-state!)
- (if event-descriptor
- (begin
- (os2win-destroy-pointer graphics-window-icon)
- (set! graphics-window-icon)
- (remove-all-from-gc-finalizer! window-finalizer)
- (remove-all-from-gc-finalizer! image-finalizer)
- (deregister-io-thread-event event-previewer-registration)
- (set! event-previewer-registration #f)
- (set! user-event-mask user-event-mask:default)
- (flush-queue! user-event-queue)
- (os2win-close-event-qid event-descriptor)
- (set! event-descriptor #f)
- unspecific)))
-\f
-;;;; Window Abstraction
-
-(define-structure (window
- (conc-name window/)
- (constructor %make-window
- (wid pel-width pel-height x-slope y-slope)))
- wid
- pel-width
- pel-height
- backing-image
- (changes #f)
- (x-gcursor 0)
- (y-gcursor 0)
- (x-left -1)
- (y-bottom -1)
- (x-right 1)
- (y-top 1)
- x-slope
- y-slope
- font-specifier
- font-metrics
- (foreground-color #xFFFFFF)
- (background-color #x000000)
- device)
-
-(define (make-window wid width height)
- (let ((window
- (%make-window wid width height
- (exact->inexact (/ (- width 1) 2))
- (exact->inexact (/ (- height 1) 2)))))
- (set-window/backing-image! window (create-image width height))
- (add-to-gc-finalizer! window-finalizer window)))
-
-(define (close-window window)
- (if (window/wid window)
- (begin
- (destroy-image (window/backing-image window))
- (remove-from-gc-finalizer! window-finalizer window))))
-
-(define-integrable (os2-graphics-device/wid device)
- (window/wid (graphics-device/descriptor device)))
-
-(define-integrable (os2-graphics-device/psid device)
- (window/backing-store (graphics-device/descriptor device)))
-
-(define-integrable (window/backing-store window)
- (image/ps (window/backing-image window)))
-
-(define (compute-window-slopes! window)
- (set-window/x-slope!
- window
- (exact->inexact
- (/ (- (window/pel-width window) 1)
- (- (window/x-right window) (window/x-left window)))))
- (set-window/y-slope!
- window
- (exact->inexact
- (/ (- (window/pel-height window) 1)
- (- (window/y-top window) (window/y-bottom window))))))
-
-(define (window/x->device window x)
- (round->exact (* (window/x-slope window) (- x (window/x-left window)))))
-
-(define (window/y->device window y)
- (round->exact (* (window/y-slope window) (- y (window/y-bottom window)))))
-
-(define (window/device->x window x)
- (+ (/ x (window/x-slope window)) (window/x-left window)))
-
-(define (window/device->y window y)
- (+ (/ y (window/y-slope window)) (window/y-bottom window)))
-\f
-;;;; Standard Operations
-
-(define (os2-graphics/available?)
- (implemented-primitive-procedure? (ucode-primitive os2win-open 2)))
-
-(define (os2-graphics/open descriptor->device #!optional width height)
- (if (not event-descriptor)
- (begin
- (set! event-descriptor (os2win-open-event-qid))
- (set! event-previewer-registration
- (permanently-register-io-thread-event
- event-descriptor
- 'READ
- (current-thread)
- (lambda (mode)
- mode
- (read-and-process-event))))
- (set! graphics-window-icon
- (os2win-load-pointer HWND_DESKTOP NULLHANDLE IDI_GRAPHICS))))
- (open-window descriptor->device
- (if (default-object? width) 256 width)
- (if (default-object? height) 256 height)))
-
-(define (open-window descriptor->device width height)
- (let ((wid (os2win-open event-descriptor "Scheme Graphics")))
- (os2win-set-icon wid graphics-window-icon)
- (os2win-show-cursor wid #f)
- (os2win-show wid #t)
- (os2win-set-size wid width height)
- (pm-synchronize)
- (os2win-set-state wid window-state:deactivate)
- (os2win-set-state wid window-state:top)
- (let ((window (make-window wid width height)))
- (update-colors window)
- (set-window-font! window "4.System VIO")
- (let ((device (descriptor->device window)))
- (os2-graphics/clear device)
- (set-window/device! window device)
- device))))
-
-(define (os2-graphics/open-window? device)
- (if (os2-graphics-device/wid device) #t #f))
-
-(define (os2-graphics/close device)
- (let ((window (graphics-device/descriptor device)))
- (without-interruption
- (lambda ()
- (close-window window)))))
-
-(define (os2-graphics/clear device)
- (let ((window (graphics-device/descriptor device)))
- (without-interruption
- (lambda ()
- (let ((width (window/pel-width window))
- (height (window/pel-height window)))
- (os2ps-clear (window/backing-store window) 0 width 0 height)
- (invalidate-rectangle device 0 width 0 height))))))
-
-(define (os2-graphics/coordinate-limits device)
- (let ((window (graphics-device/descriptor device)))
- (without-interruption
- (lambda ()
- (values (window/x-left window)
- (window/y-bottom window)
- (window/x-right window)
- (window/y-top window))))))
-
-(define (os2-graphics/device-coordinate-limits device)
- (let ((window (graphics-device/descriptor device)))
- (without-interruption
- (lambda ()
- (values 0
- 0
- (- (window/pel-width window) 1)
- (- (window/pel-height window) 1))))))
-\f
-(define (os2-graphics/drag-cursor device x y)
- (let ((window (graphics-device/descriptor device)))
- (without-interruption
- (lambda ()
- (let ((xs (window/x-gcursor window))
- (ys (window/y-gcursor window))
- (xe (window/x->device window x))
- (ye (window/y->device window y)))
- (let ((xl (if (fix:< xs xe) xs xe))
- (yl (if (fix:< ys ye) ys ye))
- (xh (fix:+ (if (fix:> xs xe) xs xe) 1))
- (yh (fix:+ (if (fix:> ys ye) ys ye) 1)))
- (os2ps-line (window/backing-store window) xe ye)
- (set-window/x-gcursor! window xe)
- (set-window/y-gcursor! window ye)
- (invalidate-rectangle device xl xh yl yh)))))))
-
-(define (os2-graphics/draw-line device x-start y-start x-end y-end)
- (os2-graphics/move-cursor device x-start y-start)
- (os2-graphics/drag-cursor device x-end y-end))
-
-(define (os2-graphics/draw-lines device xv yv)
- (let ((window (graphics-device/descriptor device)))
- (without-interruption
- (lambda ()
- (let ((xv (vector-map (lambda (x) (window/x->device window x)) xv))
- (yv (vector-map (lambda (y) (window/y->device window y)) yv)))
- (let ((xl (fix:vector-min xv))
- (yl (fix:vector-min yv))
- (xh (fix:+ (fix:vector-max xv) 1))
- (yh (fix:+ (fix:vector-max yv) 1)))
- (os2ps-poly-line-disjoint (window/backing-store window) xv yv)
- (invalidate-rectangle device xl xh yl yh)))))))
-
-(define (os2-graphics/draw-point device x y)
- ;; This sucks. Implement a real point-drawing primitive.
- (let ((window (graphics-device/descriptor device)))
- (without-interruption
- (lambda ()
- (let ((x (window/x->device window x))
- (y (window/y->device window y)))
- (os2ps-draw-point (window/backing-store window) x y)
- (invalidate-rectangle device x (fix:+ x 1) y (fix:+ y 1)))))))
-
-(define (os2-graphics/draw-text device x y string)
- (let ((window (graphics-device/descriptor device))
- (length (string-length string)))
- (without-interruption
- (lambda ()
- (let ((psid (window/backing-store window))
- (metrics (window/font-metrics window))
- (x (window/x->device window x))
- (y (window/y->device window y)))
- (os2ps-write psid
- x
- (fix:+ y (font-metrics/descender metrics))
- string
- 0
- length)
- (invalidate-rectangle device
- x
- (fix:+ x
- (os2ps-text-width psid string 0 length))
- y
- (fix:+ y (font-metrics/height metrics))))))))
-\f
-(define (os2-graphics/flush device)
- (let ((window (graphics-device/descriptor device)))
- (without-interruption
- (lambda ()
- (let ((changes (window/changes window)))
- (if changes
- (begin
- (os2win-invalidate (window/wid window)
- (changes/x-left changes)
- (changes/x-right changes)
- (changes/y-bottom changes)
- (changes/y-top changes))
- (set-window/changes! window #f))))))))
-
-(define (invalidate-rectangle device x-left x-right y-bottom y-top)
- (let ((window (graphics-device/descriptor device)))
- (if (graphics-device/buffer? device)
- (let ((changes (window/changes window)))
- (if (not changes)
- (set-window/changes! window
- (make-changes x-left
- x-right
- y-bottom
- y-top))
- (begin
- (if (fix:< x-left (changes/x-left changes))
- (set-changes/x-left! changes x-left))
- (if (fix:> x-right (changes/x-right changes))
- (set-changes/x-right! changes x-right))
- (if (fix:< y-bottom (changes/y-bottom changes))
- (set-changes/y-bottom! changes y-bottom))
- (if (fix:> y-top (changes/y-top changes))
- (set-changes/y-top! changes y-top)))))
- (os2win-invalidate (window/wid window)
- x-left x-right y-bottom y-top))))
-
-(define-structure (changes (type vector)
- (conc-name changes/)
- (constructor make-changes))
- x-left
- x-right
- y-bottom
- y-top)
-\f
-(define (os2-graphics/move-cursor device x y)
- (let ((window (graphics-device/descriptor device)))
- (without-interruption
- (lambda ()
- (let ((x (window/x->device window x))
- (y (window/y->device window y)))
- (os2ps-move-graphics-cursor (window/backing-store window) x y)
- (set-window/x-gcursor! window x)
- (set-window/y-gcursor! window y))))))
-
-(define (os2-graphics/reset-clip-rectangle device)
- (os2ps-reset-clip-rectangle (os2-graphics-device/psid device)))
-
-(define (os2-graphics/set-clip-rectangle device x-left y-bottom x-right y-top)
- (let ((window (graphics-device/descriptor device)))
- (without-interruption
- (lambda ()
- (os2ps-set-clip-rectangle (window/backing-store window)
- (window/x->device window x-left)
- (window/x->device window x-right)
- (window/y->device window y-bottom)
- (window/y->device window y-top))))))
-
-(define (os2-graphics/set-coordinate-limits device
- x-left y-bottom x-right y-top)
- (let ((window (graphics-device/descriptor device)))
- (without-interruption
- (lambda ()
- (set-window/x-left! window x-left)
- (set-window/y-bottom! window y-bottom)
- (set-window/x-right! window x-right)
- (set-window/y-top! window y-top)
- (compute-window-slopes! window)))))
-
-(define (os2-graphics/set-drawing-mode device mode)
- (os2ps-set-mix (os2-graphics-device/psid device)
- (map-drawing-mode mode)))
-
-(define (os2-graphics/set-line-style device style)
- (os2ps-set-line-type (os2-graphics-device/psid device)
- (map-line-style style)))
-\f
-;;;; Color Operations
-
-(define (os2-graphics/color? device)
- (not (= 0 (os2ps-query-capability (os2-graphics-device/psid device)
- CAPS_COLOR_TABLE_SUPPORT))))
-
-(define (os2-graphics/define-color device name color)
- device
- (os2/define-color name color))
-
-(define (os2-graphics/find-color device specification)
- device
- (os2/find-color specification))
-
-(define (os2-graphics/set-background-color device color)
- (let ((window (graphics-device/descriptor device))
- (color (->color color 'SET-BACKGROUND-COLOR)))
- (without-interruption
- (lambda ()
- (set-window/background-color! window color)
- (update-colors window)))))
-
-(define (os2-graphics/set-foreground-color device color)
- (let ((window (graphics-device/descriptor device))
- (color (->color color 'SET-FOREGROUND-COLOR)))
- (without-interruption
- (lambda ()
- (set-window/foreground-color! window color)
- (update-colors window)))))
-
-(define (update-colors window)
- (os2ps-set-colors (window/backing-store window)
- (window/foreground-color window)
- (window/background-color window)))
-
-(define (os2-graphics/image-depth device)
- (let ((bitcount
- (os2ps-query-capability (os2-graphics-device/psid device)
- CAPS_COLOR_BITCOUNT)))
- (if (<= 1 bitcount 8)
- bitcount
- 8)))
-\f
-;;;; Window Operations
-
-(define (os2-graphics/window-size device)
- (let ((w.h (os2win-get-size (os2-graphics-device/wid device))))
- (values (car w.h)
- (cdr w.h))))
-
-(define (os2-graphics/set-window-size device width height)
- (os2win-set-size (os2-graphics-device/wid device) width height))
-
-(define (os2-graphics/window-frame-size device)
- (let ((w.h (os2win-get-frame-size (os2-graphics-device/wid device))))
- (values (car w.h)
- (cdr w.h))))
-
-(define (os2-graphics/window-position device)
- (let ((x.y (os2win-get-pos (os2-graphics-device/wid device))))
- (values (car x.y)
- (cdr x.y))))
-
-(define (os2-graphics/set-window-position device x y)
- (os2win-set-pos (os2-graphics-device/wid device) x y))
-
-(define (os2-graphics/set-window-title device title)
- (os2win-set-title (os2-graphics-device/wid device) title))
-
-(define (os2-graphics/set-font device font-specifier)
- (set-window-font! (graphics-device/descriptor device) font-specifier))
-
-(define (os2-graphics/hide-window device)
- (os2win-set-state (os2-graphics-device/wid device) window-state:hide))
-
-(define (os2-graphics/minimize-window device)
- (os2win-set-state (os2-graphics-device/wid device) window-state:minimize))
-
-(define (os2-graphics/maximize-window device)
- (os2win-set-state (os2-graphics-device/wid device) window-state:maximize))
-
-(define (os2-graphics/restore-window device)
- (os2win-set-state (os2-graphics-device/wid device) window-state:restore))
-
-(define (os2-graphics/raise-window device)
- (os2win-set-state (os2-graphics-device/wid device) window-state:top))
-
-(define (os2-graphics/lower-window device)
- (os2win-set-state (os2-graphics-device/wid device) window-state:bottom))
-
-(define (os2-graphics/activate-window device)
- (os2win-set-state (os2-graphics-device/wid device) window-state:activate))
-
-(define (os2-graphics/deactivate-window device)
- (os2win-set-state (os2-graphics-device/wid device) window-state:deactivate))
-
-(define (os2-graphics/desktop-size device)
- device
- (values (os2win-desktop-width) (os2win-desktop-height)))
-\f
-;;;; Color Support
-
-(define (os2/define-color name color)
- (if (not (and (color-name? name)
- (not (char=? #\# (string-ref name 0)))))
- (error:wrong-type-argument name "color name" 'OS2/DEFINE-COLOR))
- (let ((entry (lookup-color-name name))
- (color (->color color 'OS2/DEFINE-COLOR)))
- (if entry
- (set-cdr! entry color)
- (begin
- (set! color-table (cons (cons name color) color-table))
- unspecific))))
-
-(define (os2/find-color specification)
- (->color specification 'OS2/FIND-COLOR))
-
-(define (->color specification procedure)
- (cond ((color? specification)
- specification)
- ((color-triple? specification)
- (triple->color specification))
- ((color-name? specification)
- (name->color specification procedure))
- (else
- (error:wrong-type-argument specification
- "color specification"
- procedure))))
-
-(define (color? object)
- (and (exact-nonnegative-integer? object)
- (< object #x1000000)))
-
-(define (color-triple? object)
- (and (list? object)
- (= 3 (length object))
- (for-all? object
- (lambda (element)
- (and (exact-nonnegative-integer? element)
- (< element #x100))))))
-
-(define (triple->color triple)
- (+ (* #x10000 (car triple))
- (* #x100 (cadr triple))
- (caddr triple)))
-\f
-(define (color-name? object)
- (and (string? object)
- (not (string-null? object))))
-
-(define (name->color name procedure)
- (if (char=? #\# (string-ref name 0))
- (let ((color (substring->number name 1 (string-length name) 16)))
- (if (not (color? color))
- (error:bad-range-argument name procedure))
- color)
- (let ((entry (lookup-color-name name)))
- (if (not entry)
- (error:bad-range-argument name procedure))
- (cdr entry))))
-
-(define (lookup-color-name name)
- (let loop ((entries color-table))
- (and (not (null? entries))
- (if (string-ci=? (caar entries) name)
- (car entries)
- (loop (cdr entries))))))
-
-(define (initialize-color-table)
- (set! color-table '())
- (for-each (lambda (entry)
- (os2/define-color (car entry) (cdr entry)))
- initial-color-definitions))
-
-(define color-table)
-
-(define initial-color-definitions
- `(("red" 255 0 0)
- ("green" 0 255 0)
- ("blue" 0 0 255)
- ("cyan" 0 255 255)
- ("magenta" 255 0 255)
- ("yellow" 255 255 0)
- ("black" 0 0 0)
- ("dark gray" 63 63 63)
- ("dark grey" 63 63 63)
- ("gray" 127 127 127)
- ("grey" 127 127 127)
- ("light gray" 191 191 191)
- ("light grey" 191 191 191)
- ("white" 255 255 255)
- ("purple" 127 0 127)
- ("dark green" 0 127 0)
- ("orange" 255 135 0)
- ("pink" 255 181 197)
- ("brown" 127 63 0)))
-\f
-;;;; Console Window
-
-;;; This and the color support really should be in a separate file.
-
-(define (os2-console/color?)
- (not (= 0 (os2ps-query-capability (os2win-ps (os2win-console-wid))
- CAPS_COLOR_TABLE_SUPPORT))))
-
-(define (os2-console/get-font-metrics)
- (let ((metrics (os2ps-get-font-metrics (os2win-ps (os2win-console-wid)))))
- (values (font-metrics/width metrics)
- (font-metrics/height metrics))))
-
-(define (os2-console/set-font! font-name)
- (if (not (os2ps-set-font (os2win-ps (os2win-console-wid)) 1 font-name))
- (error:bad-range-argument font-name 'OS2-CONSOLE/SET-FONT!)))
-
-(define (os2-console/set-colors! foreground background)
- (let ((wid (os2win-console-wid)))
- (os2ps-set-colors (os2win-ps wid)
- (os2/find-color foreground)
- (os2/find-color background))
- (let ((w.h (os2win-get-size wid)))
- (os2win-invalidate wid 0 (car w.h) 0 (cdr w.h)))))
-
-(define (os2-console/get-pel-size)
- (let ((w.h (os2win-get-size (os2win-console-wid))))
- (values (car w.h)
- (cdr w.h))))
-
-(define (os2-console/set-pel-size! width height)
- (os2win-set-size (os2win-console-wid) width height))
-
-(define (os2-console/get-size)
- (let ((wid (os2win-console-wid)))
- (let ((w.h (os2win-get-size wid))
- (metrics (os2ps-get-font-metrics (os2win-ps wid))))
- (values (quotient (car w.h) (font-metrics/width metrics))
- (quotient (cdr w.h) (font-metrics/height metrics))))))
-
-(define (os2-console/set-size! width height)
- (let ((metrics (os2ps-get-font-metrics (os2win-ps (os2win-console-wid)))))
- (os2-console/set-pel-size! (* width (font-metrics/width metrics))
- (* height (font-metrics/height metrics)))))
-
-(define (os2-console/get-frame-size)
- (let ((w.h (os2win-get-frame-size (os2win-console-wid))))
- (values (car w.h)
- (cdr w.h))))
-
-(define (os2-console/get-frame-position)
- (let ((x.y (os2win-get-pos (os2win-console-wid))))
- (values (car x.y)
- (cdr x.y))))
-
-(define (os2-console/set-frame-position! x y)
- (os2win-set-pos (os2win-console-wid) x y))
-\f
-;;;; Miscellaneous Support
-
-(define (set-window-font! window font-specifier)
- (set-window/font-specifier! window font-specifier)
- (set-window/font-metrics!
- window
- (let ((metrics
- (os2ps-set-font (window/backing-store window) 1 font-specifier)))
- (if (not metrics)
- (error "Unknown font name:" font-specifier))
- metrics)))
-
-(define (fix:vector-min v)
- (let ((length (vector-length v))
- (min (vector-ref v 0)))
- (do ((index 1 (fix:+ index 1)))
- ((fix:= index length))
- (if (fix:< (vector-ref v index) min)
- (set! min (vector-ref v index))))
- min))
-
-(define (fix:vector-max v)
- (let ((length (vector-length v))
- (max (vector-ref v 0)))
- (do ((index 1 (fix:+ index 1)))
- ((fix:= index length))
- (if (fix:> (vector-ref v index) max)
- (set! max (vector-ref v index))))
- max))
-
-(define map-drawing-mode
- (let ((modes
- (vector FM_ZERO
- FM_AND
- FM_MASKSRCNOT
- FM_OVERPAINT
- FM_SUBTRACT
- FM_LEAVEALONE
- FM_XOR
- FM_OR
- FM_NOTMERGESRC
- FM_NOTXORSRC
- FM_INVERT
- FM_MERGESRCNOT
- FM_NOTCOPYSRC
- FM_MERGENOTSRC
- FM_NOTMASKSRC
- FM_ONE)))
- (lambda (mode)
- (if (not (and (fix:fixnum? mode) (fix:<= 0 mode) (fix:< mode 16)))
- (error:wrong-type-argument mode "graphics line style"
- 'MAP-DRAWING-MODE))
- (vector-ref modes mode))))
-
-(define map-line-style
- (let ((styles
- (vector LINETYPE_SOLID
- LINETYPE_SHORTDASH
- LINETYPE_DOT
- LINETYPE_DASHDOT
- LINETYPE_DASHDOUBLEDOT
- LINETYPE_LONGDASH
- LINETYPE_DOUBLEDOT
- LINETYPE_ALTERNATE)))
- (lambda (style)
- (if (not (and (fix:fixnum? style) (fix:<= 0 style) (fix:< style 8)))
- (error:wrong-type-argument style "graphics line style"
- 'MAP-LINE-STYLE))
- (vector-ref styles style))))
-\f
-;;;; Events
-
-(define (pm-synchronize)
- (os2pm-synchronize)
- (without-interruption
- (lambda () (do () ((not (read-and-process-event)))))))
-
-(define (read-and-process-event)
- (let ((event (os2win-get-event event-descriptor #f)))
- (and event
- (begin (process-event event) #t))))
-
-(define (process-event event)
- (let ((window
- (search-gc-finalizer window-finalizer
- (let ((wid (event-wid event)))
- (lambda (window)
- (eq? (window/wid window) wid))))))
- (if window
- (begin
- (let ((handler (vector-ref event-handlers (event-type event))))
- (if handler
- (handler window event)))
- (maybe-queue-user-event window event)))))
-
-(define event-handlers (make-vector number-of-event-types #f))
-
-(define-integrable (define-event-handler event-type handler)
- (vector-set! event-handlers event-type handler))
-
-(define-event-handler event-type:button
- (lambda (window event)
- (if (and (eq? button-event-type:down (button-event/type event))
- (not (os2win-focus? (window/wid window))))
- (os2win-activate (window/wid window)))))
-
-(define-event-handler event-type:close
- (lambda (window event)
- event
- (close-window window)))
-
-(define-event-handler event-type:paint
- (lambda (window event)
- (os2ps-bitblt (os2win-ps (window/wid window))
- (window/backing-store window)
- (let ((xl (paint-event/xl event)))
- (vector xl (paint-event/xh event) xl))
- (let ((yl (paint-event/yl event)))
- (vector yl (paint-event/yh event) yl))
- ROP_SRCCOPY
- BBO_OR)))
-
-(define-event-handler event-type:resize
- (lambda (window event)
- (let ((width (resize-event/width event))
- (height (resize-event/height event)))
- (let ((old (window/backing-store window)))
- (let ((bitmap (os2ps-create-bitmap old width height)))
- (let ((new (os2ps-create-memory-ps)))
- (os2ps-set-bitmap new bitmap)
- ;; I'm worried that this will fail because the new memory PS
- ;; doesn't have the correct attributes. Maybe this will
- ;; only cause trouble once we start hacking color maps.
- (os2ps-bitblt new
- old
- (vector 0 width 0 (window/pel-width window))
- (vector 0 height 0 (window/pel-height window))
- ROP_SRCCOPY
- BBO_IGNORE)
- (os2ps-set-bitmap new #f)
- (os2ps-destroy-memory-ps new))
- (os2ps-destroy-bitmap (os2ps-set-bitmap old bitmap))))
- (set-window/pel-width! window width)
- (set-window/pel-height! window height)
- (compute-window-slopes! window)
- (os2win-invalidate (window/wid window) 0 width 0 height)
- (set-window/changes! window #f))))
-\f
-;;;; User Events
-
-(define (maybe-queue-user-event window event)
- (if (not (fix:= 0 (fix:and (fix:lsh 1 (event-type event)) user-event-mask)))
- (begin
- (set-event-wid! event (window/device window))
- (enqueue!/unsafe user-event-queue event))))
-
-(define (os2-graphics/select-user-events device mask)
- device
- (if (not (and (exact-nonnegative-integer? mask)
- (< mask (expt 2 number-of-event-types))))
- (error:bad-range-argument mask 'SELECT-USER-EVENTS))
- (set! user-event-mask mask)
- unspecific)
-
-(define (os2-graphics/read-user-event device)
- device
- (without-interruption
- (lambda ()
- (let loop ()
- (if (queue-empty? user-event-queue)
- (begin
- (if (eq? 'READ
- (test-for-io-on-descriptor event-descriptor #t 'READ))
- (read-and-process-event))
- (loop))
- (dequeue! user-event-queue))))))
-
-(define (os2-graphics/read-button device)
- (let ((window (graphics-device/descriptor device))
- (event
- (let loop ()
- (let ((event (os2-graphics/read-user-event device)))
- (if (and (eq? event-type:button (event-type event))
- (eq? button-event-type:down (button-event/type event)))
- event
- (loop))))))
- (values (button-event/number event)
- (window/device->x window (button-event/x event))
- (window/device->y window (button-event/y event))
- (event-wid event))))
-
-(define (os2-graphics/discard-events device)
- device
- (without-interruption
- (lambda ()
- (let loop ()
- (flush-queue! user-event-queue)
- (if (read-and-process-event)
- (loop))))))
-
-(define (flush-queue! queue)
- (without-interruption
- (lambda ()
- (let loop ()
- (if (not (queue-empty? queue))
- (begin
- (dequeue!/unsafe queue)
- (loop)))))))
-\f
-;;;; Images
-
-(define-structure (image (conc-name image/))
- ps
- (width #f read-only #t)
- (height #f read-only #t)
- colormap)
-
-(define (os2-graphics/capture-image device x-left y-bottom x-right y-top)
- (let ((window (graphics-device/descriptor device)))
- (let ((x (window/x->device window x-left))
- (y (window/y->device window y-bottom)))
- (let ((width (+ (- (window/x->device window x-right) x) 1))
- (height (+ (- (window/y->device window y-top) y) 1)))
- (let ((image (image/create device width height)))
- (os2ps-bitblt (image/ps (image/descriptor image))
- (window/backing-store window)
- (vector x (+ x width) 0)
- (vector y (+ y height) 0)
- ROP_SRCCOPY
- BBO_OR)
- image)))))
-
-(define (os2-image/create device width height)
- device
- (create-image width height))
-
-(define (create-image width height)
- (let ((ps (os2ps-create-memory-ps)))
- (os2ps-set-bitmap ps (os2ps-create-bitmap ps width height))
- (add-to-gc-finalizer! image-finalizer (make-image ps width height #f))))
-
-(define (os2-image/set-colormap image colormap)
- ;; Kludge: IMAGE/FILL-FROM-BYTE-VECTOR doesn't accept a colormap
- ;; argument to define how the bytes in the vector map into colors.
- ;; But OS/2 needs this information in order to transform those bytes
- ;; into a bitmap. So this operation allows a colormap to be stored
- ;; in the image and retrieved later.
- (set-image/colormap! (image/descriptor image) colormap))
-
-(define (os2-image/destroy image)
- (destroy-image (image/descriptor image)))
-
-(define (destroy-image image)
- (remove-from-gc-finalizer! image-finalizer image))
-
-(define (destroy-memory-ps ps)
- (let ((bitmap (os2ps-set-bitmap ps #f)))
- (os2ps-destroy-memory-ps ps)
- (if bitmap
- (os2ps-destroy-bitmap bitmap))))
-
-(define (os2-image/width image)
- (image/width (image/descriptor image)))
-
-(define (os2-image/height image)
- (image/height (image/descriptor image)))
-\f
-(define (os2-image/fill-from-byte-vector image bytes)
- (let ((image (image/descriptor image)))
- (set-bitmap-bits
- (image/ps image)
- (let ((width (image/width image))
- (height (image/height image)))
- (make-bitmap-info width height 8
- (image/colormap image)
- (convert-bitmap-data width height bytes))))))
-
-(define (convert-bitmap-data width height bytes)
- ;; Convert Scheme bitmap data layout to OS/2 bitmap layout. Scheme
- ;; layout is row-major with upper-left corner at index zero with no
- ;; padding. OS/2 layout is row-major with lower-left corner at
- ;; index zero and rows padded to 32-bit boundaries. This conversion
- ;; uses the OS/2 standard 8-bit-per-pixel bitmap format.
- (let ((row-size (* (ceiling (/ (* 8 width) 32)) 4)))
- (let ((copy (make-string (* row-size height))))
- (let loop ((from 0) (to (string-length copy)))
- (if (not (fix:= to 0))
- (let ((from* (fix:+ from width))
- (to (fix:- to row-size)))
- (substring-move! bytes from from* copy to)
- (loop from* to))))
- copy)))
-
-(define (os2-image/draw device x y image)
- (let ((window (graphics-device/descriptor device))
- (image (image/descriptor image)))
- (draw-image device
- (window/x->device window x)
- (window/y->device window y)
- image
- 0
- 0
- (image/width image)
- (image/height image))))
-
-(define (os2-image/draw-subimage device x y image
- image-x image-y image-width image-height)
- (let ((window (graphics-device/descriptor device))
- (image (image/descriptor image)))
- (draw-image device
- (window/x->device window x)
- (window/y->device window y)
- image
- image-x
- ;; IMAGE-Y must be inverted because Scheme images have
- ;; origin in upper left and OS/2 bitmaps have origin
- ;; in lower left.
- (- (image/height image) (+ image-y image-height))
- image-width
- image-height)))
-
-(define (draw-image device x-left y-top
- image image-x image-y image-width image-height)
- (let ((y-top (+ y-top 1)))
- (let ((x-right (+ x-left image-width))
- (y-bottom (- y-top image-height)))
- (os2ps-bitblt (os2-graphics-device/psid device)
- (image/ps image)
- (vector x-left x-right image-x)
- (vector y-bottom y-top image-y)
- ROP_SRCCOPY
- BBO_OR)
- (invalidate-rectangle device x-left x-right y-bottom y-top))))
-\f
-;;;; Bitmap I/O
-
-;;; This code uses the OS/2 C datatype modelling code to manipulate
-;;; OS/2 C data types which are contained in Scheme character strings.
-
-(define (get-bitmap-bits psid n-bits)
- (if (not (memv n-bits '(1 4 8 24)))
- (error:bad-range-argument n-bits 'GET-BITMAP-BITS))
- (maybe-initialize-bitmaps!)
- (call-with-values (lambda () (get-bitmap-dimensions (os2ps-get-bitmap psid)))
- (lambda (width height)
- (let ((info (make-bytes:bitmap-info-2 1 n-bits))
- (data (make-bytes:bitmap-data width height 1 n-bits)))
- (let ((n (os2ps-get-bitmap-bits psid 0 height data info)))
- (if (not (= height n))
- (error "Only able to read part of bitmap data:" n height)))
- (bytes->bitmap-info info data)))))
-
-(define (set-bitmap-bits psid info)
- (maybe-initialize-bitmaps!)
- (let ((height (bitmap-info/height info)))
- (call-with-values (lambda () (bitmap-info->bytes info))
- (lambda (info data)
- (let ((n (os2ps-set-bitmap-bits psid 0 height data info)))
- (if (not (= height n))
- (error "Only able to write part of bitmap data:" n height)))))))
-
-(define bitmaps-initialized? #f)
-(define (maybe-initialize-bitmaps!)
- (without-interruption
- (lambda ()
- (if (not bitmaps-initialized?)
- (begin
- (initialize-c-types!)
- (define-c-type "USHORT" "unsigned short")
- (define-c-type "ULONG" "unsigned long")
- (define-c-type "BITMAPINFOHEADER"
- '(struct ("ULONG" "cbFix")
- ("USHORT" "cx")
- ("USHORT" "cy")
- ("USHORT" "cPlanes")
- ("USHORT" "cBitCount")))
- (define-c-type "BITMAPINFO2"
- '(struct ("ULONG" "cbFix")
- ("ULONG" "cx")
- ("ULONG" "cy")
- ("USHORT" "cPlanes")
- ("USHORT" "cBitCount")
- ("ULONG" "ulCompression")
- ("ULONG" "cbImage")
- ("ULONG" "cxResolution")
- ("ULONG" "cyResolution")
- ("ULONG" "cclrUsed")
- ("ULONG" "cclrImportant")
- ("USHORT" "usUnits")
- ("USHORT" "usReserved")
- ("USHORT" "usRecording")
- ("USHORT" "usRendering")
- ("ULONG" "cSize1")
- ("ULONG" "cSize2")
- ("ULONG" "ulColorEncoding")
- ("ULONG" "ulIdentifier")
- ((array "ULONG" 1) "argbColor")))
- (set! get-bitmap-dimensions (make:get-bitmap-dimensions))
- (set! bytes->bitmap-info (make:bytes->bitmap-info))
- (set! bitmap-info->bytes (make:bitmap-info->bytes))
- (set! make-bytes:bitmap-info-2 (make:make-bytes:bitmap-info-2))
- (set! bitmaps-initialized? #t)
- unspecific)))))
-
-(define get-bitmap-dimensions)
-(define (make:get-bitmap-dimensions)
- (let ((type (lookup-c-type "BITMAPINFOHEADER")))
- (let ((width (c-number-reader type 0 "cx"))
- (height (c-number-reader type 0 "cy")))
- (lambda (bid)
- (let ((bytes (os2ps-get-bitmap-parameters bid)))
- (values (width bytes) (height bytes)))))))
-\f
-(define bytes->bitmap-info)
-(define (make:bytes->bitmap-info)
- (let ((type (lookup-c-type "BITMAPINFO2")))
- (let ((width (c-number-reader type 0 "cx"))
- (height (c-number-reader type 0 "cy"))
- (n-bits (c-number-reader type 0 "cBitCount"))
- (get-color (c-array-reader type 0 "argbColor")))
- (lambda (bytes data)
- (let ((n-bits (n-bits bytes)))
- (make-bitmap-info (width bytes)
- (height bytes)
- n-bits
- (if (= n-bits 24)
- #f
- (make-initialized-vector (expt 2 n-bits)
- (lambda (index)
- (get-color bytes index))))
- data))))))
-
-(define bitmap-info->bytes)
-(define (make:bitmap-info->bytes)
- (let ((type (lookup-c-type "BITMAPINFO2")))
- (let ((set-width! (c-number-writer type 0 "cx"))
- (set-height! (c-number-writer type 0 "cy"))
- (set-color! (c-array-writer type 0 "argbColor")))
- (lambda (info)
- (let ((n-bits (bitmap-info/n-bits info)))
- (let ((bytes (make-bytes:bitmap-info-2 1 n-bits)))
- (set-width! bytes (bitmap-info/width info))
- (set-height! bytes (bitmap-info/height info))
- (if (not (= n-bits 24))
- (let ((n-colors (expt 2 n-bits))
- (colormap (bitmap-info/colormap info)))
- (do ((index 0 (fix:+ index 1)))
- ((fix:= index n-colors))
- (set-color! bytes index (vector-ref colormap index)))))
- (values bytes (bitmap-info/data info))))))))
-
-(define-structure (bitmap-info (conc-name bitmap-info/))
- (width #f read-only #t)
- (height #f read-only #t)
- (n-bits #f read-only #t)
- (colormap #f read-only #t)
- (data #f read-only #t))
-
-(define (make-bytes:bitmap-data width height n-planes n-bits)
- (make-string (* (ceiling (/ (* n-bits width) 32)) 4 height n-planes)))
-
-;;; OS2PS-GET-BITMAP-BITS and OS2PS-SET-BITMAP-BITS both require an
-;;; argument of type BITMAPINFO2. On input, this argument specifies
-;;; the external format of the bitmap, which is just the size and
-;;; depth of the information. The colormap information is output from
-;;; OS2PS-GET-BITMAP-BITS and input to OS2PS-SET-BITMAP-BITS.
-
-(define make-bytes:bitmap-info-2)
-(define (make:make-bytes:bitmap-info-2)
- (let ((type (lookup-c-type "BITMAPINFO2")))
- (call-with-values (lambda () (select-c-type type 0 '("argbColor")))
- (lambda (rgb-type size-base)
- (let ((size-increment (c-array-type/element-spacing rgb-type))
- (set-struct-size! (c-number-writer type 0 "cbFix"))
- (set-n-planes! (c-number-writer type 0 "cPlanes"))
- (set-n-bits! (c-number-writer type 0 "cBitCount")))
- (lambda (n-planes n-bits)
- (let ((info
- (make-string (+ size-base
- (if (= n-bits 24)
- 0
- (* size-increment (expt 2 n-bits))))
- (ascii->char 0))))
- (set-struct-size! info size-base)
- (set-n-planes! info n-planes)
- (set-n-bits! info n-bits)
- info)))))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Miscellaneous OS/2 Primitives
-;;; package: (runtime os-primitives)
-
-(declare (usual-integrations))
-\f
-(define (file-modes filename)
- ((ucode-primitive file-attributes 1)
- (->namestring (merge-pathnames filename))))
-
-(define (set-file-modes! filename modes)
- ((ucode-primitive set-file-attributes! 2)
- (->namestring (merge-pathnames filename))
- modes))
-
-(define-integrable os2-file-mode/read-only #x01)
-(define-integrable os2-file-mode/hidden #x02)
-(define-integrable os2-file-mode/system #x04)
-(define-integrable os2-file-mode/directory #x10)
-(define-integrable os2-file-mode/archived #x20)
-
-(define (file-length filename)
- ((ucode-primitive file-length 1)
- (->namestring (merge-pathnames filename))))
-
-(define (file-modification-time filename)
- ((ucode-primitive file-mod-time 1)
- (->namestring (merge-pathnames filename))))
-(define file-modification-time-direct file-modification-time)
-(define file-modification-time-indirect file-modification-time)
-
-(define (file-access-time filename)
- ((ucode-primitive file-access-time 1)
- (->namestring (merge-pathnames filename))))
-(define file-access-time-direct file-access-time)
-(define file-access-time-indirect file-access-time)
-
-(define (set-file-times! filename access-time modification-time)
- ((ucode-primitive set-file-times! 3)
- (->namestring (merge-pathnames filename))
- access-time
- modification-time))
-\f
-(define (file-time->local-decoded-time time)
- (let* ((twosecs (remainder time 32)) (time (quotient time 32))
- (minutes (remainder time 64)) (time (quotient time 64))
- (hours (remainder time 32)) (time (quotient time 32))
- (day (remainder time 32)) (time (quotient time 32))
- (month (remainder time 16)) (year (quotient time 16)))
- (make-decoded-time (* twosecs 2) minutes hours day month (+ 1980 year))))
-
-(define (file-time->global-decoded-time time)
- (universal-time->global-decoded-time (file-time->universal-time time)))
-
-(define (decoded-time->file-time dt)
- (let ((f (lambda (i j k) (+ (* i j) k))))
- (f (f (f (f (f (let ((year (decoded-time/year dt)))
- (if (< year 1980)
- (error "Can't encode years earlier than 1980:" year))
- year)
- 16 (decoded-time/month dt))
- 32 (decoded-time/day dt))
- 32 (decoded-time/hour dt))
- 64 (decoded-time/minute dt))
- 32 (quotient (decoded-time/second dt) 2))))
-
-(define decode-file-time file-time->local-decoded-time)
-(define encode-file-time decoded-time->file-time)
-
-(define (file-time->universal-time time)
- (decoded-time->universal-time (file-time->local-decoded-time time)))
-
-(define (universal-time->file-time time)
- (decoded-time->file-time (universal-time->local-decoded-time time)))
-
-(define (file-attributes filename)
- ((ucode-primitive file-info 1)
- (->namestring (merge-pathnames filename))))
-(define file-attributes-direct file-attributes)
-(define file-attributes-indirect file-attributes)
-
-(define-structure (file-attributes (type vector)
- (constructor #f)
- (conc-name file-attributes/))
- (type #f read-only #t)
- (access-time #f read-only #t)
- (modification-time #f read-only #t)
- (change-time #f read-only #t)
- (length #f read-only #t)
- (mode-string #f read-only #t)
- (modes #f read-only #t)
- (allocated-length #f read-only #t))
-
-(define (file-attributes/n-links attributes) attributes 1)
-\f
-(define (get-environment-variable name)
- ((ucode-primitive get-environment-variable 1) name))
-
-(define (temporary-file-pathname #!optional directory)
- (let ((root
- (let ((directory
- (if (or (default-object? directory) (not directory))
- (temporary-directory-pathname)
- (pathname-as-directory directory))))
- (merge-pathnames
- (if (dos/fs-long-filenames? directory)
- (string-append
- "sch"
- (string-pad-left (number->string (os2/current-pid)) 6 #\0))
- "_scm_tmp")
- directory))))
- (let loop ((ext 0))
- (let ((pathname (pathname-new-type root (number->string ext))))
- (if (allocate-temporary-file pathname)
- pathname
- (begin
- (if (> ext 999)
- (error "Can't find unique temporary pathname:" root))
- (loop (+ ext 1))))))))
-
-(define (temporary-directory-pathname)
- (let ((try-directory
- (lambda (directory)
- (let ((directory
- (pathname-as-directory (merge-pathnames directory))))
- (and (file-directory? directory)
- (file-writeable? directory)
- directory)))))
- (let ((try-variable
- (lambda (name)
- (let ((value (get-environment-variable name)))
- (and value
- (try-directory value)))))
- (try-system-directory
- (lambda (directory)
- (try-directory
- (merge-pathnames directory (os2/system-root-directory))))))
- (or (try-variable "TMPDIR")
- (try-variable "TEMP")
- (try-variable "TMP")
- (try-system-directory "\\temp")
- (try-system-directory "\\tmp")
- (try-system-directory "")
- (try-directory ".")
- (error "Can't find temporary directory.")))))
-
-(define (os2/system-root-directory)
- (let ((system.ini (get-environment-variable "SYSTEM_INI")))
- (if (not (file-exists? system.ini))
- (error "Unable to find OS/2 system.ini file:" system.ini))
- (pathname-new-directory (directory-pathname system.ini) '(ABSOLUTE))))
-
-(define-integrable os2/current-pid
- (ucode-primitive current-pid 0))
-\f
-(define current-user-name)
-(define current-home-directory)
-(define user-home-directory)
-(letrec
- ((trydir
- (lambda (directory)
- (and directory
- (file-directory? directory)
- (pathname-as-directory directory))))
- (%current-user-name
- (lambda ()
- (get-environment-variable "USER")))
- (%current-home-directory
- (lambda ()
- (trydir (get-environment-variable "HOME"))))
- (%users-directory
- (lambda ()
- (trydir (get-environment-variable "USERDIR")))))
-
- (set! current-user-name
- (lambda ()
- (or (%current-user-name)
- ;; If the home directory is defined, use the last part of the
- ;; path as the user's name. If the home directory is the root
- ;; of a drive, this won't do anything.
- (let ((homedir (%current-home-directory)))
- (and homedir
- (pathname-name (directory-pathname-as-file homedir))))
- (error "Unable to determine current user name."))))
-
- (set! current-home-directory
- (lambda ()
- (or (%current-home-directory)
- ;; If home directory not defined, look for directory
- ;; with user's name in users directory and in root
- ;; directory of system drive. If still nothing, use
- ;; root directory of system drive.
- (let ((user-name (%current-user-name))
- (rootdir (os2/system-root-directory)))
- (or (and user-name
- (or (let ((usersdir (%users-directory)))
- (and usersdir
- (trydir
- (merge-pathnames user-name usersdir))))
- (trydir (merge-pathnames user-name rootdir))))
- rootdir)))))
-
- (set! user-home-directory
- (lambda (user-name)
- (let ((homedir (%current-home-directory)))
- ;; If USER-NAME is current user, use current home
- ;; directory.
- (or (let ((user-name* (%current-user-name)))
- (and user-name*
- (string=? user-name user-name*)
- homedir))
- ;; Look for USER-NAME in users directory.
- (let ((usersdir (%users-directory)))
- (and usersdir
- (trydir (merge-pathnames user-name usersdir))))
- ;; Look for USER-NAME in same directory as current
- ;; user's home directory.
- (and homedir
- (trydir (merge-pathnames
- user-name
- (directory-pathname-as-file homedir))))
- ;; Look for USER-NAME in root directory of system
- ;; drive.
- (trydir
- (merge-pathnames user-name (os2/system-root-directory)))
- ;; OK, give up:
- (error "Can't find user's home directory:" user-name))))))
-\f
-(define (dos/fs-drive-type pathname)
- (let ((type
- ((ucode-primitive drive-type 1)
- (pathname-device (merge-pathnames pathname)))))
- (let ((colon (string-find-next-char type #\:)))
- (if colon
- (cons (string-head type colon) (string-tail type (fix:+ colon 1)))
- (cons type "")))))
-
-(define (dos/fs-long-filenames? pathname)
- (not (string-ci=? "fat" (car (dos/fs-drive-type pathname)))))
-
-(define (file-line-ending pathname)
- (let ((type (dos/fs-drive-type pathname)))
- ;; "ext2" is the Linux ext2 file-system driver. "NFS" is the IBM
- ;; TCP/IP NFS driver, which we further qualify by examining the
- ;; mount info -- if the directory starts with a "/", we assume
- ;; that it is a unix system.
- (if (or (string=? "ext2" (car type))
- (and (string=? "NFS" (car type))
- (let* ((mount (cdr type))
- (colon (string-find-next-char mount #\:)))
- (and colon
- (fix:< (fix:+ colon 1) (string-length mount))
- (char=? #\/ (string-ref mount (fix:+ colon 1)))))))
- 'LF
- 'CRLF)))
-
-(define (default-line-ending)
- 'CRLF)
-
-(define (copy-file from to)
- ((ucode-primitive os2-copy-file 2) (->namestring (merge-pathnames from))
- (->namestring (merge-pathnames to))))
-
-(define (os/suffix-mime-type suffix)
- ;; **** not yet implemented ****
- suffix
- #f)
-\f
-(define (init-file-specifier->pathname specifier)
-
- (define (read-fat-init-file-map port)
- (let loop ((result '()))
- (let ((item (read port)))
- (if (eof-object? item)
- result
- (begin
- (if (not (and (pair? item)
- (init-file-specifier? (car item))
- (string? (cdr item))))
- (error "Malformed init-file map item:" item))
- (loop (cons item result)))))))
-
- (define (generate-fat-init-file directory)
- (let loop ((index 1))
- (let ((filename
- (string-append "ini"
- (string-pad-left (number->string index) 5 #\0)
- ".dat")))
- (if (file-exists? (merge-pathnames filename directory))
- (loop (+ index 1))
- filename))))
-
- (guarantee-init-file-specifier specifier 'INIT-FILE-SPECIFIER->PATHNAME)
- (let ((long-base (merge-pathnames ".mit-scheme/" (user-homedir-pathname))))
- (if (dos/fs-long-filenames? long-base)
- (if (pair? specifier)
- (merge-pathnames
- (apply string-append
- (cons (car specifier)
- (append-map (lambda (string) (list "/" string))
- (cdr specifier))))
- long-base)
- (directory-pathname-as-file long-base))
- (let ((short-base
- (merge-pathnames "mitschem.ini/" (user-homedir-pathname))))
- (let ((file-map-pathname (merge-pathnames "filemap.dat" short-base)))
- (let ((port #f))
- (dynamic-wind
- (lambda ()
- (set! port (open-i/o-file file-map-pathname))
- unspecific)
- (lambda ()
- (merge-pathnames
- (or (let ((entry
- (assoc specifier (read-fat-init-file-map port))))
- (and entry
- (cdr entry)))
- (let ((filename (generate-fat-init-file short-base)))
- (let ((channel (port/output-channel port)))
- (channel-file-set-position
- channel
- (channel-file-length channel)))
- (write (cons specifier filename) port)
- (newline port)
- filename))
- short-base))
- (lambda ()
- (if port
- (begin
- (close-port port)
- (set! port #f)
- unspecific))))))))))
-
-(define (initialize-system-primitives!)
- unspecific)
-\f
-;;;; Subprocess/Shell Support
-
-(define (os/make-subprocess filename arguments environment working-directory
- ctty stdin stdout stderr)
- (if ctty
- (error "Can't manipulate controlling terminal of subprocess:" ctty))
- ((ucode-primitive os2-make-subprocess 7)
- filename
- (os2/rewrite-subprocess-arguments (vector->list arguments))
- (and environment
- (os2/rewrite-subprocess-environment (vector->list environment)))
- working-directory
- stdin
- stdout
- stderr))
-
-(define (os2/rewrite-subprocess-arguments strings)
- (let ((strings
- (if (pair? strings)
- (if (pair? (cdr strings))
- strings
- (list (car strings) ""))
- (list "" ""))))
- (let ((result
- (make-string
- (reduce +
- 0
- (map (lambda (s) (fix:+ (string-length s) 1)) strings)))))
- (let ((n (string-length (car strings))))
- (substring-move! (car strings) 0 n result 0)
- (string-set! result n #\NUL)
- (let loop ((strings (cdr strings)) (index (fix:+ n 1)))
- (let ((n (string-length (car strings))))
- (substring-move! (car strings) 0 n result index)
- (if (pair? (cdr strings))
- (begin
- (string-set! result (fix:+ index n) #\space)
- (loop (cdr strings) (fix:+ (fix:+ index n) 1)))
- (string-set! result (fix:+ index n) #\NUL)))))
- result)))
-
-(define (os2/rewrite-subprocess-environment strings)
- (let ((result
- (make-string
- (reduce +
- 0
- (map (lambda (s) (fix:+ (string-length s) 1)) strings)))))
- (let loop ((strings strings) (index 0))
- (if (pair? strings)
- (let ((n (string-length (car strings))))
- (substring-move! (car strings) 0 n result index)
- (string-set! result (fix:+ index n) #\NUL)
- (loop (cdr strings) (fix:+ (fix:+ index n) 1)))))
- result))
-\f
-(define (os/find-program program default-directory #!optional exec-path error?)
- (let ((namestring
- (let* ((exec-path
- (if (default-object? exec-path)
- (os/exec-path)
- exec-path))
- (try
- (let ((types (os/executable-pathname-types)))
- (lambda (pathname)
- (let ((type (pathname-type pathname)))
- (if type
- (and (member type types)
- (file-exists? pathname)
- (->namestring pathname))
- (let loop ((types types))
- (and (pair? types)
- (let ((p
- (pathname-new-type pathname
- (car types))))
- (if (file-exists? p)
- (->namestring p)
- (loop (cdr types)))))))))))
- (try-dir
- (lambda (directory)
- (try (merge-pathnames program directory)))))
- (cond ((pathname-absolute? program)
- (try program))
- ((not default-directory)
- (let loop ((path exec-path))
- (and (pair? path)
- (or (and (pathname-absolute? (car path))
- (try-dir (car path)))
- (loop (cdr path))))))
- (else
- (let ((default-directory
- (merge-pathnames default-directory)))
- (let loop ((path exec-path))
- (and (pair? path)
- (or (try-dir
- (merge-pathnames (car path) default-directory))
- (loop (cdr path)))))))))))
- (if (and (not namestring)
- (if (default-object? error) #t error?))
- (error "Can't find program:" (->namestring program)))
- namestring))
-
-(define (os/exec-path)
- (os/parse-path-string
- (let ((path (get-environment-variable "PATH")))
- (if (not path)
- (error "Can't find PATH environment variable."))
- path)))
-
-(define (os/parse-path-string string)
- (let ((end (string-length string))
- (substring
- (lambda (string start end)
- (pathname-as-directory (substring string start end)))))
- (let loop ((start 0))
- (if (< start end)
- (let ((index (substring-find-next-char string start end #\;)))
- (if index
- (if (= index start)
- (loop (+ index 1))
- (cons (substring string start index)
- (loop (+ index 1))))
- (list (substring string start end))))
- '()))))
-
-(define (os/shell-file-name)
- (or (get-environment-variable "SHELL")
- (get-environment-variable "COMSPEC")
- "cmd.exe"))
-
-(define (os/form-shell-command command)
- (list "/c" command))
-
-(define (os/executable-pathname-types)
- '("exe" "com" "bat" "cmd" "btm"))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
- Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; OS/2 PM Interface -- Primitives
-;;; package: (runtime os2-window-primitives)
-
-(declare (usual-integrations))
-\f
-(define-primitives
- (os2-clipboard-read-text 0)
- (os2-clipboard-write-text 1)
- (os2-map-window-point 3)
- (os2-window-handle-from-id 2)
- (os2menu-create 3)
- (os2menu-destroy 1)
- (os2menu-get-item 3)
- (os2menu-get-item-attributes 4)
- (os2menu-insert-item 7)
- (os2menu-n-items 1)
- (os2menu-nth-item 2)
- (os2menu-remove-item 4)
- (os2menu-set-item-attributes 5)
- (os2pm-synchronize 0)
- (os2ps-bitblt 6)
- (os2ps-clear 5)
- (os2ps-create-bitmap 3)
- (os2ps-create-memory-ps 0)
- (os2ps-destroy-bitmap 1)
- (os2ps-destroy-memory-ps 1)
- (os2ps-draw-point 3)
- (os2ps-get-bitmap 1)
- (os2ps-get-bitmap-bits 5)
- (os2ps-get-bitmap-parameters 1)
- (os2ps-get-font-metrics 1)
- (os2ps-line 3)
- (os2ps-move-graphics-cursor 3)
- (os2ps-poly-line 3)
- (os2ps-poly-line-disjoint 3)
- (os2ps-query-capabilities 3)
- (os2ps-query-capability 2)
- (os2ps-reset-clip-rectangle 1)
- (os2ps-set-bitmap 2)
- (os2ps-set-bitmap-bits 5)
- (os2ps-set-clip-rectangle 5)
- (os2ps-set-colors 3)
- (os2ps-set-font 3)
- (os2ps-set-line-type 2)
- (os2ps-set-mix 2)
- (os2ps-text-width 4)
- (os2ps-write 6)
- (os2win-activate 1)
- (os2win-alarm 1)
- (os2win-beep 2)
- (os2win-client-handle 1)
- (os2win-close 1)
- (os2win-close-event-qid 1)
- (os2win-console-wid 0)
- (os2win-desktop-height 0)
- (os2win-desktop-width 0)
- (os2win-destroy-pointer 1)
- (os2win-event-ready? 2)
- (os2win-focus? 1)
- (os2win-font-dialog 2)
- (os2win-frame-handle 1)
- (os2win-get-event 2)
- (os2win-get-frame-size 1)
- (os2win-get-pos 1)
- (os2win-get-size 1)
- (os2win-invalidate 5)
- (os2win-load-pointer 3)
- (os2win-load-menu 3)
- (os2win-move-cursor 3)
- (os2win-open 2)
- (os2win-open-event-qid 0)
- (os2win-popup-menu 7)
- (os2win-ps 1)
- (os2win-query-sys-value 2)
- (os2win-scroll 7)
- (os2win-set-capture 2)
- (os2win-set-grid 3)
- (os2win-set-icon 2)
- (os2win-set-pos 3)
- (os2win-set-size 3)
- (os2win-set-state 2)
- (os2win-set-title 2)
- (os2win-shape-cursor 4)
- (os2win-show 2)
- (os2win-show-cursor 2)
- (os2win-track-mouse 2)
- (os2win-update-frame 2))
-\f
-(define-integrable (event-type event) (vector-ref event 0))
-(define-integrable (event-wid event) (vector-ref event 1))
-(define-integrable (set-event-wid! event wid) (vector-set! event 1 wid))
-
-(define-syntax define-event
- (sc-macro-transformer
- (lambda (form environment)
- (let ((name (cadr form))
- (type (close-syntax (caddr form) environment))
- (slots (cdddr form)))
- `(BEGIN
- (DEFINE-INTEGRABLE ,(symbol-append 'EVENT-TYPE: name) ,type)
- ,@(let loop ((slots slots) (index 2))
- (if (pair? slots)
- (cons `(DEFINE-INTEGRABLE
- (,(symbol-append name '-EVENT/ (car slots)) EVENT)
- (VECTOR-REF EVENT ,index))
- (loop (cdr slots) (+ index 1)))
- '())))))))
-
-;; These must match "microcode/pros2pm.c"
-(define-event button 0 number type x y flags)
-(define-event close 1)
-(define-event focus 2 gained?)
-(define-event key 3 code flags repeat)
-(define-event paint 4 xl xh yl yh)
-(define-event resize 5 width height)
-(define-event visibility 6 shown?)
-(define-event command 7 code source mouse?)
-(define-event help 8 code source mouse?)
-(define-event mousemove 9 x y hit-test flags)
-
-(define-integrable number-of-event-types 10)
-
-(define-integrable button-event-type:down 0)
-(define-integrable button-event-type:up 1)
-(define-integrable button-event-type:click 2)
-(define-integrable button-event-type:double-click 3)
-
-(define-structure (font-metrics (type vector) (conc-name font-metrics/))
- (width #f read-only #t)
- (height #f read-only #t)
- (descender #f read-only #t))
-\f
-;;; Constants from OS/2 header file "pmwin.h":
-
-(define-integrable CURSOR_SOLID #x0000)
-(define-integrable CURSOR_HALFTONE #x0001)
-(define-integrable CURSOR_FRAME #x0002)
-(define-integrable CURSOR_FLASH #x0004)
-
-(define-integrable VK_BUTTON1 #x01)
-(define-integrable VK_BUTTON2 #x02)
-(define-integrable VK_BUTTON3 #x03)
-(define-integrable VK_BREAK #x04)
-(define-integrable VK_BACKSPACE #x05)
-(define-integrable VK_TAB #x06)
-(define-integrable VK_BACKTAB #x07)
-(define-integrable VK_NEWLINE #x08)
-(define-integrable VK_SHIFT #x09)
-(define-integrable VK_CTRL #x0A)
-(define-integrable VK_ALT #x0B)
-(define-integrable VK_ALTGRAF #x0C)
-(define-integrable VK_PAUSE #x0D)
-(define-integrable VK_CAPSLOCK #x0E)
-(define-integrable VK_ESC #x0F)
-(define-integrable VK_SPACE #x10)
-(define-integrable VK_PAGEUP #x11)
-(define-integrable VK_PAGEDOWN #x12)
-(define-integrable VK_END #x13)
-(define-integrable VK_HOME #x14)
-(define-integrable VK_LEFT #x15)
-(define-integrable VK_UP #x16)
-(define-integrable VK_RIGHT #x17)
-(define-integrable VK_DOWN #x18)
-(define-integrable VK_PRINTSCRN #x19)
-(define-integrable VK_INSERT #x1A)
-(define-integrable VK_DELETE #x1B)
-(define-integrable VK_SCRLLOCK #x1C)
-(define-integrable VK_NUMLOCK #x1D)
-(define-integrable VK_ENTER #x1E)
-(define-integrable VK_SYSRQ #x1F)
-(define-integrable VK_F1 #x20)
-(define-integrable VK_F2 #x21)
-(define-integrable VK_F3 #x22)
-(define-integrable VK_F4 #x23)
-(define-integrable VK_F5 #x24)
-(define-integrable VK_F6 #x25)
-(define-integrable VK_F7 #x26)
-(define-integrable VK_F8 #x27)
-(define-integrable VK_F9 #x28)
-(define-integrable VK_F10 #x29)
-(define-integrable VK_F11 #x2A)
-(define-integrable VK_F12 #x2B)
-(define-integrable VK_F13 #x2C)
-(define-integrable VK_F14 #x2D)
-(define-integrable VK_F15 #x2E)
-(define-integrable VK_F16 #x2F)
-(define-integrable VK_F17 #x30)
-(define-integrable VK_F18 #x31)
-(define-integrable VK_F19 #x32)
-(define-integrable VK_F20 #x33)
-(define-integrable VK_F21 #x34)
-(define-integrable VK_F22 #x35)
-(define-integrable VK_F23 #x36)
-(define-integrable VK_F24 #x37)
-(define-integrable VK_ENDDRAG #x38)
-(define-integrable VK_CLEAR #x39)
-(define-integrable VK_EREOF #x3A)
-(define-integrable VK_PA1 #x3B)
-(define-integrable virtual-key-supremum #x3C)
-\f
-(define-integrable KC_NONE #x0000)
-(define-integrable KC_CHAR #x0001)
-(define-integrable KC_VIRTUALKEY #x0002)
-(define-integrable KC_SCANCODE #x0004)
-(define-integrable KC_SHIFT #x0008)
-(define-integrable KC_CTRL #x0010)
-(define-integrable KC_ALT #x0020)
-(define-integrable KC_KEYUP #x0040)
-(define-integrable KC_PREVDOWN #x0080)
-(define-integrable KC_LONEKEY #x0100)
-(define-integrable KC_DEADKEY #x0200)
-(define-integrable KC_COMPOSITE #x0400)
-(define-integrable KC_INVALIDCOMP #x0800)
-(define-integrable KC_TOGGLE #x1000)
-(define-integrable KC_INVALIDCHAR #x2000)
-
-(define-integrable LINETYPE_DEFAULT 0)
-(define-integrable LINETYPE_DOT 1)
-(define-integrable LINETYPE_SHORTDASH 2)
-(define-integrable LINETYPE_DASHDOT 3)
-(define-integrable LINETYPE_DOUBLEDOT 4)
-(define-integrable LINETYPE_LONGDASH 5)
-(define-integrable LINETYPE_DASHDOUBLEDOT 6)
-(define-integrable LINETYPE_SOLID 7)
-(define-integrable LINETYPE_INVISIBLE 8)
-(define-integrable LINETYPE_ALTERNATE 9)
-
-(define-integrable FM_DEFAULT 0)
-(define-integrable FM_OR 1)
-(define-integrable FM_OVERPAINT 2)
-(define-integrable FM_XOR 4)
-(define-integrable FM_LEAVEALONE 5)
-(define-integrable FM_AND 6)
-(define-integrable FM_SUBTRACT 7)
-(define-integrable FM_MASKSRCNOT 8)
-(define-integrable FM_ZERO 9)
-(define-integrable FM_NOTMERGESRC 10)
-(define-integrable FM_NOTXORSRC 11)
-(define-integrable FM_INVERT 12)
-(define-integrable FM_MERGESRCNOT 13)
-(define-integrable FM_NOTCOPYSRC 14)
-(define-integrable FM_MERGENOTSRC 15)
-(define-integrable FM_NOTMASKSRC 16)
-(define-integrable FM_ONE 17)
-
-(define-integrable window-state:top 0)
-(define-integrable window-state:bottom 1)
-(define-integrable window-state:show 2)
-(define-integrable window-state:hide 3)
-(define-integrable window-state:activate 4)
-(define-integrable window-state:deactivate 5)
-(define-integrable window-state:minimize 6)
-(define-integrable window-state:maximize 7)
-(define-integrable window-state:restore 8)
-
-(define-integrable WS_VISIBLE #x80000000)
-(define-integrable WS_DISABLED #x40000000)
-(define-integrable WS_CLIPCHILDREN #x20000000)
-(define-integrable WS_CLIPSIBLINGS #x10000000)
-(define-integrable WS_PARENTCLIP #x08000000)
-(define-integrable WS_SAVEBITS #x04000000)
-(define-integrable WS_SYNCPAINT #x02000000)
-(define-integrable WS_MINIMIZED #x01000000)
-(define-integrable WS_MAXIMIZED #x00800000)
-(define-integrable WS_ANIMATE #x00400000)
-\f
-;; codes for OS2PS-QUERY-CAPABILITIES and OS2PS-QUERY-CAPABILITY
-(define-integrable CAPS_FAMILY 0)
-(define-integrable CAPS_IO_CAPS 1)
-(define-integrable CAPS_TECHNOLOGY 2)
-(define-integrable CAPS_DRIVER_VERSION 3)
-(define-integrable CAPS_WIDTH 4) ;pels
-(define-integrable CAPS_HEIGHT 5) ;pels
-(define-integrable CAPS_WIDTH_IN_CHARS 6)
-(define-integrable CAPS_HEIGHT_IN_CHARS 7)
-(define-integrable CAPS_HORIZONTAL_RESOLUTION 8) ;pels per meter
-(define-integrable CAPS_VERTICAL_RESOLUTION 9) ;pels per meter
-(define-integrable CAPS_CHAR_WIDTH 10) ;pels
-(define-integrable CAPS_CHAR_HEIGHT 11) ;pels
-(define-integrable CAPS_SMALL_CHAR_WIDTH 12) ;pels
-(define-integrable CAPS_SMALL_CHAR_HEIGHT 13) ;pels
-(define-integrable CAPS_COLORS 14)
-(define-integrable CAPS_COLOR_PLANES 15)
-(define-integrable CAPS_COLOR_BITCOUNT 16)
-(define-integrable CAPS_COLOR_TABLE_SUPPORT 17)
-(define-integrable CAPS_MOUSE_BUTTONS 18)
-(define-integrable CAPS_FOREGROUND_MIX_SUPPORT 19)
-(define-integrable CAPS_BACKGROUND_MIX_SUPPORT 20)
-(define-integrable CAPS_VIO_LOADABLE_FONTS 21)
-(define-integrable CAPS_WINDOW_BYTE_ALIGNMENT 22)
-(define-integrable CAPS_BITMAP_FORMATS 23)
-(define-integrable CAPS_RASTER_CAPS 24)
-(define-integrable CAPS_MARKER_HEIGHT 25) ;pels
-(define-integrable CAPS_MARKER_WIDTH 26) ;pels
-(define-integrable CAPS_DEVICE_FONTS 27)
-(define-integrable CAPS_GRAPHICS_SUBSET 28)
-(define-integrable CAPS_GRAPHICS_VERSION 29)
-(define-integrable CAPS_GRAPHICS_VECTOR_SUBSET 30)
-(define-integrable CAPS_DEVICE_WINDOWING 31)
-(define-integrable CAPS_ADDITIONAL_GRAPHICS 32)
-(define-integrable CAPS_PHYS_COLORS 33)
-(define-integrable CAPS_COLOR_INDEX 34)
-(define-integrable CAPS_GRAPHICS_CHAR_WIDTH 35)
-(define-integrable CAPS_GRAPHICS_CHAR_HEIGHT 36)
-(define-integrable CAPS_HORIZONTAL_FONT_RES 37)
-(define-integrable CAPS_VERTICAL_FONT_RES 38)
-(define-integrable CAPS_DEVICE_FONT_SIM 39)
-(define-integrable CAPS_LINEWIDTH_THICK 40)
-(define-integrable CAPS_DEVICE_POLYSET_POINTS 41)
-\f
-;; Constants for CAPS_IO_CAPS
-(define-integrable CAPS_IO_DUMMY 1)
-(define-integrable CAPS_IO_SUPPORTS_OP 2)
-(define-integrable CAPS_IO_SUPPORTS_IP 3)
-(define-integrable CAPS_IO_SUPPORTS_IO 4)
-
-;; Constants for CAPS_TECHNOLOGY
-(define-integrable CAPS_TECH_UNKNOWN 0)
-(define-integrable CAPS_TECH_VECTOR_PLOTTER 1)
-(define-integrable CAPS_TECH_RASTER_DISPLAY 2)
-(define-integrable CAPS_TECH_RASTER_PRINTER 3)
-(define-integrable CAPS_TECH_RASTER_CAMERA 4)
-(define-integrable CAPS_TECH_POSTSCRIPT 5)
-
-;; Constants for CAPS_COLOR_TABLE_SUPPORT
-(define-integrable CAPS_COLTABL_RGB_8 #x0001)
-(define-integrable CAPS_COLTABL_RGB_8_PLUS #x0002)
-(define-integrable CAPS_COLTABL_TRUE_MIX #x0004)
-(define-integrable CAPS_COLTABL_REALIZE #x0008)
-
-;; Constants for CAPS_FOREGROUND_MIX_SUPPORT
-(define-integrable CAPS_FM_OR #x0001)
-(define-integrable CAPS_FM_OVERPAINT #x0002)
-(define-integrable CAPS_FM_XOR #x0008)
-(define-integrable CAPS_FM_LEAVEALONE #x0010)
-(define-integrable CAPS_FM_AND #x0020)
-(define-integrable CAPS_FM_GENERAL_BOOLEAN #x0040)
-
-;; Constants for CAPS_BACKGROUND_MIX_SUPPORT
-(define-integrable CAPS_BM_OR #x0001)
-(define-integrable CAPS_BM_OVERPAINT #x0002)
-(define-integrable CAPS_BM_XOR #x0008)
-(define-integrable CAPS_BM_LEAVEALONE #x0010)
-(define-integrable CAPS_BM_AND #x0020)
-(define-integrable CAPS_BM_GENERAL_BOOLEAN #x0040)
-(define-integrable CAPS_BM_SRCTRANSPARENT #x0080)
-(define-integrable CAPS_BM_DESTTRANSPARENT #x0100)
-
-;; Constants for CAPS_DEVICE_WINDOWING
-(define-integrable CAPS_DEV_WINDOWING_SUPPORT 1)
-
-;; Constants for CAPS_ADDITIONAL_GRAPHICS
-(define-integrable CAPS_VDD_DDB_TRANSFER #x0001)
-(define-integrable CAPS_GRAPHICS_KERNING_SUPPORT #x0002)
-(define-integrable CAPS_FONT_OUTLINE_DEFAULT #x0004)
-(define-integrable CAPS_FONT_IMAGE_DEFAULT #x0008)
-;; bits represented by values #x0010 and #x0020 are reserved
-(define-integrable CAPS_SCALED_DEFAULT_MARKERS #x0040)
-(define-integrable CAPS_COLOR_CURSOR_SUPPORT #x0080)
-(define-integrable CAPS_PALETTE_MANAGER #x0100)
-(define-integrable CAPS_COSMETIC_WIDELINE_SUPPORT #x0200)
-(define-integrable CAPS_DIRECT_FILL #x0400)
-(define-integrable CAPS_REBUILD_FILLS #x0800)
-(define-integrable CAPS_CLIP_FILLS #x1000)
-(define-integrable CAPS_ENHANCED_FONTMETRICS #x2000)
-(define-integrable CAPS_TRANSFORM_SUPPORT #x4000)
-
-;; Constants for CAPS_WINDOW_BYTE_ALIGNMENT
-(define-integrable CAPS_BYTE_ALIGN_REQUIRED 0)
-(define-integrable CAPS_BYTE_ALIGN_RECOMMENDED 1)
-(define-integrable CAPS_BYTE_ALIGN_NOT_REQUIRED 2)
-
-;; Constants for CAPS_RASTER_CAPS
-(define-integrable CAPS_RASTER_BITBLT #x0001)
-(define-integrable CAPS_RASTER_BANDING #x0002)
-(define-integrable CAPS_RASTER_BITBLT_SCALING #x0004)
-(define-integrable CAPS_RASTER_SET_PEL #x0010)
-(define-integrable CAPS_RASTER_FONTS #x0020)
-(define-integrable CAPS_RASTER_FLOOD_FILL #x0040)
-\f
-;; Constants for OS2PS-BITBLT raster-op argument
-(define-integrable ROP_SRCCOPY #xCC)
-(define-integrable ROP_SRCPAINT #xEE)
-(define-integrable ROP_SRCAND #x88)
-(define-integrable ROP_SRCINVERT #x66)
-(define-integrable ROP_SRCERASE #x44)
-(define-integrable ROP_NOTSRCCOPY #x33)
-(define-integrable ROP_NOTSRCERASE #x11)
-(define-integrable ROP_MERGECOPY #xC0)
-(define-integrable ROP_MERGEPAINT #xBB)
-(define-integrable ROP_PATCOPY #xF0)
-(define-integrable ROP_PATPAINT #xFB)
-(define-integrable ROP_PATINVERT #x5A)
-(define-integrable ROP_DSTINVERT #x55)
-(define-integrable ROP_ZERO #x00)
-(define-integrable ROP_ONE #xFF)
-
-;; Constants for OS2PS-BITBLT options argument
-(define-integrable BBO_OR 0)
-(define-integrable BBO_AND 1)
-(define-integrable BBO_IGNORE 2)
-(define-integrable BBO_PAL_COLORS 4)
-(define-integrable BBO_NO_COLOR_INFO 8)
-\f
-;; Menu item positions:
-(define-integrable MIT_END #xFFFF)
-(define-integrable MIT_NONE #xFFFF)
-(define-integrable MIT_MEMERROR #xFFFF)
-(define-integrable MIT_ERROR #xFFFF)
-(define-integrable MIT_FIRST #xFFFE)
-(define-integrable MIT_LAST #xFFFD)
-
-;; Menu item styles:
-(define-integrable MIS_TEXT #x0001)
-(define-integrable MIS_BITMAP #x0002)
-(define-integrable MIS_SEPARATOR #x0004)
-(define-integrable MIS_OWNERDRAW #x0008)
-(define-integrable MIS_SUBMENU #x0010)
-(define-integrable MIS_MULTMENU #x0020) ;multiple choice submenu
-(define-integrable MIS_SYSCOMMAND #x0040)
-(define-integrable MIS_HELP #x0080)
-(define-integrable MIS_STATIC #x0100)
-(define-integrable MIS_BUTTONSEPARATOR #x0200)
-(define-integrable MIS_BREAK #x0400)
-(define-integrable MIS_BREAKSEPARATOR #x0800)
-(define-integrable MIS_GROUP #x1000) ;multiple choice group
-;; In multiple choice submenus a style of 'single' denotes the item is
-;; a radiobutton. Absence of this style defaults the item to a
-;; checkbox.
-(define-integrable MIS_SINGLE #x2000)
-
-;; Menu item attributes:
-(define-integrable MIA_NODISMISS #x0020)
-(define-integrable MIA_FRAMED #x1000)
-(define-integrable MIA_CHECKED #x2000)
-(define-integrable MIA_DISABLED #x4000)
-(define-integrable MIA_HILITED #x8000)
-
-(define-integrable FID_SYSMENU #x8002)
-(define-integrable FID_TITLEBAR #x8003)
-(define-integrable FID_MINMAX #x8004)
-(define-integrable FID_MENU #x8005)
-(define-integrable FID_VERTSCROLL #x8006)
-(define-integrable FID_HORZSCROLL #x8007)
-(define-integrable FID_CLIENT #x8008)
-
-;; Menu control styles */
-(define-integrable MS_ACTIONBAR #x0001)
-(define-integrable MS_TITLEBUTTON #x0002)
-(define-integrable MS_VERTICALFLIP #x0004)
-(define-integrable MS_CONDITIONALCASCADE #x0040)
-
-;; Frame window styles:
-(define-integrable FCF_TITLEBAR #x00000001)
-(define-integrable FCF_SYSMENU #x00000002)
-(define-integrable FCF_MENU #x00000004)
-(define-integrable FCF_SIZEBORDER #x00000008)
-(define-integrable FCF_MINBUTTON #x00000010)
-(define-integrable FCF_MAXBUTTON #x00000020)
-(define-integrable FCF_MINMAX #x00000030)
-(define-integrable FCF_VERTSCROLL #x00000040)
-(define-integrable FCF_HORZSCROLL #x00000080)
-(define-integrable FCF_DLGBORDER #x00000100)
-(define-integrable FCF_BORDER #x00000200)
-(define-integrable FCF_SHELLPOSITION #x00000400)
-(define-integrable FCF_TASKLIST #x00000800)
-(define-integrable FCF_NOBYTEALIGN #x00001000)
-(define-integrable FCF_NOMOVEWITHOWNER #x00002000)
-(define-integrable FCF_ICON #x00004000)
-(define-integrable FCF_ACCELTABLE #x00008000)
-(define-integrable FCF_SYSMODAL #x00010000)
-(define-integrable FCF_SCREENALIGN #x00020000)
-(define-integrable FCF_MOUSEALIGN #x00040000)
-(define-integrable FCF_HIDEBUTTON #x01000000)
-(define-integrable FCF_HIDEMAX #x01000020)
-(define-integrable FCF_AUTOICON #x40000000)
-(define-integrable FCF_STANDARD #x0000CC3F)
-
-;;; Window handles.
-(define-integrable NULLHANDLE 0)
-(define-integrable HWND_DESKTOP 1)
-
-;;; Hit-test values (event-type:mousemove).
-(define-integrable HT_NORMAL 0)
-(define-integrable HT_TRANSPARENT -1)
-(define-integrable HT_DISCARD -2)
-(define-integrable HT_ERROR -3)
-
-;;; Pop-up menu option flags.
-(define-integrable PU_POSITIONONITEM #x0001)
-(define-integrable PU_HCONSTRAIN #x0002)
-(define-integrable PU_VCONSTRAIN #x0004)
-(define-integrable PU_NONE #x0000)
-(define-integrable PU_MOUSEBUTTON1DOWN #x0008)
-(define-integrable PU_MOUSEBUTTON2DOWN #x0010)
-(define-integrable PU_MOUSEBUTTON3DOWN #x0018)
-(define-integrable PU_SELECTITEM #x0020)
-(define-integrable PU_MOUSEBUTTON1 #x0040)
-(define-integrable PU_MOUSEBUTTON2 #x0080)
-(define-integrable PU_MOUSEBUTTON3 #x0100)
-(define-integrable PU_KEYBOARD #x0200)
-
-;;; Alarm types (os2win-alarm).
-(define-integrable WA_WARNING 0)
-(define-integrable WA_NOTE 1)
-(define-integrable WA_ERROR 2)
-
-(define-integrable SPTR_ARROW 1)
-(define-integrable SPTR_TEXT 2)
-(define-integrable SPTR_WAIT 3)
-(define-integrable SPTR_SIZE 4)
-(define-integrable SPTR_MOVE 5)
-(define-integrable SPTR_SIZENWSE 6)
-(define-integrable SPTR_SIZENESW 7)
-(define-integrable SPTR_SIZEWE 8)
-(define-integrable SPTR_SIZENS 9)
-(define-integrable SPTR_APPICON 10)
-(define-integrable SPTR_ICONINFORMATION 11)
-(define-integrable SPTR_ICONQUESTION 12)
-(define-integrable SPTR_ICONERROR 13)
-(define-integrable SPTR_ICONWARNING 14)
-(define-integrable SPTR_ILLEGAL 18)
-(define-integrable SPTR_FILE 19)
-(define-integrable SPTR_FOLDER 20)
-(define-integrable SPTR_MULTFILE 21)
-(define-integrable SPTR_PROGRAM 22)
-
-;;; Constants for use with os2win-load-pointer.
-(define-integrable IDI_BCH 10)
-(define-integrable IDI_COFFEE 11)
-(define-integrable IDI_CONSES 12)
-(define-integrable IDI_EDWIN 13)
-(define-integrable IDI_ENVIR1 14)
-(define-integrable IDI_GRAPHICS 15)
-(define-integrable IDI_LAMBDA 16)
-(define-integrable IDI_LAMBDA2 17)
-(define-integrable IDI_LIAR1 18)
-(define-integrable IDI_LIAR2 19)
-(define-integrable IDI_LIAR3 20)
-(define-integrable IDI_MINCER 21)
-(define-integrable IDI_SHIELD1 22)
-(define-integrable IDI_SHIELD2 23)
-(define-integrable IDI_SHIELD3 24)
-(define-integrable IDI_SHIELD4 25)
-
-(define-integrable SV_SWAPBUTTON 0)
-(define-integrable SV_DBLCLKTIME 1)
-(define-integrable SV_CXDBLCLK 2)
-(define-integrable SV_CYDBLCLK 3)
-(define-integrable SV_CXSIZEBORDER 4)
-(define-integrable SV_CYSIZEBORDER 5)
-(define-integrable SV_ALARM 6)
-;;; 7-8
-(define-integrable SV_CURSORRATE 9)
-(define-integrable SV_FIRSTSCROLLRATE 10)
-(define-integrable SV_SCROLLRATE 11)
-(define-integrable SV_NUMBEREDLISTS 12)
-(define-integrable SV_WARNINGFREQ 13)
-(define-integrable SV_NOTEFREQ 14)
-(define-integrable SV_ERRORFREQ 15)
-(define-integrable SV_WARNINGDURATION 16)
-(define-integrable SV_NOTEDURATION 17)
-(define-integrable SV_ERRORDURATION 18)
-;;; 19
-(define-integrable SV_CXSCREEN 20)
-(define-integrable SV_CYSCREEN 21)
-(define-integrable SV_CXVSCROLL 22)
-(define-integrable SV_CYHSCROLL 23)
-(define-integrable SV_CYVSCROLLARROW 24)
-(define-integrable SV_CXHSCROLLARROW 25)
-(define-integrable SV_CXBORDER 26)
-(define-integrable SV_CYBORDER 27)
-(define-integrable SV_CXDLGFRAME 28)
-(define-integrable SV_CYDLGFRAME 29)
-(define-integrable SV_CYTITLEBAR 30)
-(define-integrable SV_CYVSLIDER 31)
-(define-integrable SV_CXHSLIDER 32)
-(define-integrable SV_CXMINMAXBUTTON 33)
-(define-integrable SV_CYMINMAXBUTTON 34)
-(define-integrable SV_CYMENU 35)
-(define-integrable SV_CXFULLSCREEN 36)
-(define-integrable SV_CYFULLSCREEN 37)
-(define-integrable SV_CXICON 38)
-(define-integrable SV_CYICON 39)
-(define-integrable SV_CXPOINTER 40)
-(define-integrable SV_CYPOINTER 41)
-(define-integrable SV_DEBUG 42)
-(define-integrable SV_CMOUSEBUTTONS 43)
-(define-integrable SV_CPOINTERBUTTONS 43)
-(define-integrable SV_POINTERLEVEL 44)
-(define-integrable SV_CURSORLEVEL 45)
-(define-integrable SV_TRACKRECTLEVEL 46)
-(define-integrable SV_CTIMERS 47)
-(define-integrable SV_MOUSEPRESENT 48)
-(define-integrable SV_CXBYTEALIGN 49)
-(define-integrable SV_CXALIGN 49)
-(define-integrable SV_CYBYTEALIGN 50)
-(define-integrable SV_CYALIGN 50)
-;;; 51-55
-(define-integrable SV_NOTRESERVED 56)
-(define-integrable SV_EXTRAKEYBEEP 57)
-(define-integrable SV_SETLIGHTS 58)
-(define-integrable SV_INSERTMODE 59)
-;;; 60-63
-(define-integrable SV_MENUROLLDOWNDELAY 64)
-(define-integrable SV_MENUROLLUPDELAY 65)
-(define-integrable SV_ALTMNEMONIC 66)
-(define-integrable SV_TASKLISTMOUSEACCESS 67)
-(define-integrable SV_CXICONTEXTWIDTH 68)
-(define-integrable SV_CICONTEXTLINES 69)
-(define-integrable SV_CHORDTIME 70)
-(define-integrable SV_CXCHORD 71)
-(define-integrable SV_CYCHORD 72)
-(define-integrable SV_CXMOTIONSTART 73)
-(define-integrable SV_CYMOTIONSTART 74)
-(define-integrable SV_BEGINDRAG 75)
-(define-integrable SV_ENDDRAG 76)
-(define-integrable SV_SINGLESELECT 77)
-(define-integrable SV_OPEN 78)
-(define-integrable SV_CONTEXTMENU 79)
-(define-integrable SV_CONTEXTHELP 80)
-(define-integrable SV_TEXTEDIT 81)
-(define-integrable SV_BEGINSELECT 82)
-(define-integrable SV_ENDSELECT 83)
-(define-integrable SV_BEGINDRAGKB 84)
-(define-integrable SV_ENDDRAGKB 85)
-(define-integrable SV_SELECTKB 86)
-(define-integrable SV_OPENKB 87)
-(define-integrable SV_CONTEXTMENUKB 88)
-(define-integrable SV_CONTEXTHELPKB 89)
-(define-integrable SV_TEXTEDITKB 90)
-(define-integrable SV_BEGINSELECTKB 91)
-(define-integrable SV_ENDSELECTKB 92)
-(define-integrable SV_ANIMATION 93)
-(define-integrable SV_ANIMATIONSPEED 94)
-(define-integrable SV_MONOICONS 95)
-(define-integrable SV_KBDALTERED 96)
-(define-integrable SV_PRINTSCREEN 97)
-(define-integrable SV_LOCKSTARTINPUT 98)
-;;; 99-104
-(define-integrable SV_CSYSVALUES 105)
\ No newline at end of file
\f
(define known-host-types
'((0 UNIX)
- (1 DOS NT OS/2)
- (2 VMS)))
+ (1 DOS NT)))
(define (host-name->index name)
(let loop ((entries known-host-types))
nt/system-root-directory
nt/windows-type
set-environment-variable!
- set-environment-variable-default!)))
- ((os/2)
- (extend-package (runtime os-primitives)
- (files "os2prm")
- (export ()
- dos/fs-drive-type
- dos/fs-long-filenames?
- file-attributes/allocated-length
- file-attributes/modes
- os2-file-mode/archived
- os2-file-mode/directory
- os2-file-mode/hidden
- os2-file-mode/read-only
- os2-file-mode/system
- os2/current-pid
- os2/system-root-directory))))
+ set-environment-variable-default!))))
(define-package (runtime string)
(files "string")
(files "unxdir")))
((nt)
(extend-package (runtime directory)
- (files "ntdir")))
- ((os/2)
- (extend-package (runtime directory)
- (files "os2dir"))))
+ (files "ntdir"))))
(define-package (runtime emacs-interface)
(files "emacs")
starbase-graphics-device-type)
(initialization (initialize-package!)))
-(os-type-case
- ((os/2)
- (define-package (runtime os2-graphics)
- (file-case os-type
- ((os/2) "os2graph" "os2ctype")
- (else))
- (parent (runtime))
- (import (runtime graphics)
- graphics-device/buffer?
- make-image-type)
- (export ()
- os2-console/color?
- os2-console/get-font-metrics
- os2-console/get-frame-position
- os2-console/get-frame-size
- os2-console/get-pel-size
- os2-console/get-size
- os2-console/set-colors!
- os2-console/set-font!
- os2-console/set-frame-position!
- os2-console/set-pel-size!
- os2-console/set-size!
- os2-graphics-device-type
- os2-image/set-colormap
- os2/define-color
- os2/find-color)
- (initialization (initialize-package!)))
-
- (define-package (runtime os2-window-primitives)
- (file-case os-type
- ((os/2) "os2winp")
- (else))
- (parent (runtime))
- (export (runtime os2-graphics)
- bbo_and
- bbo_ignore
- bbo_no_color_info
- bbo_or
- bbo_pal_colors
- button-event-type:click
- button-event-type:double-click
- button-event-type:down
- button-event-type:up
- button-event/flags
- button-event/number
- button-event/type
- button-event/x
- button-event/y
- caps_additional_graphics
- caps_background_mix_support
- caps_bitmap_formats
- caps_bm_and
- caps_bm_desttransparent
- caps_bm_general_boolean
- caps_bm_leavealone
- caps_bm_or
- caps_bm_overpaint
- caps_bm_srctransparent
- caps_bm_xor
- caps_byte_align_not_required
- caps_byte_align_recommended
- caps_byte_align_required
- caps_char_height
- caps_char_width
- caps_clip_fills
- caps_color_bitcount
- caps_color_cursor_support
- caps_color_index
- caps_color_planes
- caps_color_table_support
- caps_colors
- caps_coltabl_realize
- caps_coltabl_rgb_8
- caps_coltabl_rgb_8_plus
- caps_coltabl_true_mix
- caps_cosmetic_wideline_support
- caps_dev_windowing_support
- caps_device_font_sim
- caps_device_fonts
- caps_device_polyset_points
- caps_device_windowing
- caps_direct_fill
- caps_driver_version
- caps_enhanced_fontmetrics
- caps_family
- caps_fm_and
- caps_fm_general_boolean
- caps_fm_leavealone
- caps_fm_or
- caps_fm_overpaint
- caps_fm_xor
- caps_font_image_default
- caps_font_outline_default
- caps_foreground_mix_support
- caps_graphics_char_height
- caps_graphics_char_width
- caps_graphics_kerning_support
- caps_graphics_subset
- caps_graphics_vector_subset
- caps_graphics_version
- caps_height ;pels
- caps_height_in_chars
- caps_horizontal_font_res
- caps_horizontal_resolution
- caps_io_caps
- caps_io_dummy
- caps_io_supports_io
- caps_io_supports_ip
- caps_io_supports_op
- caps_linewidth_thick
- caps_marker_height
- caps_marker_width
- caps_mouse_buttons
- caps_palette_manager
- caps_phys_colors
- caps_raster_banding
- caps_raster_bitblt
- caps_raster_bitblt_scaling
- caps_raster_caps
- caps_raster_flood_fill
- caps_raster_fonts
- caps_raster_set_pel
- caps_rebuild_fills
- caps_scaled_default_markers
- caps_small_char_height
- caps_small_char_width
- caps_tech_postscript
- caps_tech_raster_camera
- caps_tech_raster_display
- caps_tech_raster_printer
- caps_tech_unknown
- caps_tech_vector_plotter
- caps_technology
- caps_transform_support
- caps_vdd_ddb_transfer
- caps_vertical_font_res
- caps_vertical_resolution
- caps_vio_loadable_fonts
- caps_width ;pels
- caps_width_in_chars
- caps_window_byte_alignment
- command-event/code
- cursor_flash
- cursor_frame
- cursor_halftone
- cursor_solid
- event-type
- event-type:button
- event-type:close
- event-type:command
- event-type:focus
- event-type:help
- event-type:key
- event-type:paint
- event-type:resize
- event-type:visibility
- event-wid
- fcf_acceltable
- fcf_autoicon
- fcf_border
- fcf_dlgborder
- fcf_hidebutton
- fcf_hidemax
- fcf_horzscroll
- fcf_icon
- fcf_maxbutton
- fcf_menu
- fcf_minbutton
- fcf_minmax
- fcf_mousealign
- fcf_nobytealign
- fcf_nomovewithowner
- fcf_screenalign
- fcf_shellposition
- fcf_sizeborder
- fcf_standard
- fcf_sysmenu
- fcf_sysmodal
- fcf_tasklist
- fcf_titlebar
- fcf_vertscroll
- fid_client
- fid_horzscroll
- fid_menu
- fid_minmax
- fid_sysmenu
- fid_titlebar
- fid_vertscroll
- fm_and
- fm_default
- fm_invert
- fm_leavealone
- fm_masksrcnot
- fm_mergenotsrc
- fm_mergesrcnot
- fm_notcopysrc
- fm_notmasksrc
- fm_notmergesrc
- fm_notxorsrc
- fm_one
- fm_or
- fm_overpaint
- fm_subtract
- fm_xor
- fm_zero
- focus-event/gained?
- font-metrics/descender
- font-metrics/height
- font-metrics/width
- help-event/code
- hwnd_desktop
- idi_graphics
- kc_alt
- kc_char
- kc_composite
- kc_ctrl
- kc_deadkey
- kc_invalidchar
- kc_invalidcomp
- kc_keyup
- kc_lonekey
- kc_none
- kc_prevdown
- kc_scancode
- kc_shift
- kc_toggle
- kc_virtualkey
- key-event/code
- key-event/flags
- key-event/repeat
- linetype_alternate
- linetype_dashdot
- linetype_dashdoubledot
- linetype_default
- linetype_dot
- linetype_doubledot
- linetype_invisible
- linetype_longdash
- linetype_shortdash
- linetype_solid
- mia_checked
- mia_disabled
- mia_framed
- mia_hilited
- mia_nodismiss
- mis_bitmap
- mis_break
- mis_breakseparator
- mis_buttonseparator
- mis_group
- mis_help
- mis_multmenu
- mis_ownerdraw
- mis_separator
- mis_single
- mis_static
- mis_submenu
- mis_syscommand
- mis_text
- mit_end
- mit_error
- mit_first
- mit_last
- mit_memerror
- mit_none
- ms_actionbar
- ms_conditionalcascade
- ms_titlebutton
- ms_verticalflip
- nullhandle
- number-of-event-types
- os2menu-create
- os2menu-destroy
- os2menu-get-item-attributes
- os2menu-insert-item
- os2menu-n-items
- os2menu-nth-item
- os2menu-remove-item
- os2menu-set-item-attributes
- os2pm-synchronize
- os2ps-bitblt
- os2ps-clear
- os2ps-create-bitmap
- os2ps-create-memory-ps
- os2ps-destroy-bitmap
- os2ps-destroy-memory-ps
- os2ps-draw-point
- os2ps-get-bitmap
- os2ps-get-bitmap-bits
- os2ps-get-bitmap-parameters
- os2ps-get-font-metrics
- os2ps-line
- os2ps-move-graphics-cursor
- os2ps-poly-line
- os2ps-poly-line-disjoint
- os2ps-query-capabilities
- os2ps-query-capability
- os2ps-reset-clip-rectangle
- os2ps-set-bitmap
- os2ps-set-bitmap-bits
- os2ps-set-clip-rectangle
- os2ps-set-colors
- os2ps-set-font
- os2ps-set-line-type
- os2ps-set-mix
- os2ps-text-width
- os2ps-write
- os2win-activate
- os2win-beep
- os2win-close
- os2win-close-event-qid
- os2win-console-wid
- os2win-desktop-height
- os2win-desktop-width
- os2win-destroy-pointer
- os2win-event-ready?
- os2win-focus?
- os2win-frame-handle
- os2win-get-event
- os2win-get-frame-size
- os2win-get-pos
- os2win-get-size
- os2win-invalidate
- os2win-load-pointer
- os2win-move-cursor
- os2win-open
- os2win-open-event-qid
- os2win-ps
- os2win-scroll
- os2win-set-grid
- os2win-set-icon
- os2win-set-pos
- os2win-set-size
- os2win-set-state
- os2win-set-title
- os2win-shape-cursor
- os2win-show
- os2win-show-cursor
- os2win-update-frame
- paint-event/xh
- paint-event/xl
- paint-event/yh
- paint-event/yl
- resize-event/height
- resize-event/width
- rop_dstinvert
- rop_mergecopy
- rop_mergepaint
- rop_notsrccopy
- rop_notsrcerase
- rop_one
- rop_patcopy
- rop_patinvert
- rop_patpaint
- rop_srcand
- rop_srccopy
- rop_srcerase
- rop_srcinvert
- rop_srcpaint
- rop_zero
- set-event-wid!
- virtual-key-supremum
- visibility-event/shown?
- vk_alt
- vk_altgraf
- vk_backspace
- vk_backtab
- vk_break
- vk_button1
- vk_button2
- vk_button3
- vk_capslock
- vk_clear
- vk_ctrl
- vk_delete
- vk_down
- vk_end
- vk_enddrag
- vk_enter
- vk_ereof
- vk_esc
- vk_f1
- vk_f10
- vk_f11
- vk_f12
- vk_f13
- vk_f14
- vk_f15
- vk_f16
- vk_f17
- vk_f18
- vk_f19
- vk_f2
- vk_f20
- vk_f21
- vk_f22
- vk_f23
- vk_f24
- vk_f3
- vk_f4
- vk_f5
- vk_f6
- vk_f7
- vk_f8
- vk_f9
- vk_home
- vk_insert
- vk_left
- vk_newline
- vk_numlock
- vk_pa1
- vk_pagedown
- vk_pageup
- vk_pause
- vk_printscrn
- vk_right
- vk_scrllock
- vk_shift
- vk_space
- vk_sysrq
- vk_tab
- vk_up
- window-state:activate
- window-state:bottom
- window-state:deactivate
- window-state:hide
- window-state:maximize
- window-state:minimize
- window-state:restore
- window-state:show
- window-state:top
- ws_animate
- ws_clipchildren
- ws_clipsiblings
- ws_disabled
- ws_maximized
- ws_minimized
- ws_parentclip
- ws_savebits
- ws_syncpaint
- ws_visible
- ))
- ))
-
(define-package (runtime state-space)
(files "wind")
(parent (runtime))
(sf-conditionally "gentag")
(sf-conditionally "graphics")
(sf-conditionally "infstr")
- (sf-conditionally "os2winp")
(sf-conditionally "port")
(sf-conditionally "input")
UNIX-BLOCK-DEVICE
UNIX-NAMED-PIPE
UNIX-SOCKET
- OS2-NAMED-PIPE
+ UNKNOWN
WIN32-NAMED-PIPE)))
(if (fix:< n (vector-length types))
(vector-ref types n)
(lambda (k)
(if (not name)
(signal-user-microcode-reset k)
- (case microcode-id/operating-system
- ((OS/2)
- (cond ((string=? "XCPT_FLOAT_UNDERFLOW" name)
- (signal-floating-point-underflow k #f '()))
- ((or (string=? "XCPT_FLOAT_OVERFLOW" name)
- (string=? "XCPT_INTEGER_OVERFLOW" name))
- (signal-floating-point-overflow k #f '()))
- ((string=? "XCPT_FLOAT_DIVIDE_BY_ZERO" name)
- (signal-floating-point-divide-by-zero k #f '()))
- ((string=? "XCPT_INTEGER_DIVIDE_BY_ZERO" name)
- (signal-integer-divide-by-zero k #f '()))
- ((string=? "XCPT_FLOAT_INEXACT_RESULT" name)
- (signal-inexact-floating-point-result k #f '()))
- ((string=? "XCPT_FLOAT_INVALID_OPERATION" name)
- (signal-invalid-floating-point-operation k #f '()))
- ((or (string=? "XCPT_FLOAT_DENORMAL_OPERAND" name)
- (string=? "XCPT_FLOAT_STACK_CHECK" name)
- (string=? "XCPT_B1NPX_ERRATA_02" name))
- (signal-arithmetic-error k #f '()))
- (else
- (signal-hardware-trap k name #f))))
- (else
- (let ((code
- (let ((frame (continuation/first-subproblem k)))
- (and (hardware-trap-frame? frame)
- (hardware-trap-frame/code frame)))))
- (if (string=? "SIGFPE" name)
- ((case (and (string? code)
- (normalize-trap-code-name code))
- ((DIVIDE-BY-ZERO) signal-divide-by-zero)
- ((FLOATING-POINT-DIVIDE-BY-ZERO)
- signal-floating-point-divide-by-zero)
- ((INEXACT-RESULT)
- signal-inexact-floating-point-result)
- ((INTEGER-DIVIDE-BY-ZERO)
- signal-integer-divide-by-zero)
- ((INVALID-OPERATION)
- signal-invalid-floating-point-operation)
- ((OVERFLOW) signal-floating-point-overflow)
- ((UNDERFLOW) signal-floating-point-underflow)
- (else signal-arithmetic-error))
- k #f '())
- (signal-hardware-trap k name code)))))))))))
+ (let ((code
+ (let ((frame (continuation/first-subproblem k)))
+ (and (hardware-trap-frame? frame)
+ (hardware-trap-frame/code frame)))))
+ (if (string=? "SIGFPE" name)
+ ((case (and (string? code)
+ (normalize-trap-code-name code))
+ ((DIVIDE-BY-ZERO) signal-divide-by-zero)
+ ((FLOATING-POINT-DIVIDE-BY-ZERO)
+ signal-floating-point-divide-by-zero)
+ ((INEXACT-RESULT)
+ signal-inexact-floating-point-result)
+ ((INTEGER-DIVIDE-BY-ZERO)
+ signal-integer-divide-by-zero)
+ ((INVALID-OPERATION)
+ signal-invalid-floating-point-operation)
+ ((OVERFLOW) signal-floating-point-overflow)
+ ((UNDERFLOW) signal-floating-point-underflow)
+ (else signal-arithmetic-error))
+ k #f '())
+ (signal-hardware-trap k name code)))))))))
;;; end INITIALIZE-PACKAGE!.
)
\ No newline at end of file
microcode-id/operating-system
os-type)
((NT) "w32")
- ((OS/2) "os2")
((UNIX) "unx")
(else (error "Unknown operating system:" os-type))))
\f
|#
;;;; Student graphics Interface
-;;;; implemented for X Windows/ Win32 / OS2
+;;;; implemented for X Windows/ Win32
(declare (usual-integrations))
\f
(set! graphics-available?
(lambda ()
(or (graphics-type-available? 'X)
- (graphics-type-available? 'WIN32)
- (graphics-type-available? 'OS/2))))
+ (graphics-type-available? 'WIN32))))
(set! graphics-text
(lambda (text x y)
(make-graphics-device 'X #F "512x388"))
((graphics-type-available? 'WIN32)
(make-graphics-device 'WIN32 512 388))
- ((graphics-type-available? 'OS/2)
- (make-graphics-device 'OS/2 512 388))
(else
(error "Graphics is not available"))))
(graphics-set-coordinate-limits graphics-device -256 -195 255 194)
static SCHEME_OBJECT * memory_base;
-#ifdef OS2
-
-#include <fcntl.h>
-#include <io.h>
-#include <sys\types.h>
-
-#define fread OS2_fread
-extern off_t EXFUN (OS2_fread, (char *, unsigned int, off_t, FILE *));
-
-#define fwrite OS2_fwrite
-extern off_t EXFUN (OS2_fwrite, (char *, unsigned int, off_t, FILE *));
-
-#endif /* OS2 */
-
long
DEFUN (Load_Data, (Count, To_Where), long Count AND SCHEME_OBJECT *To_Where)
{
-#ifdef OS2
- setmode ((fileno (stdin)), O_BINARY);
-#endif /* OS2 */
-
return (fread (((char *) To_Where),
(sizeof (SCHEME_OBJECT)),
Count,
;; operating system are actually loaded and initialized.
(RUNTIME STARBASE-GRAPHICS)
(RUNTIME X-GRAPHICS)
- (RUNTIME OS2-GRAPHICS)
;; Emacs -- last because it installs hooks everywhere which must be initted.
(RUNTIME EMACS-INTERFACE)
;; More debugging
((unix) "unxprm")
((dos) "dosprm")
((nt) "ntprm")
- ((os/2) "os2prm")
(else)))
(define-package (package)
(file-case os-type
((unix) "unxdir")
((dos) "dosdir")
- ((os/2) "os2dir")
((nt) "ntdir")
;;(else "unkdir")
(else))
make-graphics-device
make-graphics-device-type)
(export (runtime x-graphics)
- make-image-type)
- (export (runtime os2-graphics)
- graphics-device/buffer?
make-image-type))
(define-package (runtime x-graphics)
starbase-graphics-device-type)
(initialization (initialize-package!)))
-(define-package (runtime os2-graphics)
- (file-case os-type
- ((os/2) "os2graph" "os2ctype")
- (else))
- (parent ())
- (export ()
- os2-console/color?
- os2-console/get-font-metrics
- os2-console/get-frame-position
- os2-console/get-frame-size
- os2-console/get-pel-size
- os2-console/get-size
- os2-console/set-colors!
- os2-console/set-font!
- os2-console/set-frame-position!
- os2-console/set-pel-size!
- os2-console/set-size!
- os2-graphics-device-type
- os2-image/set-colormap
- os2/define-color
- os2/find-color)
- (initialization (initialize-package!)))
-
-(define-package (runtime os2-window-primitives)
- (file-case os-type
- ((os/2) "os2winp")
- (else))
- (parent ())
- (export (runtime os2-graphics)
- bbo_and
- bbo_ignore
- bbo_no_color_info
- bbo_or
- bbo_pal_colors
- button-event-type:click
- button-event-type:double-click
- button-event-type:down
- button-event-type:up
- button-event/flags
- button-event/number
- button-event/type
- button-event/x
- button-event/y
- caps_additional_graphics
- caps_background_mix_support
- caps_bitmap_formats
- caps_bm_and
- caps_bm_desttransparent
- caps_bm_general_boolean
- caps_bm_leavealone
- caps_bm_or
- caps_bm_overpaint
- caps_bm_srctransparent
- caps_bm_xor
- caps_byte_align_not_required
- caps_byte_align_recommended
- caps_byte_align_required
- caps_char_height
- caps_char_width
- caps_clip_fills
- caps_color_bitcount
- caps_color_cursor_support
- caps_color_index
- caps_color_planes
- caps_color_table_support
- caps_colors
- caps_coltabl_realize
- caps_coltabl_rgb_8
- caps_coltabl_rgb_8_plus
- caps_coltabl_true_mix
- caps_cosmetic_wideline_support
- caps_dev_windowing_support
- caps_device_font_sim
- caps_device_fonts
- caps_device_polyset_points
- caps_device_windowing
- caps_direct_fill
- caps_driver_version
- caps_enhanced_fontmetrics
- caps_family
- caps_fm_and
- caps_fm_general_boolean
- caps_fm_leavealone
- caps_fm_or
- caps_fm_overpaint
- caps_fm_xor
- caps_font_image_default
- caps_font_outline_default
- caps_foreground_mix_support
- caps_graphics_char_height
- caps_graphics_char_width
- caps_graphics_kerning_support
- caps_graphics_subset
- caps_graphics_vector_subset
- caps_graphics_version
- caps_height ;pels
- caps_height_in_chars
- caps_horizontal_font_res
- caps_horizontal_resolution
- caps_io_caps
- caps_io_dummy
- caps_io_supports_io
- caps_io_supports_ip
- caps_io_supports_op
- caps_linewidth_thick
- caps_marker_height
- caps_marker_width
- caps_mouse_buttons
- caps_palette_manager
- caps_phys_colors
- caps_raster_banding
- caps_raster_bitblt
- caps_raster_bitblt_scaling
- caps_raster_caps
- caps_raster_flood_fill
- caps_raster_fonts
- caps_raster_set_pel
- caps_rebuild_fills
- caps_scaled_default_markers
- caps_small_char_height
- caps_small_char_width
- caps_tech_postscript
- caps_tech_raster_camera
- caps_tech_raster_display
- caps_tech_raster_printer
- caps_tech_unknown
- caps_tech_vector_plotter
- caps_technology
- caps_transform_support
- caps_vdd_ddb_transfer
- caps_vertical_font_res
- caps_vertical_resolution
- caps_vio_loadable_fonts
- caps_width ;pels
- caps_width_in_chars
- caps_window_byte_alignment
- command-event/code
- cursor_flash
- cursor_frame
- cursor_halftone
- cursor_solid
- event-type
- event-type:button
- event-type:close
- event-type:command
- event-type:focus
- event-type:help
- event-type:key
- event-type:paint
- event-type:resize
- event-type:visibility
- event-wid
- fcf_acceltable
- fcf_autoicon
- fcf_border
- fcf_dlgborder
- fcf_hidebutton
- fcf_hidemax
- fcf_horzscroll
- fcf_icon
- fcf_maxbutton
- fcf_menu
- fcf_minbutton
- fcf_minmax
- fcf_mousealign
- fcf_nobytealign
- fcf_nomovewithowner
- fcf_screenalign
- fcf_shellposition
- fcf_sizeborder
- fcf_standard
- fcf_sysmenu
- fcf_sysmodal
- fcf_tasklist
- fcf_titlebar
- fcf_vertscroll
- fid_client
- fid_horzscroll
- fid_menu
- fid_minmax
- fid_sysmenu
- fid_titlebar
- fid_vertscroll
- fm_and
- fm_default
- fm_invert
- fm_leavealone
- fm_masksrcnot
- fm_mergenotsrc
- fm_mergesrcnot
- fm_notcopysrc
- fm_notmasksrc
- fm_notmergesrc
- fm_notxorsrc
- fm_one
- fm_or
- fm_overpaint
- fm_subtract
- fm_xor
- fm_zero
- focus-event/gained?
- font-metrics/descender
- font-metrics/height
- font-metrics/width
- help-event/code
- hwnd_desktop
- idi_graphics
- kc_alt
- kc_char
- kc_composite
- kc_ctrl
- kc_deadkey
- kc_invalidchar
- kc_invalidcomp
- kc_keyup
- kc_lonekey
- kc_none
- kc_prevdown
- kc_scancode
- kc_shift
- kc_toggle
- kc_virtualkey
- key-event/code
- key-event/flags
- key-event/repeat
- linetype_alternate
- linetype_dashdot
- linetype_dashdoubledot
- linetype_default
- linetype_dot
- linetype_doubledot
- linetype_invisible
- linetype_longdash
- linetype_shortdash
- linetype_solid
- mia_checked
- mia_disabled
- mia_framed
- mia_hilited
- mia_nodismiss
- mis_bitmap
- mis_break
- mis_breakseparator
- mis_buttonseparator
- mis_group
- mis_help
- mis_multmenu
- mis_ownerdraw
- mis_separator
- mis_single
- mis_static
- mis_submenu
- mis_syscommand
- mis_text
- mit_end
- mit_error
- mit_first
- mit_last
- mit_memerror
- mit_none
- ms_actionbar
- ms_conditionalcascade
- ms_titlebutton
- ms_verticalflip
- nullhandle
- number-of-event-types
- os2menu-create
- os2menu-destroy
- os2menu-get-item-attributes
- os2menu-insert-item
- os2menu-n-items
- os2menu-nth-item
- os2menu-remove-item
- os2menu-set-item-attributes
- os2pm-synchronize
- os2ps-bitblt
- os2ps-clear
- os2ps-create-bitmap
- os2ps-create-memory-ps
- os2ps-destroy-bitmap
- os2ps-destroy-memory-ps
- os2ps-draw-point
- os2ps-get-bitmap
- os2ps-get-bitmap-bits
- os2ps-get-bitmap-parameters
- os2ps-get-font-metrics
- os2ps-line
- os2ps-move-graphics-cursor
- os2ps-poly-line
- os2ps-poly-line-disjoint
- os2ps-query-capabilities
- os2ps-query-capability
- os2ps-reset-clip-rectangle
- os2ps-set-bitmap
- os2ps-set-bitmap-bits
- os2ps-set-clip-rectangle
- os2ps-set-colors
- os2ps-set-font
- os2ps-set-line-type
- os2ps-set-mix
- os2ps-text-width
- os2ps-write
- os2win-activate
- os2win-beep
- os2win-close
- os2win-close-event-qid
- os2win-console-wid
- os2win-desktop-height
- os2win-desktop-width
- os2win-destroy-pointer
- os2win-event-ready?
- os2win-focus?
- os2win-frame-handle
- os2win-get-event
- os2win-get-frame-size
- os2win-get-pos
- os2win-get-size
- os2win-invalidate
- os2win-load-pointer
- os2win-move-cursor
- os2win-open
- os2win-open-event-qid
- os2win-ps
- os2win-scroll
- os2win-set-grid
- os2win-set-icon
- os2win-set-pos
- os2win-set-size
- os2win-set-state
- os2win-set-title
- os2win-shape-cursor
- os2win-show
- os2win-show-cursor
- os2win-update-frame
- paint-event/xh
- paint-event/xl
- paint-event/yh
- paint-event/yl
- resize-event/height
- resize-event/width
- rop_dstinvert
- rop_mergecopy
- rop_mergepaint
- rop_notsrccopy
- rop_notsrcerase
- rop_one
- rop_patcopy
- rop_patinvert
- rop_patpaint
- rop_srcand
- rop_srccopy
- rop_srcerase
- rop_srcinvert
- rop_srcpaint
- rop_zero
- set-event-wid!
- virtual-key-supremum
- visibility-event/shown?
- vk_alt
- vk_altgraf
- vk_backspace
- vk_backtab
- vk_break
- vk_button1
- vk_button2
- vk_button3
- vk_capslock
- vk_clear
- vk_ctrl
- vk_delete
- vk_down
- vk_end
- vk_enddrag
- vk_enter
- vk_ereof
- vk_esc
- vk_f1
- vk_f10
- vk_f11
- vk_f12
- vk_f13
- vk_f14
- vk_f15
- vk_f16
- vk_f17
- vk_f18
- vk_f19
- vk_f2
- vk_f20
- vk_f21
- vk_f22
- vk_f23
- vk_f24
- vk_f3
- vk_f4
- vk_f5
- vk_f6
- vk_f7
- vk_f8
- vk_f9
- vk_home
- vk_insert
- vk_left
- vk_newline
- vk_numlock
- vk_pa1
- vk_pagedown
- vk_pageup
- vk_pause
- vk_printscrn
- vk_right
- vk_scrllock
- vk_shift
- vk_space
- vk_sysrq
- vk_tab
- vk_up
- window-state:activate
- window-state:bottom
- window-state:deactivate
- window-state:hide
- window-state:maximize
- window-state:minimize
- window-state:restore
- window-state:show
- window-state:top
- ws_animate
- ws_clipchildren
- ws_clipsiblings
- ws_disabled
- ws_maximized
- ws_minimized
- ws_parentclip
- ws_savebits
- ws_syncpaint
- ws_visible
- ))
-
(define-package (runtime state-space)
(files "wind")
(parent ())
projects / mit-scheme.git / commitdiff